unit PlugServ;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, ActiveX, Classes, ComObj, CM2GenInterface,
  CM2AutoUpdateInterface, xmldom, XMLIntf, StdCtrls, msxmldom, XMLDoc, forms;

type
  TReuterRSS = class(TComObject, ICM2GenPlug, ICM2AutoUpdate)
  private
   lasterrmsg: String;
   Parent: THandle;
   rss: TXMLDocument;
   dummyForm: TForm;
   filename: String;
   rssItemNumber: Integer;
   refrss: TStrings;
   Procedure Parser(Parameters: String);
   Procedure refineRSS;
  protected
  // Declare Basics
   Function Name(OUT Name: Pchar): HResult; stdcall;
   Function Version(OUT Version: word): HResult; stdcall; // Using MMRB Notation
   Function RequiredCoreVersion(OUT RCV: Word): HResult; stdcall; // Using MMRB Notation - Please refer to CM2Plugtypes for details
   Function SetParentHandle(Handle: THandle): HResult; stdcall;
  // Declare Error commands
   Function GetLastErrorMsg(OUT ErrMsg: PChar): HResult; stdcall;
  // Declare Info system
   Function GetInfoCount(OUT InfoCount: Integer): HResult; stdcall;
   Function GetInfo(Index: Integer; OUT InfoName: PChar; OUT InfoVar: PChar): HResult; stdcall;
  // Declare Sensor system
   Function GetSensorCount(OUT SensorCount: Integer): HResult; stdcall;
   Function GetSensorNameOnly(Index: Integer; OUT SensorName: PChar; OUT SensorStyle: Byte): HResult; stdcall; // Designed for speed polling at startup
   Function GetSensor(Index: Integer; Parameters: PChar; OUT SensorName: PChar; OUT SensorStyle: byte; OUT SensorString: PChar; OUT SensorValue: Double): HResult; stdcall;
  // Declare "Event" functions
   Function Init: HResult; stdcall;
   Function Terminating: HResult; stdcall;
   Function Setup: HResult; stdcall;
  // Declare Support types
   // Default (Required)
   Function GetDefaultCount(SensorIndex: Integer; OUT DefaultCount: Integer): HResult; stdcall;
   Function GetDefault(SensorIndex: Integer; Index: Integer; OUT Name: Pchar; OUT Value: PChar; OUT Description: PChar): HResult; stdcall;
   // Optional
   Function GetOptionalCount(SensorIndex: Integer; OUT OptionalCount: Integer): HResult; stdcall;
   Function GetOptional(SensorIndex: Integer; Index: Integer; OUT Name: Pchar; OUT Value: PChar; OUT Description: PChar): HResult; stdcall;
   // Auto update
   Function UpdateFileURL(OUT URL: Pchar): HResult; stdcall;
  end;

const
  Class_ReuterRSS: TGUID = '{F8BCC445-BAF3-4658-88C2-7491052F7452}';
  RCVersion = 0500;
  PlugVersion = 0200;
  UpdFile = 'http://www.coolmon.org/update/rss.upd';

implementation

uses ComServ, filter, sysutils, Dialogs;

{ TReuterRSS }

function TReuterRSS.GetDefault(SensorIndex, Index: Integer; out Name,
  Value, Description: PChar): HResult;
begin
 Case SensorIndex of
  0: begin
      case Index of
       0: begin
           Name := 'filename';
           Value := 'http://rss.news.yahoo.com/rss/topstories';
           Description := 'The url to the RSS Version 2.0 feed you wish to track';
          end;
      end;
     end;
  1: begin
      case Index of
       0: Begin
           Name := 'ItemNo';
           Value := '0';
           Description := 'RSS feed Item# you want to extract';
          end;
       end;
     end;
 end;
 Result := S_OK;
end;

function TReuterRSS.GetDefaultCount(SensorIndex: Integer;
  out DefaultCount: Integer): HResult;
begin
 Case SensorIndex of
  0: DefaultCount := 1;
  1: DefaultCount := 1;
 end;
 Result := S_OK;
end;

function TReuterRSS.GetInfo(Index: Integer; out InfoName,
  InfoVar: PChar): HResult;
begin
 Result := S_OK;
 Case index of
  0: Begin Infoname := 'Programmed By'; InfoVar := 'Christian Aaangel'; End;
  1: Begin Infoname := 'Created'; InfoVar := 'August 31st, 2004'; end;
  2: Begin Infoname := 'Updated'; InfoVar := 'August 31st, 2004'; end;
  3: Begin Infoname := 'Copyright'; Infovar := '(c) 2004 by The CoolMon Project'; end;
  else
   begin
    Result := E_FAIL;
    Lasterrmsg := 'Index out of bounds';
   end;
 End;
end;

function TReuterRSS.GetInfoCount(out InfoCount: Integer): HResult;
begin
 InfoCount := 4;
 result := S_OK;
end;

function TReuterRSS.GetLastErrorMsg(out ErrMsg: PChar): HResult;
begin
 If lasterrmsg = '' then Lasterrmsg := 'No error';
 ErrMsg := PChar(lasterrmsg);
 Result := S_OK;
end;

function TReuterRSS.GetOptional(SensorIndex, Index: Integer; out Name,
  Value, Description: PChar): HResult;
begin
 Result := S_OK;
end;

function TReuterRSS.GetOptionalCount(SensorIndex: Integer;
  out OptionalCount: Integer): HResult;
begin
 OptionalCount := 0;
 Result := S_OK;
end;

function TReuterRSS.GetSensor(Index: Integer; Parameters: PChar;
  out SensorName: PChar; out SensorStyle: byte; out SensorString: PChar;
  out SensorValue: Double): HResult;
begin
 Parser(Parameters);
 Case Index of
  0: begin
      Result := GetSensorNameOnly(Index, Sensorname, sensorstyle);
      If filename = '' then exit;
      If rss.FileName <> filename then begin
       rss.filename := filename;
      end;
      rss.Active := true;
      refineRSS;
      rss.active := False;
      SensorStyle := ssNumeric;
      SensorValue := 0;
     end;
  1: begin
      Result := GetSensorNameOnly(Index, Sensorname, sensorstyle);
      If (rssItemNumber > -1) and (rssItemNumber < refrss.Count) then begin
       SensorStyle := ssNonNumeric;
       SensorString := Pchar(refrss[rssItemNumber]);
      end;
     end;
 else
  begin
   LastErrMsg := 'Index out of bounds';
   result := E_FAIL;
  end;
 end;
end;

function TReuterRSS.GetSensorCount(out SensorCount: Integer): HResult;
begin
 SensorCount := 2;
 Result := S_OK;
end;

function TReuterRSS.GetSensorNameOnly(Index: Integer;
  out SensorName: PChar; out SensorStyle: Byte): HResult;
begin
 Result := S_OK;
 Case Index of
  0: begin
      SensorName := 'RSSLoad';
      SensorStyle := ssUnknown;
     end;
  1: begin
      SensorName := 'RSSItem';
      SensorStyle := ssNonNumeric;
     end;
  else
  begin
   Result := E_FAIL;
   LasterrMsg := 'Index out of bounds';
  end;
 End;
end;

function TReuterRSS.Init: HResult;
begin
 Result := S_OK;
 Try
  dummyform := TForm.CreateParented(parent);
  rss := TXMLDocument.Create(dummyform);
  refrss := TStringList.Create;
 except
  LastErrMsg := 'Failure in init block';
  result := E_FAIL;
 end;
end;

function TReuterRSS.Name(out Name: Pchar): HResult;
begin
 name := 'RSS';
 Result := S_OK;
end;

procedure TReuterRSS.Parser(Parameters: String);
Var
 I: Integer;
 N, V: String;
begin
 For I := 1 to countfilt(parameters, '|') do begin
  N := GetFilt(Parameters, I, '|');
  V := GetFilt(N, 2, '=');
  N := GetFilt(N, 1, '=');
  If uppercase(N) = 'FILENAME' then Filename := V;
  If uppercase(N) = 'ITEMNO' then begin
   Try
    rssItemNumber := StrToInt(V);
   except
    rssItemNumber := -1;
   end;
  end;
 end;
end;

procedure TReuterRSS.refineRSS;
Var
 node, subnode: IXMLNode;
 I: Integer;
begin
 refrss.clear;
 node := rss.ChildNodes.FindNode('rss');
 node := node.ChildNodes.FindNode('channel');
 For I := 0 to node.ChildNodes.Count - 1 do begin
  If node.ChildNodes[I].NodeName = 'item' then begin
   subnode := node.childnodes[I];
   refrss.add(subnode.ChildNodes.FindNode('title').NodeValue);
  end;
 end;
end;

function TReuterRSS.RequiredCoreVersion(out RCV: Word): HResult;
begin
 Rcv := RCVersion;
 Result := S_OK;
end;

function TReuterRSS.SetParentHandle(Handle: THandle): HResult;
begin
 Parent := Handle;
 Result := S_OK;
end;

function TReuterRSS.Setup: HResult;
begin
 result := E_NOTIMPL;
end;

function TReuterRSS.Terminating: HResult;
begin
 FreeAndnil(refrss);
 FreeAndNil(rss);
 FreeAndNil(dummyform);
 Result := S_OK;
end;

function TReuterRSS.UpdateFileURL(out URL: Pchar): HResult;
begin
 URL := PChar(Updfile);
 Result := S_OK;
end;

function TReuterRSS.Version(out Version: word): HResult;
begin
 Version := PlugVersion;
 result := S_OK;
end;

initialization
  TComObjectFactory.Create(ComServer, TReuterRSS, Class_ReuterRSS,
    'ReuterRSS', 'Grab Reuter.com headlines', ciMultiInstance, tmApartment);
end.
