RSS/fr

│ English (en) │ français (fr) │

Vue d'ensemble

C'est une petite unité que Gints a écrit pour lire des flux RSS, en souhaitant qu'elle soit utile.

Code de l'unité RSS

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.