-{********************************************************}
-{ DirectSstp - SSTP Client using DirectSSTP method }
-{ }
-{ Copyright (c) 2001-2003 naruto/CANO-Lab }
-{********************************************************}
-
-
-unit DirectSstp;
-
-interface
-
-uses
- Windows, Messages, SysUtils, Classes, Dialogs, ExtCtrls, Forms;
-
-type
- //\83G\83\89\81[\83R\81[\83h
- TSstpResult = (
- srOk,
- srNoContent,
- srBreak,
- srBadRequest,
- srRequestTimeout,
- srConflict,
- srRefuse,
- srNotImplemented,
- srServiceUnavailable,
- srNotLocalIP,
- srInBlackList,
- srUnknownError
- );
-
- TGiveType = (gtDocument, gtSongname);
-
- TSstpSendOption = (soNoTranslate, soNoDescript);
- TSstpSendOptions = set of TSstpSendOption;
-
- //\8dÄ\91\97\83L\83\85\81[\97p
- TSendScript = class(TObject)
- private
- FScript: String;
- FOption: TSstpSendOptions;
- FID: integer;
- FGhost: String;
- procedure SetOption(const Value: TSstpSendOptions);
- procedure SetScript(const Value: String);
- procedure SetGhost(const Value: String);
- public
- constructor Create(const AScript: String; const AOption: TSstpSendOptions;
- const AGhost: String; const ID: integer);
- property Script: String read FScript write SetScript;
- property Option: TSstpSendOptions read FOption write SetOption;
- property Ghost: String read FGhost write SetGhost;
- property ID: integer read FID;
- end;
-
- TSstpResendEvent = procedure (Sender: TObject; ID: integer;
- const Script: String) of Object;
-
- TDirectSstp = class(TComponent)
- private
- FStatusCode: Integer;
- FSstpSender: String;
- FSentLog: TStringList;
- FRecvLog: TStringList;
- FRecvLogString: String;
- FNextCueID: integer;
- FSendCue: TList;
- FTimer: TTimer;
- FInterval: integer;
- FOnResendResend: TSstpResendEvent;
- FOnResendTrying: TSstpResendEvent;
- FOnResendEnd: TSstpResendEvent;
- FOnResendCountChange: TNotifyEvent;
- FSleep: boolean;
- FOnAfterConnection: TNotifyEvent;
- FWindowHandle: THandle;
- FDirectSstpResult: String;
- FTargetHWnd: THandle;//DirectSSTP
- FBusy: boolean;
- FTimeOut: integer; //\90Ú\91±\92\86\82Í\95Ê\82Ì\90Ú\91±\97v\8b\81\82ð\8eó\82¯\95t\82¯\82È\82¢
- procedure SetSStpSender(const Value: String);
- function GetRecvLog: String;
- function GetSentLog: String;
- procedure SetInterval(const Value: integer);
- procedure SetOnResendResend(const Value: TSstpResendEvent);
- procedure SetOnResendEnd(const Value: TSstpResendEvent);
- procedure SetOnResendTrying(const Value: TSstpResendEvent);
- function GetCueCount: integer;
- procedure SetOnResendCountChange(const Value: TNotifyEvent);
- procedure SetSleep(const Value: boolean);
- procedure SetOnAfterConnection(const Value: TNotifyEvent);
- procedure WndProc(var Msg: TMessage);
- procedure SetTargetHWnd(const Value: THandle);
- procedure SetTimeOut(const Value: integer); //DirectSSTP\97p
- protected
- function ExtractCode(const CodeStr: String): integer;
- function CodeToStatus(const Code: integer): TSstpResult;
- function GetLastStatus: TSstpResult;
- procedure FlushLog;
- procedure ResendTimerEvent(Sender: TObject);
- procedure Loaded; override;
- public
- function ConnectSstp(Source: TStrings): TSstpResult;
- property StatusCode: Integer read FStatusCode;
- property LastStatus: TSstpResult read GetLastStatus;
- property SentLog: String read GetSentLog;
- property RecvLog: String read GetRecvLog;
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- function SstpGIVE(const Document: String): TSstpResult;
- function SstpGIVE1_1(const Data: String;
- const DataType: TGiveType = gtDocument): TSstpResult;
- function SstpCOMMUNICATE(const Sentence: String;
- const Port: integer = 0): TSstpResult;
- function SstpSEND(const Script: String;
- const Option: TSstpSendOptions = [];
- const Ghost: String = ''): TSstpResult; overload;
- function SstpSEND(const Script: TStrings;
- const Option: TSstpSendOptions = [];
- const Handle: HWND = 0;
- const Ghost: String = ''): TSstpResult; overload;
- function SstpEXECUTE(const Command: String): String;
- function SstpExGetName: String;
- function SstpExSetCookie(const Key, Value: String): TSstpResult;
- function SstpExGetCookie(const Key: String): String;
- function SstpExGetVersion: String;
- function SstpExQuiet(const Quiet: boolean): TSstpResult;
- function SstpSENDCue(const Script: String;
- const HighPriority: boolean = false;
- const Option: TSstpSendOptions = [];
- const Ghost: String = ''): integer;
- property CueCount: integer read GetCueCount;
- property Handle: THandle read FWindowHandle;
- procedure ClearCue;
- published
- property TimeOut: integer read FTimeOut write SetTimeOut default 2000;
- property SstpSender: String read FSStpSender write SetSStpSender;
- property Interval: integer read FInterval write SetInterval default 5000;
- property Sleep: boolean read FSleep write SetSleep;
- property TargetHWnd: THandle read FTargetHWnd write SetTargetHWnd;
- property OnResendTrying: TSstpResendEvent read FOnResendTrying write SetOnResendTrying;
- property OnResendEnd: TSstpResendEvent read FOnResendEnd write SetOnResendEnd;
- property OnResendResend: TSstpResendEvent read FOnResendResend write SetOnResendResend;
- property OnResendCountChange: TNotifyEvent read FOnResendCountChange write SetOnResendCountChange;
- property OnAfterConnection: TNotifyEvent read FOnAfterConnection write SetOnAfterConnection;
- end;
-
-const
- //\82±\82Ì\83G\83\89\81[\82Í\81ASSTP\83T\81[\83o\82ª\83X\83e\81[\83^\83X\82ð\95Ô\82³\82¸\82É\90Ø\92f\82µ\82½\82Æ\82«\82È\82Ç\82É\95Ô\82é
- UnknownError = -1000;
-
- //\83\8a\83g\83\89\83C\82ð\8ds\82í\82È\82¢\83X\83e\81[\83^\83X\83R\81[\83h
- NotResendList: set of TSstpResult = [
- srOk,
- srNoContent,
- srBreak,
- srBadRequest,
- srRequestTimeout,
- srRefuse,
- srNotImplemented,
- srServiceUnavailable,
- srNotLocalIP,
- srInBlackList
- ];
-
-procedure Register;
-
-implementation
-
-{ TDirectSstp }
-
-function TDirectSstp.CodeToStatus(const Code: integer): TSstpResult;
-begin
- case Code of
- 200: Result := srOk;
- 204: Result := srNoContent;
- 210: Result := srBreak;
- 400: Result := srBadRequest;
- 408: Result := srRequestTimeout;
- 409: Result := srConflict;
- 420: Result := srRefuse;
- 501: Result := srNotImplemented;
- 503: Result := srServiceUnavailable;
- 504: Result := srNotLocalIP;
- 541: Result := srInBlackList;
- else
- Result := srUnknownError;
- end;
-end;
-
-function TDirectSstp.ConnectSstp(Source: TStrings): TSstpResult;
-var Mes: TCopyDataStruct;
- MesStr: String;
- Dummy: DWORD; //SendMessageTimeout\97p
-begin
- FlushLog;
- Result := srUnknownError;
- if FBusy then Exit;
- FBusy := true;
- FTimer.Enabled := false;
-
- if TargetHWnd <> 0 then begin
- MesStr := Source.Text;
- Mes.dwData := 9801;
- Mes.cbData := Length(MesStr);
- Mes.lpData := PChar(MesStr);
- FDirectSstpResult := '';
- FSentLog.Text := MesStr;
- //SendMessage(TargetHWnd, WM_COPYDATA, FWindowHandle, LPARAM(@Mes));
- SendMessageTimeout(TargetHWnd, WM_COPYDATA, FWindowHandle, LPARAM(@Mes),
- SMTO_ABORTIFHUNG or SMTO_NORMAL, TimeOut, Dummy);
- FRecvLog.Text := FDirectSstpResult;
- if FRecvLog.Count > 0 then
- FStatusCode := ExtractCode(FRecvLog[0])
- else
- FStatusCode := UnknownError;
- Result := CodeToStatus(FStatusCode);
- end;
-
- FTimer.Enabled := not FSleep;
- if Assigned(FOnAfterConnection) then FOnAfterConnection(Self);
- FBusy := false;
-end;
-
-constructor TDirectSstp.Create;
-begin
- inherited;
- TimeOut := 2000;
- FInterval := 5000;
- SstpSender := 'My Program';
- FSentLog := TStringList.Create;
- FRecvLog := TStringList.Create;
- FSendCue := TList.Create;
- FTimer := TTimer.Create(Self);
- FTimer.OnTimer := ResendTimerEvent;
- FWindowHandle := AllocateHWnd(WndProc);
-end;
-
-destructor TDirectSstp.Destroy;
-var i: integer;
-begin
- inherited;
- FSentLog.Free;
- FRecvLog.Free;
- for i := FSendCue.Count-1 downto 0 do
- TSendScript(FSendCue[i]).Free;
- FSendCue.Free;
- DeallocateHWnd(FWindowHandle);
-end;
-
-function TDirectSstp.ExtractCode(const CodeStr: String): integer;
-var i, l: integer;
- s, p: String;
-begin
- if CodeStr = '' then begin
- Result := UnknownError;
- Exit;
- end;
- i := 1;
- l := length(CodeStr);
- while (CodeStr[i] <> ' ') and (i<=l) do begin
- p := p + CodeStr[i];
- Inc(i);
- end;
- Inc(i);
- while (CodeStr[i] in ['0'..'9']) and (i<=l) do begin
- s := s + CodeStr[i];
- Inc(i);
- end;
- try
- Result := StrToInt(s);
- except
- on EConvertError do Result := UnknownError;
- end;
-end;
-
-procedure TDirectSstp.FlushLog;
-begin
- if FSentLog <> nil then FSentLog.Clear;
- if FRecvLog <> nil then FRecvLog.Clear;
- FRecvLogString := '';
-end;
-
-function TDirectSstp.GetLastStatus: TSstpResult;
-begin
- Result := CodeToStatus(FStatusCode);
-end;
-
-
-function TDirectSstp.GetRecvLog: String;
-begin
- Result := FRecvLog.Text;
-end;
-
-function TDirectSstp.GetSentLog: String;
-begin
- Result := FSentLog.Text;
-end;
-
-procedure TDirectSstp.Loaded;
-begin
- inherited;
- FTimer.Interval := FInterval;
- FTimer.Enabled := not FSleep;
- if Assigned(FOnResendCountChange) then FOnResendCountChange(Self);
-end;
-
-procedure TDirectSstp.ResendTimerEvent(Sender: TObject);
-var Scr: TSendScript;
- Res: TSstpResult;
-begin
- if FSendCue.Count = 0 then Exit;
- Scr := TSendScript(FSendCue[0]);
- if Assigned(FOnResendTrying) then FOnResendTrying(Self, Scr.ID, Scr.Script);
- Res := SstpSEND(Scr.Script, Scr.Option, Scr.Ghost);
- if Res in NotResendList then begin
- if Assigned(FOnResendEnd) then FOnResendEnd(Self, Scr.ID, Scr.Script);
- FSendCue.Delete(0);
- if Assigned(FOnResendCountChange) then FOnResendCountChange(Self);
- Scr.Free;
- end else begin
- if Assigned(FOnResendResend) then FOnResendResend(Self, Scr.ID, Scr.Script);
- end;
-end;
-
-procedure TDirectSstp.SetInterval(const Value: integer);
-begin
- FInterval := Value;
- FTimer.Interval := Value;
-end;
-
-procedure TDirectSstp.SetOnResendResend(const Value: TSstpResendEvent);
-begin
- FOnResendResend := Value;
-end;
-
-procedure TDirectSstp.SetOnResendEnd(const Value: TSstpResendEvent);
-begin
- FOnResendEnd := Value;
-end;
-
-procedure TDirectSstp.SetOnResendTrying(const Value: TSstpResendEvent);
-begin
- FOnResendTrying := Value;
-end;
-
-procedure TDirectSstp.SetSstpSender(const Value: String);
-begin
- FSStpSender := Value;
-end;
-
-function TDirectSstp.SstpCOMMUNICATE(const Sentence: String;
- const Port: integer): TSstpResult;
-var Source: TStringList;
-begin
- Source := nil;
- try
- Source := TStringList.Create;
- Source.Add('COMMUNICATE SSTP/1.2');
- Source.Add('Sender: ' + FSstpSender);
- if Port <> 0 then Source.Add('Port: ' + IntToStr(Port));
- Source.Add('Sentence: ' + Sentence);
- Source.Add('CharSet: Shift_JIS');
- Source.Add('HWnd: ' + IntToStr(FWindowHandle));
- ConnectSstp(Source);
- finally
- Source.Free;
- end;
- Result := LastStatus;
-end;
-
-function TDirectSstp.SstpEXECUTE(const Command: String): String;
-var S: String;
- Source: TStringList;
-begin
- Source := nil;
- try
- Source := TStringList.Create;
- Source.Add('EXECUTE SSTP/1.1');
- Source.Add('Sender: ' + FSstpSender);
- Source.Add('Command: ' + Command);
- Source.Add('CharSet: Shift_JIS');
- Source.Add('HWnd: ' + IntToStr(FWindowHandle));
- ConnectSstp(Source);
- finally
- Source.Free;
- end;
- if FRecvLog.Count > 1 then begin
- s := FRecvLog[0];
- FRecvLog.Delete(0);
- Result := FRecvLog.Text;
- FRecvLog.Insert(0, s);
- end else Result := '';
-end;
-
-function TDirectSstp.SstpExGetName: String;
-begin
- Result := SstpEXECUTE('getname');
- Result := StringReplace(Result, #13#10, '', [rfReplaceAll]);
-end;
-
-function TDirectSstp.SstpGIVE(const Document: String): TSstpResult;
-begin
- Result := SstpGIVE1_1(Document, gtDocument);
-end;
-
-function TDirectSstp.SstpGIVE1_1(const Data: String;
- const DataType: TGiveType): TSstpResult;
-var Source: TStringList;
-begin
- Source := nil;
- try
- Source := TStringList.Create;
- Source.Add('GIVE SSTP/1.1');
- Source.Add('Sender: ' + FSstpSender);
- Source.Add('CharSet: Shift_JIS');
- case DataType of
- gtSongname:
- Source.Add('Songname: ' + Data);
- else
- Source.Add('Document: ' + Data);
- end;
- Source.Add('HWnd: ' + IntToStr(FWindowHandle));
- ConnectSstp(Source);
- finally
- Source.Free;
- end;
- Result := LastStatus;
-end;
-
-function TDirectSstp.SstpSEND(const Script: String;
- const Option: TSstpSendOptions = [];
- const Ghost: String = ''): TSstpResult;
-var Source: TStringList;
-begin
- Source := nil;
- try
- Source := TStringList.Create;
- Source.Text := Script;
- Result := SstpSEND(Source, Option, 0, Ghost);
- finally
- Source.Free;
- end;
-end;
-
-function TDirectSstp.SstpSEND(const Script: TStrings;
- const Option: TSstpSendOptions;
- const Handle: HWND;
- const Ghost: String): TSstpResult;
-var Opt: String;
- i: integer;
- Source: TStringList;
-begin
- if soNoTranslate in Option then begin
- Opt := 'notranslate';
- end;
- if soNoDescript in Option then begin
- if Opt <> '' then Opt := Opt + ',';
- Opt := Opt + 'nodescript';
- end;
- Source := nil;
- try
- Source := TStringList.Create;
- Source.Add('SEND SSTP/1.4');
- Source.Add('Sender: ' + FSstpSender);
- Source.Add('Charset: Shift_JIS');
- if Ghost <> '' then Source.Add('IfGhost: '+Ghost);
- for i := 0 to Script.Count -1 do begin
- if i = 0 then begin
- Source.Add('Script: ' + Script[i]);
- end else begin
- Source.Add('Entry: ' + Script[i]);
- end;
- end;
- Source.Add('Option: ' + Opt);
- if Handle <> 0 then
- Source.Add('HWnd: ' + IntToStr(Handle))
- else
- Source.Add('HWnd: ' + IntToStr(FWindowHandle));
- Source.Add(''); //\8bó\8ds\82ª\8fI\97¹\82ð\8e¦\82·
- ConnectSstp(Source);
- finally
- Source.Free;
- end;
- Result := LastStatus;
-end;
-
-function TDirectSstp.SstpSENDCue(const Script: String;
- const HighPriority: boolean; const Option: TSstpSendOptions;
- const Ghost: String): integer;
-var NewScript: TSendScript;
-begin
- Inc(FNextCueID);
- NewScript := TSendScript.Create(Script, Option, Ghost, FNextCueID);
- if HighPriority then begin
- FSendCue.Insert(0, NewScript);
- ResendTimerEvent(Self);
- end else FSendCue.Add(NewScript);
- if Assigned(FOnResendCountChange) then FOnResendCountChange(Self);
- Result := FNextCueID;
-end;
-
-function TDirectSstp.GetCueCount: integer;
-begin
- Result := FSendCue.Count;
-end;
-
-procedure TDirectSstp.SetOnResendCountChange(const Value: TNotifyEvent);
-begin
- FOnResendCountChange := Value;
-end;
-
-procedure TDirectSstp.SetSleep(const Value: boolean);
-begin
- FSleep := Value;
- FTimer.Enabled := false; //\82¢\82Á\82½\82ñ\83^\83C\83}\81[\82ð\94j\8aü\82·\82é
- FTimer.Enabled := not Value;
-end;
-
-procedure TDirectSstp.SetOnAfterConnection(const Value: TNotifyEvent);
-begin
- FOnAfterConnection := Value;
-end;
-
-procedure TDirectSstp.ClearCue;
-var i: integer;
-begin
- for i := FSendCue.Count-1 downto 0 do
- TSendScript(FSendCue[i]).Free;
- FSendCue.Clear;
- if Assigned(FOnResendCountChange) then FOnResendCountChange(Self);
-end;
-
-function TDirectSstp.SstpExGetCookie(const Key: String): String;
-begin
- Result := SstpEXECUTE('GetCookie[' + Key + ']');
- Result := StringReplace(Result, #13#10, '', [rfReplaceAll]);
-end;
-
-function TDirectSstp.SstpExSetCookie(const Key, Value: String): TSstpResult;
-begin
- SstpEXECUTE('SetCookie[' +
- StringReplace(Key, #13#10, '', [rfReplaceAll]) +
- ',' +
- StringReplace(Value, #13#10, '', [rfReplaceAll])
- + ']');
- Result := GetLastStatus;
-end;
-
-function TDirectSstp.SstpExGetVersion: String;
-begin
- Result := SstpEXECUTE('getversion');
- Result := StringReplace(Result, #13#10, '', [rfReplaceAll]);
-end;
-
-function TDirectSstp.SstpExQuiet(const Quiet: boolean): TSstpResult;
-begin
- if Quiet then
- SstpEXECUTE('Quiet')
- else
- SstpEXECUTE('Restore');
- Result := GetLastStatus;
-end;
-
-procedure TDirectSstp.WndProc(var Msg: TMessage);
-var Dat: TWMCopyData;
-begin
- if Msg.Msg = WM_COPYDATA then begin
- Dat := TWMCopyData(Msg);
- FDirectSstpResult := PChar(Dat.CopyDataStruct^.lpData);
- end else begin
- Msg.Result := DefWindowProc(FWindowHandle, Msg.Msg, Msg.wParam, Msg.lParam);
- end;
-end;
-
-procedure TDirectSstp.SetTargetHWnd(const Value: THandle);
-begin
- FTargetHWnd := Value;
-end;
-
-procedure TDirectSstp.SetTimeOut(const Value: integer);
-begin
- FTimeOut := Value;
-end;
-
-{ TSendScript }
-
-constructor TSendScript.Create(const AScript: String;
- const AOption: TSstpSendOptions; const AGhost: String; const ID: integer);
-begin
- FScript := AScript;
- FOption := AOption;
- FGhost := AGhost;
- FID := ID;
-end;
-
-procedure TSendScript.SetGhost(const Value: String);
-begin
- FGhost := Value;
-end;
-
-procedure TSendScript.SetOption(const Value: TSstpSendOptions);
-begin
- FOption := Value;
-end;
-
-procedure TSendScript.SetScript(const Value: String);
-begin
- FScript := Value;
-end;
-
-//-------------------------------------
-
-procedure Register;
-begin
- RegisterComponents('Miscellaneous', [TDirectSstp]);
-end;
-
-end.
-
-
-
-
-
-
-