RSS
From Lazarus wiki
Jump to navigationJump to searchThe printable version is no longer supported and may have rendering errors. Please update your browser bookmarks and please use the default browser print function instead.
│
English (en) │
français (fr) │
Overview
This is a small unit I created to read RSS feeds. Maybe it is useful.
RSS unit code
unit rss;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
lNetComponents, lNet, lhttp, lHTTPUtil, DOM, XMLRead, db;
const
RSSXML_RSS = 'rss';
RSSXML_CHANNEL = 'channel';
RSSXML_ITEM = 'item';
RSSXML_TITLE = 'title';
RSSXML_LINK = 'link';
RSSXML_DESCRIPTION = 'description';
RSSXML_PUBDATE = 'pubDate';
RSSXML_COMMENTS = 'comments';
type
{ TFeedItem }
TFeedItem = class(TObject)
private
fTitle, fLink, fComments : String;
fDescription: TStringList;
fPubDate: TDateTime;
public
constructor create();
destructor destroy(); override;
class function CreateFromNode(aNode: TDOMNode): TFeedItem;
property Title : String read fTitle write fTitle;
property Link : String read fLink write fLink;
property Comments : String read fComments write fComments;
property Description : TStringList read fDescription write fDescription;
end;
TFeedReadState = (frReady, frRequest, frParse, frSave, frDone, frError);
// Callback for result report
TRSSResultEvent = procedure(const aFeedID: string) of object;
{ TRssFeed }
TRssFeed = class(TObject)
private
fTitle, fLink, fLanguage, fError, fFeedID: String;
fDescription: TStringList;
fItems: TList;
fXmlString: TStringList;
fReadState: TFeedReadState;
HTTPClient: TLHTTPClientComponent;
HTTPBuffer: string;
fDoc : TXMLDocument;
fOnResult: TRSSResultEvent;
fDatabase: TDatabase;
procedure AddItem(aItem : TFeedItem);
procedure ClearItems;
procedure HTTPClientError(const msg: string; aSocket: TLSocket);
function HTTPClientInput(ASocket: TLHTTPClientSocket; ABuffer: pchar; ASize: integer): integer;
procedure HTTPClientDisconnect(aSocket: TLSocket);
public
constructor create(aLink: String; aFeedID: string; aDatabase: TDatabase);
destructor destroy(); override;
procedure RssRead;
property Title: String read fTitle write fTitle;
property Language: String read fLanguage write fLanguage;
property Link: String read fLink write fLink;
property Description: TStringList read fDescription write fDescription;
property Items: TList read fItems write fItems;
property ReadState: TFeedReadState read fReadState;
property OnResult: TRSSResultEvent read fOnResult write fOnResult;
end;
implementation
{ TFeedItem }
constructor TFeedItem.create();
begin
fDescription := TStringList.Create;
end;
destructor TFeedItem.destroy;
begin
FreeAndNil(fDescription);
inherited destroy;
end;
class function TFeedItem.CreateFromNode(aNode: TDOMNode): TFeedItem;
var
propertynode: TDOMNode;
begin
Result := TFeedItem.Create();
propertynode := aNode.FindNode(RSSXML_TITLE);
if propertynode <> nil then
Result.fTitle := propertynode.TextContent;
propertynode := aNode.FindNode(RSSXML_LINK);
if propertynode <> nil then
Result.fLink := propertynode.TextContent;
propertynode := aNode.FindNode(RSSXML_DESCRIPTION);
if propertynode <> nil then
Result.fDescription.Text := propertynode.TextContent;
propertynode := aNode.FindNode(RSSXML_COMMENTS);
if propertynode <> nil then
Result.fComments := propertynode.TextContent;
end;
{ TRssFeed }
procedure TRssFeed.AddItem(aItem: TFeedItem);
begin
fItems.Add(aItem);
end;
procedure TRssFeed.ClearItems;
var
i: Integer;
Item: TFeedItem;
begin
for i := 0 to fItems.Count - 1 do
begin
Item := TFeedItem(fItems[0]);
FreeAndNil(Item);
end;
fItems.Clear;
end;
procedure TRssFeed.HTTPClientError(const msg: string; aSocket: TLSocket);
begin
fError := msg;
fReadState := frError;
end;
function TRssFeed.HTTPClientInput(ASocket: TLHTTPClientSocket; ABuffer: pchar;
ASize: integer): integer;
var
oldLength: dword;
begin
oldLength := Length(HTTPBuffer);
setlength(HTTPBuffer,oldLength + ASize);
move(ABuffer^,HTTPBuffer[oldLength + 1], ASize);
Result := aSize; // tell the http buffer we read it all
end;
procedure TRssFeed.HTTPClientDisconnect(aSocket: TLSocket);
var
S: TStringStream;
channel, propertynode: TDOMNode;
newsitem: TFeedItem;
begin
fReadState:= frParse;
try
S := TStringStream.Create('');
try
ReadXMLFile(fDoc, S);
finally
S.Free;
end;
except
on E : Exception do
begin
fReadState:= frError;
fError := E.Message;
Exit;
end;
end;
if ((fDoc.documentElement.nodeName = RSSXML_RSS) and
(fDoc.documentElement.hasChildNodes)) then
begin
channel := fDoc.DocumentElement.FindNode(RSSXML_CHANNEL);
if channel <> nil then
begin
propertynode := channel.FindNode(RSSXML_TITLE);
if propertynode <> nil then
fTitle := propertynode.TextContent;
propertynode := channel.FindNode(RSSXML_LINK);
if propertynode <> nil then
fLink := propertynode.TextContent;
propertynode := channel.FindNode(RSSXML_DESCRIPTION);
if propertynode <> nil then
fDescription.Text := propertynode.TextContent;
propertynode := channel.FindNode(RSSXML_ITEM);
while propertynode <> nil do
begin
newsitem:= TFeedItem.CreateFromNode(propertynode);
AddItem(newsitem);
propertynode := propertynode.NextSibling;
end;
end;
end;
fReadState:= frSave;
end;
constructor TRssFeed.create(aLink: String; aFeedID: string; aDatabase: TDatabase);
begin
fFeedID := aFeedID;
fLink := aLink;
fDatabase := aDatabase;
fReadState := frReady;
fDescription := TStringList.Create;
fItems := TList.Create;
HTTPClient := TLHTTPClientComponent.Create(nil);
fDoc := TXMLDocument.create;
end;
destructor TRssFeed.destroy;
begin
ClearItems;
FreeAndNil(fDescription);
FreeAndNil(HTTPClient);
FreeAndNil(fDoc);
inherited destroy;
end;
procedure TRssFeed.RssRead;
var
aHost, aURI: String;
aPort: Word;
begin
DecomposeURL(fLink, aHost, aURI, aPort);
HTTPClient.Host:= aHost;
HTTPClient.Port:= aPort;
HTTPClient.URI:= aURI;
HTTPClient.OnError:= @HTTPClientError;
HTTPClient.OnInput:= @HTTPClientInput;
HTTPClient.OnDisconnect:= @HTTPClientDisconnect;
HTTPClient.SendRequest;
fReadState:= frRequest;
end;
end.