sakurasuite/IdSLPP20.pas

   1 {*******************************************************}
   2 {       IdSLPP20 - Indy Client for SLPP Connection      }
   3 {                                                       }
   4 {       Copyright (c) 2002-2003 naruto/CANO-Lab         }
   5 {*******************************************************}
   6
   7 unit IdSLPP20;
   8
   9 interface
  10
  11 uses
  12   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  13   IdTCPClient, IdGlobal, IdException;
  14
  15 const
  16   SLPP_PORT = 9871;
  17   SLPP_HOST = 'bottle.mikage.to';
  18
  19 type
  20   TIdSLPPEventType = (etConnectOk, etScript, etMemberCount, etChannelCount,
  21                     etChannelList, etUnicast, etForceBroadcast, etCloseChannel,
  22                     etForceBroadcastInformation, etBroadcastInformation);
  23   TIdSLPPEvent = procedure (Sender: TObject;
  24     EventType: TIdSlppEventType; const Param: String) of Object;
  25
  26   TIdSLPP20 = class;
  27
  28   TIdSLPP20ReadThread = class(TThread)
  29   private
  30   protected
  31     FClient: TIdSLPP20;
  32     FRecvData: TStringList;
  33     FEvent: TIdSLPPEventType; // SLPP Command
  34     FParam: String;           // SLPP Command Parameter
  35     FReceivedLog: TStringList;
  36     function Parse: boolean;
  37     procedure Execute; override;
  38   public
  39     constructor Create(AClient: TIdSLPP20); reintroduce;
  40     property  Client: TIdSLPP20 read FClient;
  41   end;
  42
  43   TIdSLPP20 = class(TIdTCPClient)
  44   private
  45     FSLPPThread: TIdSLPP20ReadThread;
  46     FDebugMode: boolean;
  47     FProxyMode: boolean;
  48     FLUID: String;
  49     FOnSlppEvent: TIdSlppEvent;
  50     FOnConnect: TNotifyEvent;
  51     FOnDisconnect: TNotifyEvent;
  52     FLastReadTime: Int64;
  53     FTimeout: Integer;
  54     FOnConnectFailed: TNotifyEvent;
  55     procedure SetDebugMode(const Value: boolean);
  56     procedure SetLUID(const Value: String);
  57     procedure SetOnSlppEvent(const Value: TIdSlppEvent);
  58     procedure SetProxyMode(const Value: boolean);
  59     procedure SetOnConnect(const Value: TNotifyEvent);
  60     procedure SetOnDisconnect(const Value: TNotifyEvent);
  61     function GetLastReadTimeInterval: integer;
  62     procedure SetLastReadTime(const Value: Int64);
  63     procedure SetOnConnectFailed(const Value: TNotifyEvent);
  64   public
  65     constructor Create(AOwner: TComponent); override;
  66     destructor Destroy; override;
  67     procedure Connect(const ATimeout: Integer = IdTimeoutDefault); override;
  68     procedure ConnectServer(const ATimeout: Integer = IdTimeoutDefault);
  69     procedure Disconnect; override;
  70     procedure DoOnSlppEvent;
  71     procedure DoOnConnect;
  72     procedure DoOnConnectFailed;
  73     property SLPP20ReadThread: TIdSLPP20ReadThread read FSLPPThread;
  74     property LastReadTime: Int64 read FLastReadTime write SetLastReadTime;
  75     property LastReadTimeInterval: integer read GetLastReadTimeInterval;
  76   published
  77     property LUID: String read FLUID write SetLUID;
  78     property Port default SLPP_PORT;
  79     property DebugMode: boolean read FDebugMode write SetDebugMode;
  80     property ProxyMode: boolean read FProxyMode write SetProxyMode;
  81     property OnConnect: TNotifyEvent read FOnConnect write SetOnConnect;
  82     property OnConnectFailed: TNotifyEvent read FOnConnectFailed write SetOnConnectFailed;
  83     property OnDisconnect: TNotifyEvent read FOnDisconnect write SetOnDisconnect;
  84     property OnSLPPEvent: TIdSlppEvent read FOnSlppEvent write SetOnSlppEvent;
  85     {ProxyMode = true\82Ì\82Æ\82«\82Í\81AHost, Port\82É\83v\83\8d\83L\83V\96¼\82ð}
  86   end;
  87
  88   EIdSlppError = class(EIdException);
  89   EIdSlppClientConnectError = class(EIdSlppError);
  90
  91 procedure Register;
  92
  93 implementation
  94
  95 procedure Register;
  96 begin
  97   RegisterComponents('Indy Clients', [TIdSLPP20]);
  98 end;
  99
 100 { TIdSLPP20 }
 101
 102 procedure TIdSLPP20.Connect(const ATimeout: Integer);
 103 begin
 104   inherited Connect(ATimeout);
 105 end;
 106
 107 procedure TIdSLPP20.ConnectServer;
 108 begin
 109   try
 110     FTimeout := ATimeout;
 111     FSLPPThread := TIdSLPP20ReadThread.Create(self);
 112   except on E: EIdSocketError do
 113     raise EIdSlppClientConnectError.Create('Connection Failed');
 114   end;
 115 end;
 116
 117 constructor TIdSLPP20.Create(AOwner: TComponent);
 118 begin
 119   inherited Create(AOwner);
 120   Port := SLPP_PORT;
 121   Host := SLPP_HOST;
 122 end;
 123
 124 destructor TIdSLPP20.Destroy;
 125 begin
 126   inherited;
 127 end;
 128
 129 procedure TIdSLPP20.Disconnect;
 130 begin
 131   inherited Disconnect;
 132   if Assigned(FSLPPThread) then begin
 133     FSLPPThread.Terminate;
 134     // FSLPPThread.WaitFor;
 135     FSLPPThread := nil;
 136   end;
 137   if Assigned(FOnDisconnect) then begin
 138     OnDisconnect(self);
 139   end;
 140 end;
 141
 142 procedure TIdSLPP20.DoOnConnect;
 143 begin
 144   if Assigned(FOnConnect) then
 145     FOnConnect(self);
 146 end;
 147
 148 procedure TIdSLPP20.DoOnConnectFailed;
 149 begin
 150   if Assigned(FOnConnectFailed) then
 151     FOnConnectFailed(self);
 152 end;
 153
 154 procedure TIdSLPP20.DoOnSlppEvent;
 155 begin
 156   try
 157     FOnSlppEvent(self, FSLPPThread.FEvent, FSLPPThread.FParam);
 158   except
 159     on E: Exception do
 160       ShowMessage('Exception occured in OnSlppEvent: '#13#10 + E.Message);
 161   end;
 162 end;
 163
 164 function TIdSLPP20.GetLastReadTimeInterval: integer;
 165 begin
 166   Result := 0;
 167   if Connected then Result := GetTickCount - FLastReadTime;
 168 end;
 169
 170 procedure TIdSLPP20.SetDebugMode(const Value: boolean);
 171 begin
 172   FDebugMode := Value;
 173 end;
 174
 175 procedure TIdSLPP20.SetLastReadTime(const Value: Int64);
 176 begin
 177   FLastReadTime := Value;
 178 end;
 179
 180 procedure TIdSLPP20.SetLUID(const Value: String);
 181 begin
 182   FLUID := Value;
 183 end;
 184
 185 procedure TIdSLPP20.SetOnConnect(const Value: TNotifyEvent);
 186 begin
 187   FOnConnect := Value;
 188 end;
 189
 190 procedure TIdSLPP20.SetOnConnectFailed(const Value: TNotifyEvent);
 191 begin
 192   FOnConnectFailed := Value;
 193 end;
 194
 195 procedure TIdSLPP20.SetOnDisconnect(const Value: TNotifyEvent);
 196 begin
 197   FOnDisconnect := Value;
 198 end;
 199
 200 procedure TIdSLPP20.SetOnSlppEvent(const Value: TIdSlppEvent);
 201 begin
 202   FOnSlppEvent := Value;
 203 end;
 204
 205 procedure TIdSLPP20.SetProxyMode(const Value: boolean);
 206 begin
 207   FProxyMode := Value;
 208 end;
 209
 210 { TIdSLPP20ReadThread }
 211
 212 constructor TIdSLPP20ReadThread.Create(AClient: TIdSLPP20);
 213 begin
 214   inherited Create(true);
 215   FClient := AClient;
 216   FreeOnTerminate := true;
 217   Resume;
 218 end;
 219
 220 procedure TIdSLPP20ReadThread.Execute;
 221 var Line: String;
 222 begin
 223   try
 224     FClient.Connect(FClient.FTimeout);
 225     if Assigned(FClient.OnConnect) then begin
 226       Synchronize(FClient.DoOnConnect);
 227     end;
 228   except
 229     Synchronize(FClient.DoOnConnectFailed);
 230     Exit;
 231   end;
 232
 233   FRecvData := TStringList.Create;
 234   FReceivedLog := TStringList.Create;
 235   if FClient.ProxyMode then begin
 236     FClient.Writeln('POST http://bottle.mikage.to:9871/ HTTP/1.0');
 237     FClient.Writeln('Content-Length: ' + IntToStr(Length(FClient.LUID)));
 238     FClient.Writeln('Connection: close');
 239     FClient.Writeln;
 240     FClient.Writeln(FClient.LUID);
 241   end else begin
 242     FClient.WriteLn('POST / HTTP/1.0');
 243     FClient.WriteLn;
 244     FClient.WriteLn(FClient.LUID);
 245   end;
 246   while not Terminated do begin
 247     try
 248       FClient.CheckForDisconnect;
 249       Line := FClient.ReadLn(EOL);
 250       if FClient.DebugMode then begin
 251         FReceivedLog.Add(Line);
 252         FReceivedLog.SaveToFile(ExtractFilePath(Application.ExeName)+'slpp20_debug.log');
 253       end;
 254       if not FClient.ReadLnTimedOut then FClient.LastReadTime := getTickCount;
 255       if Length(Line) = 0 then begin
 256         if FRecvData.Count > 0 then begin
 257           while Parse do begin
 258             Synchronize(FClient.DoOnSlppEvent);
 259           end;
 260           FRecvData.Clear;
 261         end;
 262       end else begin
 263         FRecvData.Add(Line);
 264       end;
 265     except
 266       on EIdException do begin
 267         Synchronize(self.Terminate);
 268       end;
 269     end;
 270   end;
 271   FreeAndNil(FReceivedLog);
 272   FreeAndNil(FRecvData);
 273 end;
 274
 275 function TIdSLPP20ReadThread.Parse: boolean;
 276 var
 277   command: String;
 278 begin
 279   command := FRecvData[0];
 280   FRecvData.Delete(0);
 281   FParam := FRecvData.Text;
 282
 283   Result := true;
 284   if command = 'broadcastMessage' then begin
 285     FEvent := etScript;
 286   end else if command = 'allUsers' then begin
 287     FEvent := etMemberCount;
 288   end else if command = 'channelUsers' then begin
 289     FEvent := etChannelCount;
 290   end else if command = 'channelList' then begin
 291     FEvent := etChannelList;
 292   end else if (command = 'HTTP/1.0 200 OK') or (command = 'HTTP/1.1 200 OK') then begin
 293     FEvent := etConnectOk;
 294   end else if command = 'forceBroadcastMessage' then begin
 295     FEvent := etForceBroadcast;
 296   end else if command = 'forceBroadcastInformation' then begin
 297     FEvent := etForceBroadcastInformation;
 298   end else if command = 'BroadcastInformation' then begin
 299     FEvent := etBroadcastInformation;
 300   end else if command = 'closeChannel' then begin
 301     FEvent := etCloseChannel;
 302   end else if command = 'unicastMessage' then begin
 303     FEvent := etUnicast;
 304   end else Result := false;
 305 end;
 306
 307 end.