diff options
| author | michael <michael@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2010-05-30 14:14:18 +0000 |
|---|---|---|
| committer | michael <michael@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2010-05-30 14:14:18 +0000 |
| commit | c7ee013c37a34146d51cefd47c8262ecc25603ef (patch) | |
| tree | c6d19f971ee0a7c2043785bfbad656643c077e07 | |
| parent | f1db4ecbec0a3f5f075c6aaea4f85ab5e943fd0f (diff) | |
| download | fpc-c7ee013c37a34146d51cefd47c8262ecc25603ef.tar.gz | |
* Deprecated in favour of fcl-web and WST
git-svn-id: http://svn.freepascal.org/svn/fpc/trunk@15346 3ad0048d-3df7-0310-abae-a5850022a9f2
| -rw-r--r-- | packages/fcl-net/src/httpbase.pp | 488 | ||||
| -rw-r--r-- | packages/fcl-net/src/httpclient.pp | 307 | ||||
| -rw-r--r-- | packages/fcl-net/src/mkxmlrpc.pp | 871 | ||||
| -rw-r--r-- | packages/fcl-net/src/servlets.pp | 114 | ||||
| -rw-r--r-- | packages/fcl-net/src/xmlrpc.pp | 941 |
5 files changed, 0 insertions, 2721 deletions
diff --git a/packages/fcl-net/src/httpbase.pp b/packages/fcl-net/src/httpbase.pp deleted file mode 100644 index 72699a4a7d..0000000000 --- a/packages/fcl-net/src/httpbase.pp +++ /dev/null @@ -1,488 +0,0 @@ -{ - - HTTPBase: Common HTTP utility declarations and classes - Copyright (C) 2000-2003 by Sebastian Guenther (sg@freepascal.org) - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -} - -{$mode objfpc} -{$H+} - -unit HTTPBase; - -interface - - -uses Classes, fpAsync; - -const - - fieldAccept = 'Accept'; - fieldAcceptCharset = 'Accept-Charset'; - fieldAcceptEncoding = 'Accept-Encoding'; - fieldAcceptLanguage = 'Accept-Language'; - fieldAuthorization = 'Authorization'; - fieldConnection = 'Connection'; - fieldContentEncoding = 'Content-Encoding'; - fieldContentLanguage = 'Content-Language'; - fieldContentLength = 'Content-Length'; - fieldContentType = 'Content-Type'; - fieldCookie = 'Cookie'; - fieldDate = 'Date'; - fieldExpires = 'Expires'; - fieldFrom = 'From'; - fieldIfModifiedSince = 'If-Modified-Since'; - fieldLastModified = 'Last-Modified'; - fieldLocation = 'Location'; - fieldPragma = 'Pragma'; - fieldReferer = 'Referer'; - fieldRetryAfter = 'Retry-After'; - fieldServer = 'Server'; - fieldSetCookie = 'Set-Cookie'; - fieldUserAgent = 'User-Agent'; - fieldWWWAuthenticate = 'WWW-Authenticate'; - -type - - PHttpField = ^THttpField; - THttpField = record - Name, Value: String; - end; - - - THttpHeader = class - protected - FReader: TAsyncStreamLineReader; - FWriter: TAsyncWriteStream; - FOnCompleted: TNotifyEvent; - FOnEOF: TNotifyEvent; - FFields: TList; - - procedure ParseFirstHeaderLine(const line: String); virtual; abstract; - procedure LineReceived(const ALine: String); - procedure ReaderEOF(Sender: TObject); - function GetFirstHeaderLine: String; virtual; abstract; - procedure WriterCompleted(ASender: TObject); - - function GetFieldCount: Integer; - function GetFields(AIndex: Integer): String; - function GetFieldNames(AIndex: Integer): String; - procedure SetFieldNames(AIndex: Integer; const AName: String); - function GetFieldValues(AIndex: Integer): String; - procedure SetFieldValues(AIndex: Integer; const AValue: String); - - - function GetAccept: String; - procedure SetAccept(const AValue: String); - function GetAcceptCharset: String; - procedure SetAcceptCharset(const AValue: String); - function GetAcceptEncoding: String; - procedure SetAcceptEncoding(const AValue: String); - function GetAcceptLanguage: String; - procedure SetAcceptLanguage(const AValue: String); - function GetAuthorization: String; - procedure SetAuthorization(const AValue: String); - function GetConnection: String; - procedure SetConnection(const AValue: String); - function GetContentEncoding: String; - procedure SetContentEncoding(const AValue: String); - function GetContentLanguage: String; - procedure SetContentLanguage(const AValue: String); - function GetContentLength: Integer; - procedure SetContentLength(AValue: Integer); - function GetContentType: String; - procedure SetContentType(const AValue: String); - function Get_Cookie: String; - procedure Set_Cookie(const AValue: String); - function GetDate: String; - procedure SetDate(const AValue: String); - function GetExpires: String; - procedure SetExpires(const AValue: String); - function GetFrom: String; - procedure SetFrom(const AValue: String); - function GetIfModifiedSince: String; - procedure SetIfModifiedSince(const AValue: String); - function GetLastModified: String; - procedure SetLastModified(const AValue: String); - function GetLocation: String; - procedure SetLocation(const AValue: String); - function GetPragma: String; - procedure SetPragma(const AValue: String); - function GetReferer: String; - procedure SetReferer(const AValue: String); - function GetRetryAfter: String; - procedure SetRetryAfter(const AValue: String); - function GetServer: String; - procedure SetServer(const AValue: String); - function Get_SetCookie: String; - procedure Set_SetCookie(const AValue: String); - function GetUserAgent: String; - procedure SetUserAgent(const AValue: String); - function GetWWWAuthenticate: String; - procedure SetWWWAuthenticate(const AValue: String); - - public - DataReceived, CmdReceived: Boolean; // !!!: Only temporarily here - - HttpVersion: String; - - constructor Create; - destructor Destroy; override; - procedure SetFieldByName(const AName, AValue: String); - function GetFieldByName(const AName: String): String; - - procedure AsyncSend(AManager: TEventLoop; AStream: THandleStream); - procedure AsyncReceive(AManager: TEventLoop; AStream: THandleStream); - - property Reader: TAsyncStreamLineReader read FReader; - property Writer: TAsyncWriteStream read FWriter; - property FieldCount: Integer read GetFieldCount; - property Fields[AIndex: Integer]: String read GetFields; - property FieldNames[AIndex: Integer]: String read GetFieldNames write SetFieldNames; - property FieldValues[AIndex: Integer]: String read GetFieldValues write SetFieldValues; - - property OnCompleted: TNotifyEvent read FOnCompleted write FOnCompleted; - property OnEOF: TNotifyEvent read FOnEOF write FOnEOF; - - property Accept: String read GetAccept write SetAccept; - property AcceptCharset: String read GetAcceptCharset write SetAcceptCharset; - property AcceptEncoding: String read GetAcceptEncoding write SetAcceptEncoding; - property AcceptLanguage: String read GetAcceptLanguage write SetAcceptLanguage; - property Authorization: String read GetAuthorization write SetAuthorization; - property Connection: String read GetConnection write SetConnection; - property ContentEncoding: String read GetContentEncoding write SetContentEncoding; - property ContentLanguage: String read GetContentLanguage write SetContentLanguage; - property ContentLength: Integer read GetContentLength write SetContentLength; - property ContentType: String read GetContentType write SetContentType; - property Cookie: String read Get_Cookie write Set_Cookie; - property Date: String read GetDate write SetDate; - property Expires: String read GetExpires write SetExpires; - property From: String read GetFrom write SetFrom; - property IfModifiedSince: String read GetIfModifiedSince write SetIfModifiedSince; - property LastModified: String read GetLastModified write SetLastModified; - property Location: String read GetLocation write SetLocation; - property Pragma: String read GetPragma write SetPragma; - property Referer: String read GetReferer write SetReferer; - property RetryAfter: String read GetRetryAfter write SetRetryAfter; - property Server: String read GetServer write SetServer; - property SetCookie: String read Get_SetCookie write Set_SetCookie; - property UserAgent: String read GetUserAgent write SetUserAgent; - property WWWAuthenticate: String read GetWWWAuthenticate write SetWWWAuthenticate; - end; - - - THttpRequestHeader = class(THttpHeader) - protected - procedure ParseFirstHeaderLine(const line: String); override; - function GetFirstHeaderLine: String; override; - public - CommandLine: String; - Command: String; - URI: String; // Uniform Resource Identifier - QueryString: String; - end; - - - THttpResponseHeader = class(THttpHeader) - protected - procedure ParseFirstHeaderLine(const line: String); override; - function GetFirstHeaderLine: String; override; - public - Code: Integer; - CodeText: String; - constructor Create; - end; - - -implementation - -uses SysUtils; - - -// THttpHeader - -procedure THttpHeader.LineReceived(const ALine: String); -var - i: Integer; -begin - if Length(ALine) = 0 then - begin - FReader.OnLine := nil; // Stop receiving - FReader.StopAndFree; - if Assigned(FOnCompleted) then - FOnCompleted(Self); - FReader := nil; - end else - DataReceived := True; - if not CmdReceived then - begin - CmdReceived := True; - ParseFirstHeaderLine(ALine); - end else - begin - i := Pos(':', ALine); - SetFieldByName(Trim(Copy(ALine, 1, i - 1)), - Trim(Copy(ALine, i + 1, Length(ALine)))); - end; -end; - -procedure THttpHeader.ReaderEOF(Sender: TObject); -begin - if Assigned(OnEOF) then - OnEOF(Self); -end; - -procedure THttpHeader.WriterCompleted(ASender: TObject); -begin - if Assigned(FOnCompleted) then - FOnCompleted(Self); - FreeAndNil(FWriter); -end; - -function THttpHeader.GetFieldCount: Integer; -begin - Result := FFields.Count; -end; - -function THttpHeader.GetFields(AIndex: Integer): String; -begin - Result := FieldNames[AIndex] + ': ' + FieldValues[AIndex]; -end; - -function THttpHeader.GetFieldNames(AIndex: Integer): String; -begin - Result := PHttpField(FFields.Items[AIndex])^.Name; -end; - -procedure THttpHeader.SetFieldNames(AIndex: Integer; const AName: String); -begin - PHttpField(FFields.Items[AIndex])^.Name := AName; -end; - -function THttpHeader.GetFieldValues(AIndex: Integer): String; -begin - Result := PHttpField(FFields.Items[AIndex])^.Value; -end; - -procedure THttpHeader.SetFieldValues(AIndex: Integer; const AValue: String); -begin - PHttpField(FFields.Items[AIndex])^.Value := AValue; -end; - -function THttpHeader.GetAccept: String; begin Result := GetFieldByName(fieldAccept) end; -procedure THttpHeader.SetAccept(const AValue: String); begin SetFieldByName(fieldAccept, AValue) end; -function THttpHeader.GetAcceptCharset: String; begin Result := GetFieldByName(fieldAcceptCharset) end; -procedure THttpHeader.SetAcceptCharset(const AValue: String); begin SetFieldByName(fieldAcceptCharset, AValue) end; -function THttpHeader.GetAcceptEncoding: String; begin Result := GetFieldByName(fieldAcceptEncoding) end; -procedure THttpHeader.SetAcceptEncoding(const AValue: String); begin SetFieldByName(fieldAcceptEncoding, AValue) end; -function THttpHeader.GetAcceptLanguage: String; begin Result := GetFieldByName(fieldAcceptLanguage) end; -procedure THttpHeader.SetAcceptLanguage(const AValue: String); begin SetFieldByName(fieldAcceptLanguage, AValue) end; -function THttpHeader.GetAuthorization: String; begin Result := GetFieldByName(fieldAuthorization) end; -procedure THttpHeader.SetAuthorization(const AValue: String); begin SetFieldByName(fieldAuthorization, AValue) end; -function THttpHeader.GetConnection: String; begin Result := GetFieldByName(fieldConnection) end; -procedure THttpHeader.SetConnection(const AValue: String); begin SetFieldByName(fieldConnection, AValue) end; -function THttpHeader.GetContentEncoding: String; begin Result := GetFieldByName(fieldContentEncoding) end; -procedure THttpHeader.SetContentEncoding(const AValue: String); begin SetFieldByName(fieldContentEncoding, AValue) end; -function THttpHeader.GetContentLanguage: String; begin Result := GetFieldByName(fieldContentLanguage) end; -procedure THttpHeader.SetContentLanguage(const AValue: String); begin SetFieldByName(fieldContentLanguage, AValue) end; -function THttpHeader.GetContentLength: Integer; var s: String; begin s := GetFieldByName(fieldContentLength); if Length(s) = 0 then Result := -1 else Result := StrToInt(s) end; -procedure THttpHeader.SetContentLength(AValue: Integer); begin SetFieldByName(fieldContentLength, IntToStr(AValue)) end; -function THttpHeader.GetContentType: String; begin Result := GetFieldByName(fieldContentType) end; -procedure THttpHeader.SetContentType(const AValue: String); begin SetFieldByName(fieldContentType, AValue) end; -function THttpHeader.Get_Cookie: String; begin Result := GetFieldByName(fieldCookie) end; -procedure THttpHeader.Set_Cookie(const AValue: String); begin SetFieldByName(fieldCookie, AValue) end; -function THttpHeader.GetDate: String; begin Result := GetFieldByName(fieldDate) end; -procedure THttpHeader.SetDate(const AValue: String); begin SetFieldByName(fieldDate, AValue) end; -function THttpHeader.GetExpires: String; begin Result := GetFieldByName(fieldExpires) end; -procedure THttpHeader.SetExpires(const AValue: String); begin SetFieldByName(fieldExpires, AValue) end; -function THttpHeader.GetFrom: String; begin Result := GetFieldByName(fieldFrom) end; -procedure THttpHeader.SetFrom(const AValue: String); begin SetFieldByName(fieldFrom, AValue) end; -function THttpHeader.GetIfModifiedSince: String; begin Result := GetFieldByName(fieldIfModifiedSince) end; -procedure THttpHeader.SetIfModifiedSince(const AValue: String); begin SetFieldByName(fieldIfModifiedSince, AValue) end; -function THttpHeader.GetLastModified: String; begin Result := GetFieldByName(fieldLastModified) end; -procedure THttpHeader.SetLastModified(const AValue: String); begin SetFieldByName(fieldLastModified, AValue) end; -function THttpHeader.GetLocation: String; begin Result := GetFieldByName(fieldLocation) end; -procedure THttpHeader.SetLocation(const AValue: String); begin SetFieldByName(fieldLocation, AValue) end; -function THttpHeader.GetPragma: String; begin Result := GetFieldByName(fieldPragma) end; -procedure THttpHeader.SetPragma(const AValue: String); begin SetFieldByName(fieldPragma, AValue) end; -function THttpHeader.GetReferer: String; begin Result := GetFieldByName(fieldReferer) end; -procedure THttpHeader.SetReferer(const AValue: String); begin SetFieldByName(fieldReferer, AValue) end; -function THttpHeader.GetRetryAfter: String; begin Result := GetFieldByName(fieldRetryAfter) end; -procedure THttpHeader.SetRetryAfter(const AValue: String); begin SetFieldByName(fieldRetryAfter, AValue) end; -function THttpHeader.GetServer: String; begin Result := GetFieldByName(fieldServer) end; -procedure THttpHeader.SetServer(const AValue: String); begin SetFieldByName(fieldServer, AValue) end; -function THttpHeader.Get_SetCookie: String; begin Result := GetFieldByName(fieldSetCookie) end; -procedure THttpHeader.Set_SetCookie(const AValue: String); begin SetFieldByName(fieldSetCookie, AValue) end; -function THttpHeader.GetUserAgent: String; begin Result := GetFieldByName(fieldUserAgent) end; -procedure THttpHeader.SetUserAgent(const AValue: String); begin SetFieldByName(fieldUserAgent, AValue) end; -function THttpHeader.GetWWWAuthenticate: String; begin Result := GetFieldByName(fieldWWWAuthenticate) end; -procedure THttpHeader.SetWWWAuthenticate(const AValue: String); begin SetFieldByName(fieldWWWAuthenticate, AValue) end; - -constructor THttpHeader.Create; -begin - inherited Create; - FFields := TList.Create; - HttpVersion := '1.1'; -end; - -destructor THttpHeader.Destroy; -var - i: Integer; - Field: PHttpField; -begin - if Assigned(FReader) then - FReader.StopAndFree; - if Assigned(FWriter) then - FWriter.StopAndFree; - for i := 0 to FFields.Count - 1 do - begin - Field := PHttpField(FFields.Items[i]); -{ SetLength(Field^.Name, 0); - SetLength(Field^.Value, 0);} - Dispose(Field); - end; - FFields.Free; - inherited Destroy; -end; - -function THttpHeader.GetFieldByName(const AName: String): String; -var - i: Integer; - Name: String; -begin - Name := UpperCase(AName); - for i := 0 to FFields.Count - 1 do - if UpperCase(FieldNames[i]) = Name then - begin - Result := FieldValues[i]; - exit; - end; - SetLength(Result, 0); -end; - -procedure THttpHeader.SetFieldByName(const AName, AValue: String); -var - i: Integer; - Name: String; - Field: PHttpField; -begin - Name := UpperCase(AName); - for i := 0 to FFields.Count - 1 do - if UpperCase(FieldNames[i]) = Name then - begin - FieldNames[i] := AName; // preserve case - FieldValues[i] := AValue; - exit; - end; - New(Field); - FillChar(Field^, SizeOf(Field^), 0); - Field^.Name := AName; - Field^.Value := AValue; - FFields.Add(field); -end; - -procedure THttpHeader.AsyncSend(AManager: TEventLoop; AStream: THandleStream); -var - i: Integer; -begin - if Assigned(FWriter) then - FWriter.StopAndFree; - FWriter := TAsyncWriteStream.Create(AManager, AStream); - FWriter.OnBufferSent := @WriterCompleted; - FWriter.EndOfLineMarker := #13#10; - FWriter.WriteLine(GetFirstHeaderLine); - for i := 0 to FFields.Count - 1 do - FWriter.WriteLine(Fields[i]); - FWriter.WriteLine(''); -end; - -procedure THttpHeader.AsyncReceive(AManager: TEventLoop; AStream: THandleStream); -begin - CmdReceived := False; - FReader.Free; - FReader := TAsyncStreamLineReader.Create(AManager, AStream); - FReader.OnLine := @LineReceived; - FReader.OnEOF := @ReaderEOF; -end; - - -// ------------------------------------------------------------------- -// THttpRequestHeader -// ------------------------------------------------------------------- - -procedure THttpRequestHeader.ParseFirstHeaderLine(const line: String); -var - i: Integer; -begin - CommandLine := line; - i := Pos(' ', line); - Command := UpperCase(Copy(line, 1, i - 1)); - URI := Copy(line, i + 1, Length(line)); - - // Extract HTTP version - i := Pos(' ', URI); - if i > 0 then - begin - HttpVersion := Copy(URI, i + 1, Length(URI)); - URI := Copy(URI, 1, i - 1); - HttpVersion := Copy(HttpVersion, Pos('/', HttpVersion) + 1, Length(HttpVersion)); - end; - - // Extract query string - i := Pos('?', URI); - if i > 0 then - begin - QueryString := Copy(URI, i + 1, Length(URI)); - URI := Copy(URI, 1, i - 1); - end; -end; - -function THttpRequestHeader.GetFirstHeaderLine: String; -begin - Result := Command + ' ' + URI; - if Length(HttpVersion) > 0 then - Result := Result + ' HTTP/' + HttpVersion; -end; - - -// ------------------------------------------------------------------- -// THttpResponseHeader -// ------------------------------------------------------------------- - -procedure THttpResponseHeader.ParseFirstHeaderLine(const line: String); -var - i: Integer; - s: String; -begin - i := Pos('/', line); - s := Copy(line, i + 1, Length(line)); - i := Pos(' ', s); - HttpVersion := Copy(s, 1, i - 1); - s := Copy(s, i + 1, Length(s)); - i := Pos(' ', s); - if i > 0 then begin - CodeText := Copy(s, i + 1, Length(s)); - s := Copy(s, 1, i - 1); - end; - Code := StrToInt(s); -end; - -function THttpResponseHeader.GetFirstHeaderLine: String; -begin - Result := Format('HTTP/%s %d %s', [HttpVersion, Code, CodeText]); -end; - -constructor THttpResponseHeader.Create; -begin - inherited Create; - Code := 200; - CodeText := 'OK'; -end; - -end. diff --git a/packages/fcl-net/src/httpclient.pp b/packages/fcl-net/src/httpclient.pp deleted file mode 100644 index b4475a0329..0000000000 --- a/packages/fcl-net/src/httpclient.pp +++ /dev/null @@ -1,307 +0,0 @@ -{ - - HTTPClient: HTTP client component - Copyright (C) 2000-2003 by Sebastian Guenther (sg@freepascal.org) - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -} - - -unit HTTPClient; - -interface - -{$mode objfpc} -{$H+} - -uses Classes, HTTPBase, fpSock, fpAsync; - -type - - TCustomHTTPClient = class(TCustomTCPClient) - protected - SendBuffer: TAsyncWriteStream; - FOnPrepareSending: TNotifyEvent; - FOnHeaderSent: TNotifyEvent; - FOnStreamSent: TNotifyEvent; - FOnPrepareReceiving: TNotifyEvent; - FOnHeaderReceived: TNotifyEvent; - FOnStreamReceived: TNotifyEvent; - FOnDestroy: TNotifyEvent; - RecvSize: Integer; // How many bytes are still to be read. -1 if unknown. - DataAvailableNotifyHandle: Pointer; - ReceivedHTTPVersion: String; - - procedure HeaderToSendCompleted(Sender: TObject); - procedure StreamToSendCompleted(Sender: TObject); - procedure ReceivedHeaderCompleted(Sender: TObject); - procedure ReceivedHeaderEOF(Sender: TObject); - procedure DataAvailable(Sender: TObject); - procedure ReceivedStreamCompleted(Sender: TObject); - - property OnPrepareSending: TNotifyEvent read FOnPrepareSending write FOnPrepareSending; - property OnHeaderSent: TNotifyEvent read FOnHeaderSent write FOnHeaderSent; - property OnStreamSent: TNotifyEvent read FOnStreamSent write FOnStreamSent; - property OnPrepareReceiving: TNotifyEvent read FOnPrepareReceiving write FOnPrepareReceiving; - property OnHeaderReceived: TNotifyEvent read FOnHeaderReceived write FOnHeaderReceived; - property OnStreamReceived: TNotifyEvent read FOnStreamReceived write FOnStreamReceived; - property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; - - public - HeaderToSend: THttpHeader; - StreamToSend: TStream; - ReceivedHeader: THttpHeader; - ReceivedStream: TStream; - DoDestroy: Boolean; - - destructor Destroy; override; - procedure Receive; - procedure Send; - end; - - THttpClient = class(TCustomHttpClient) - public - property OnPrepareSending; - property OnHeaderSent; - property OnStreamSent; - property OnPrepareReceiving; - property OnHeaderReceived; - property OnStreamReceived; - property OnDestroy; - end; - - {TCustomHTTPClient = class - protected - FEventLoop: TEventLoop; - FSocket: TInetSocket; - SendBuffer: TAsyncWriteStream; - FOnPrepareSending: TNotifyEvent; - FOnHeaderSent: TNotifyEvent; - FOnStreamSent: TNotifyEvent; - FOnPrepareReceiving: TNotifyEvent; - FOnHeaderReceived: TNotifyEvent; - FOnStreamReceived: TNotifyEvent; - FOnDestroy: TNotifyEvent; - RecvSize: Integer; // How many bytes are still to be read. -1 if unknown. - DataAvailableNotifyHandle: Pointer; - ReceivedHTTPVersion: String; - - procedure HeaderToSendCompleted(Sender: TObject); - procedure StreamToSendCompleted(Sender: TObject); - procedure ReceivedHeaderCompleted(Sender: TObject); - procedure ReceivedHeaderEOF(Sender: TObject); - procedure DataAvailable(Sender: TObject); - procedure ReceivedStreamCompleted(Sender: TObject); - - property OnPrepareSending: TNotifyEvent read FOnPrepareSending write FOnPrepareSending; - property OnHeaderSent: TNotifyEvent read FOnHeaderSent write FOnHeaderSent; - property OnStreamSent: TNotifyEvent read FOnStreamSent write FOnStreamSent; - property OnPrepareReceiving: TNotifyEvent read FOnPrepareReceiving write FOnPrepareReceiving; - property OnHeaderReceived: TNotifyEvent read FOnHeaderReceived write FOnHeaderReceived; - property OnStreamReceived: TNotifyEvent read FOnStreamReceived write FOnStreamReceived; - property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; - - public - HeaderToSend: THttpHeader; - StreamToSend: TStream; - ReceivedHeader: THttpHeader; - ReceivedStream: TStream; - DoDestroy: Boolean; - - constructor Create(AEventLoop: TEventLoop; ASocket: TInetSocket); - destructor Destroy; override; - procedure Receive; - procedure Send; - end;} - - -implementation - -uses SysUtils; - -procedure TCustomHttpClient.HeaderToSendCompleted(Sender: TObject); -begin - // WriteLn('TCustomHttpClient.HeaderToSendCompleted'); - if Assigned(FOnHeaderSent) then - FOnHeaderSent(Self); - if Assigned(StreamToSend) then - begin - SendBuffer := TAsyncWriteStream.Create(EventLoop, Stream); - SendBuffer.CopyFrom(StreamToSend, StreamToSend.Size); - SendBuffer.OnBufferSent := @StreamToSendCompleted; - end else - begin - StreamToSendCompleted(nil); - if DoDestroy then - Self.Free; - end; -end; - -procedure TCustomHttpClient.StreamToSendCompleted(Sender: TObject); -begin - // WriteLn('TCustomHttpClient.StreamToSendCompleted'); - if Assigned(FOnStreamSent) then - FOnStreamSent(Self); - FreeAndNil(SendBuffer); - if DoDestroy then - Self.Free - else - Receive; -end; - -procedure TCustomHttpClient.ReceivedHeaderCompleted(Sender: TObject); -var - BytesInBuffer: Integer; - NeedMoreData: Boolean; -begin - // WriteLn('TCustomHttpClient.ReceivedHeaderCompleted'); - ReceivedHeader.DataReceived := False; - ReceivedHTTPVersion := ReceivedHeader.HttpVersion; - BytesInBuffer := ReceivedHeader.Reader.BytesInBuffer; - //WriteLn('BytesInBuffer: ', BytesInBuffer, ', Content length: ', ReceivedHeader.ContentLength); - if Assigned(FOnHeaderReceived) then - FOnHeaderReceived(Self); - - RecvSize := ReceivedHeader.ContentLength; - if Assigned(ReceivedStream) then - begin - if BytesInBuffer = 0 then - NeedMoreData := True - else - begin - ReceivedStream.Write(ReceivedHeader.Reader.Buffer^, BytesInBuffer); - if RecvSize > 0 then - Dec(RecvSize, BytesInBuffer); - if BytesInBuffer = ReceivedHeader.ContentLength then - NeedMoreData := False - else - NeedMoreData := (not ReceivedHeader.InheritsFrom(THttpRequestHeader)) or - (THttpRequestHeader(ReceivedHeader).Command <> 'GET'); - end; - end else - NeedMoreData := False; - - if NeedMoreData then - DataAvailableNotifyHandle := - EventLoop.SetDataAvailableNotify(Stream.Handle, @DataAvailable, Stream) - else - ReceivedStreamCompleted(nil); - - if DoDestroy then - Self.Free; -end; - -procedure TCustomHttpClient.ReceivedHeaderEOF(Sender: TObject); -begin - Self.Free; -end; - -procedure TCustomHttpClient.DataAvailable(Sender: TObject); -var - FirstRun: Boolean; - ReadNow, BytesRead: Integer; - buf: array[0..1023] of Byte; -begin - FirstRun := True; - while True do - begin - if RecvSize >= 0 then - begin - ReadNow := RecvSize; - if ReadNow > 1024 then - ReadNow := 1024; - end else - ReadNow := 1024; - BytesRead := Stream.Read(buf, ReadNow); - // WriteLn('TCustomHttpClient.DataAvailable: Read ', BytesRead, ' bytes; RecvSize=', RecvSize); - if BytesRead <= 0 then - begin - if FirstRun then - ReceivedStreamCompleted(nil); - break; - end; - FirstRun := False; - ReceivedStream.Write(buf, BytesRead); - if RecvSize > 0 then - Dec(RecvSize, BytesRead); - if RecvSize = 0 then - begin - ReceivedStreamCompleted(nil); - break; - end; - end; - if DoDestroy then - Self.Free; -end; - -procedure TCustomHttpClient.ReceivedStreamCompleted(Sender: TObject); -begin - // WriteLn('TCustomHttpClient.ReceivedStreamCompleted'); - if Assigned(DataAvailableNotifyHandle) then - begin - EventLoop.ClearDataAvailableNotify(DataAvailableNotifyHandle); - DataAvailableNotifyHandle := nil; - end; - if Assigned(FOnStreamReceived) then - FOnStreamReceived(Self); - if DoDestroy then - Self.Free - else - Send; -end; - -{constructor TCustomHttpClient.Create(AManager: TEventLoop; ASocket: TInetSocket); -begin - inherited Create; - EventLoop := AManager; - Stream := ASocket; -end;} - -destructor TCustomHttpClient.Destroy; -begin - if Assigned(DataAvailableNotifyHandle) then - EventLoop.ClearDataAvailableNotify(DataAvailableNotifyHandle); - if Assigned(OnDestroy) then - OnDestroy(Self); - FreeAndNil(SendBuffer); - inherited Destroy; -end; - -procedure TCustomHttpClient.Receive; -begin - // Start receiver - ReceivedHttpVersion := ''; - if Assigned(OnPrepareReceiving) then - OnPrepareReceiving(Self); - if Assigned(ReceivedHeader) then - begin - ReceivedHeader.OnCompleted := @ReceivedHeaderCompleted; - ReceivedHeader.OnEOF := @ReceivedHeaderEOF; - ReceivedHeader.AsyncReceive(EventLoop, Stream); - end; -end; - -procedure TCustomHttpClient.Send; -begin - // Start sender - if Assigned(OnPrepareSending) then - OnPrepareSending(Self); - if Assigned(HeaderToSend) then - begin - if ReceivedHttpVersion <> '' then - begin - HeaderToSend.HttpVersion := ReceivedHttpVersion; - ReceivedHttpVersion := ''; - end; - HeaderToSend.OnCompleted := @HeaderToSendCompleted; - HeaderToSend.AsyncSend(EventLoop, Stream); - end; -end; - - -end. diff --git a/packages/fcl-net/src/mkxmlrpc.pp b/packages/fcl-net/src/mkxmlrpc.pp deleted file mode 100644 index a5a9a4196f..0000000000 --- a/packages/fcl-net/src/mkxmlrpc.pp +++ /dev/null @@ -1,871 +0,0 @@ -{ - - Automatic XML-RPC wrapper generator - Copyright (c) 2003 by - Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -} -program MkXMLRPC; - -{$mode objfpc} -{$H+} - -uses SysUtils, Classes, PParser, PasTree, PasWrite; - -resourcestring - SCmdLineInvalidOption = 'Ignoring unknown option "%s"'; - SNoServerClassNameProvided = - 'No server class name provided (use --serverclass=<name>)'; - SNoUnitNameProvided = - 'No name for generated unit provided (use --unitname=<name>)'; - -type - TParserEngine = class(TPasTreeContainer) - protected - Modules, UsedModules: TList; - CurModule: TPasModule; - public - constructor Create; - destructor Destroy; override; - function CreateElement(AClass: TPTreeElement; const AName: String; - AParent: TPasElement; AVisibility: TPasMemberVisibility; - const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement; - override; - function FindElement(const AName: String): TPasElement; override; - function FindModule(const AName: String): TPasModule; override; - end; - - TServerClass = class - Element: TPasClassType; - ImplName: String; - end; - - TRPCList = class - ServerClasses: TList; - UsedModules: TStringList; - constructor Create; - destructor Destroy; override; - procedure AddServerClass(const AClassName: String); - end; - -var - Engine: TParserEngine; - - -constructor TParserEngine.Create; -begin - inherited Create; - Modules := TList.Create; - UsedModules := TList.Create; -end; - -destructor TParserEngine.Destroy; -begin - UsedModules.Free; - Modules.Free; - inherited Destroy; -end; - -function TParserEngine.CreateElement(AClass: TPTreeElement; const AName: String; - AParent: TPasElement; AVisibility: TPasMemberVisibility; - const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement; -begin - Result := AClass.Create(AName, AParent); - Result.Visibility := AVisibility; - if AClass.InheritsFrom(TPasModule) then - begin - Modules.Add(Result); - CurModule := TPasModule(Result); - end; -end; - -function TParserEngine.FindElement(const AName: String): TPasElement; - - function FindInModule(AModule: TPasModule; const LocalName: String): TPasElement; - var - l: TList; - i, j: Integer; - Found: Boolean; - begin - l := AModule.InterfaceSection.Declarations; - for i := 0 to l.Count - 1 do - begin - Result := TPasElement(l[i]); - if CompareText(Result.Name, LocalName) = 0 then - begin - Found := False; - for j := 0 to UsedModules.Count - 1 do - if CompareText(TPasModule(UsedModules[j]).Name, AModule.Name) = 0 then - begin - Found := True; - break; - end; - if not Found then - UsedModules.Add(AModule); - exit; - end; - end; - Result := nil; - end; - -var - i: Integer; - //ModuleName, LocalName: String; - Module: TPasElement; -begin -{!!!: Don't know if we ever will have to use the following: - i := Pos('.', AName); - if i <> 0 then - begin - WriteLn('Dot found in name: ', AName); - Result := nil; - end else - begin} - Result := FindInModule(CurModule, AName); - if not Assigned(Result) then - for i := CurModule.InterfaceSection.UsesList.Count - 1 downto 0 do - begin - Module := TPasElement(CurModule.InterfaceSection.UsesList[i]); - if Module.ClassType = TPasModule then - begin - Result := FindInModule(TPasModule(Module), AName); - if Assigned(Result) then - exit; - end; - end; - {end;} -end; - -function TParserEngine.FindModule(const AName: String): TPasModule; -var - i: Integer; -begin - for i := Modules.Count - 1 downto 0 do - begin - Result := TPasModule(Modules[i]); - if CompareText(Result.Name, AName) = 0 then - exit; - end; - Result := nil; -end; - - -constructor TRPCList.Create; -begin - ServerClasses := TList.Create; - UsedModules := TStringList.Create; -end; - -destructor TRPCList.Destroy; -var - i: Integer; -begin - UsedModules.Free; - for i := 0 to ServerClasses.Count - 1 do - TServerClass(ServerClasses[i]).Free; - ServerClasses.Free; -end; - -procedure TRPCList.AddServerClass(const AClassName: String); -var - Element: TPasClassType; - ServerClass: TServerClass; -begin - Element := TPasClassType(Engine.FindElement(AClassName)); - if not Assigned(Element) then - begin - WriteLn(StdErr, 'Server class "', AClassName, '" not found!'); - Halt(3); - end; - if (not Element.InheritsFrom(TPasClassType)) or - (Element.ObjKind <> okClass) then - begin - WriteLn('"', AClassName, '" is not a class!'); - Halt(4); - end; - ServerClass := TServerClass.Create; - ServerClasses.Add(ServerClass); - ServerClass.Element := Element; - ServerClass.ImplName := Copy(Element.Name, 2, Length(Element.Name)); - UsedModules.Add(Element.GetModule.Name); -end; - - -var - OutputFilename, UnitName: String; - RPCList: TRPCList; - -procedure WriteClassServerSource(ServerClass: TPasClassType; - ImplementationSection: TPasSection; Method, ProcImpl: TPasProcedureImpl; - const MethodPrefix: String; NestingLevel: Integer); - -{ Method: Main server method - ProcImpl: Current procedure (may be identical with Method) } - -type - TConversionInfo = record - ConverterName, TypecastFunction: String; - ArgIsParent: Boolean; - end; - - function MakeStructConverter(AClass: TPasClassType; - Referrer: TPasProcedureImpl): TPasProcedureImpl; forward; - - function MakeArrayConverter(Member, ArraySizeProp: TPasProperty; - ProcessProc, Referrer: TPasProcedureImpl): TPasProcedureImpl; forward; - - function FindArraySizeProperty(AArrayProp: TPasProperty): TPasProperty; - var - i: Integer; - Name: String; - begin - Name := Copy(AArrayProp.Name, 1, Length(AArrayProp.Name) - 1) + 'Count'; - for i := 0 to TPasClassType(AArrayProp.Parent).Members.Count - 1 do - begin - Result := TPasProperty(TPasClassType(AArrayProp.Parent).Members[i]); - if (Result.ClassType = TPasProperty) and (Result.Visibility = visPublic) - and (CompareStr(Result.Name, Name) = 0) then - exit; - end; - - Name := AArrayProp.Name + 'Count'; - for i := 0 to TPasClassType(AArrayProp.Parent).Members.Count - 1 do - begin - Result := TPasProperty(TPasClassType(AArrayProp.Parent).Members[i]); - if (Result.ClassType = TPasProperty) and (Result.Visibility = visPublic) - and (CompareStr(Result.Name, Name) = 0) then - exit; - end; - Result := nil; - end; - - function GetConversionInfo(Element: TPasElement; - Referrer: TPasProcedureImpl): TConversionInfo; - var - s: String; - ArraySizeProp: TPasProperty; - begin - FillChar(Result, SizeOf(Result), 0); - Result.ArgIsParent := False; - - if Element.ClassType = TPasProperty then - begin - ArraySizeProp := FindArraySizeProperty(TPasProperty(Element)); - if Assigned(ArraySizeProp) then - begin - Result.ConverterName := MakeArrayConverter(TPasProperty(Element), - ArraySizeProp, ProcImpl, Referrer).Name; - Result.ArgIsParent := True; - exit; - end else - Element := TPasProperty(Element).VarType; - end; - - if Element.ClassType = TPasUnresolvedTypeRef then - begin - s := UpperCase(Element.Name); - if (s = 'BYTE') or (s = 'SHORTINT') or (S = 'SMALLINT') or - (s = 'INTEGER') or (s = 'LONGINT') or (s = 'CARDINAL') or - (s = 'INT64') or (s = 'QUADWORD') then - Result.ConverterName := 'AWriter.CreateIntValue' - else if (s = 'BOOLEAN') or (s = 'WORDBOOL') or (s = 'LONGBOOL') then - Result.ConverterName := 'AWriter.CreateBooleanValue' - else if s = 'STRING' then - Result.ConverterName := 'AWriter.CreateStringValue' - else if (s = 'FLOAT') or (s = 'SINGLE') or (s = 'DOUBLE') or - (s = 'EXTENDED') then - Result.ConverterName := 'AWriter.CreateDoubleValue' - else if s = 'TDATETIME' then - Result.ConverterName := 'AWriter.CreateDateTimeValue'; - end else if Element.ClassType = TPasClassType then - Result.ConverterName := MakeStructConverter(TPasClassType(Element), Referrer).Name - else if Element.ClassType = TPasEnumType then - begin - Result.ConverterName := 'AWriter.CreateIntValue'; - Result.TypecastFunction := 'Ord'; - end; - - if Length(Result.ConverterName) = 0 then - raise Exception.Create('Result type not supported: ' + Element.ClassName + - ' ' + Element.Name); - end; - - function MakeAccessor(ConversionInfo: TConversionInfo; - const DataSource, ArrayIndex: String): String; - begin - Result := ConversionInfo.ConverterName + '('; - if ConversionInfo.TypecastFunction <> '' then - Result := Result + ConversionInfo.TypecastFunction + '('; - Result := Result + DataSource; - if ConversionInfo.TypecastFunction <> '' then - Result := Result + ')'; - if ArrayIndex <> '' then - Result := Result + '[' + ArrayIndex + ']'; - Result := Result + ')'; - end; - - function GetParseValueFnName(PasType: TPasElement): String; - var - s: String; - begin - SetLength(Result, 0); - if PasType.ClassType = TPasArgument then - begin - if TPasArgument(PasType).Access = argVar then - raise Exception.Create('"var" arguments are not allowed'); - PasType := TPasArgument(PasType).ArgType; - end; - - if PasType.ClassType = TPasUnresolvedTypeRef then - begin - s := UpperCase(PasType.Name); - if (s = 'BYTE') or (s = 'SHORTINT') or (S = 'SMALLINT') or - (s = 'INTEGER') or (s = 'LONGINT') or (s = 'CARDINAL') or - (s = 'INT64') or (s = 'QUADWORD') then - Result := 'Int' - else if (s = 'BOOLEAN') or (s = 'WORDBOOL') or (s = 'LONGBOOL') then - Result := 'Boolean' - else if s = 'STRING' then - Result := 'String' - else if (s = 'FLOAT') or (s = 'SINGLE') or (s = 'DOUBLE') or - (s = 'EXTENDED') then - Result := 'Double' - else if s = 'TDATETIME' then - Result := 'DateTime'; - end; - if Length(Result) = 0 then - raise Exception.Create('Argument type not supported: ' + - PasType.ClassName + ' ' + PasType.Name); - end; - - function NeedLocalProc(const ProcName: String; - Referrer: TPasProcedureImpl): TPasProcedureImpl; - var - i, j: Integer; - begin - for i := 0 to Method.Locals.Count - 1 do - begin - Result := TPasProcedureImpl(Method.Locals[i]); - if Result.Name = ProcName then - begin - j := Method.Locals.IndexOf(Referrer); - if (j >= 0) and (i >= j) then - begin - // Move existing converter to the top and exit - Method.Locals.Delete(i); - j := Method.Locals.IndexOf(ProcImpl); - if j < 0 then - j := 0; - Method.Locals.Insert(j, Result); - end; - exit; - end; - end; - Result := nil; - end; - - function MakeStructConverter(AClass: TPasClassType; - Referrer: TPasProcedureImpl): TPasProcedureImpl; - var - ConverterName, s: String; - Commands: TPasImplCommands; - i: Integer; - LocalMember: TPasElement; - ConversionInfo: TConversionInfo; - begin - ConverterName := 'Convert' + AClass.Name; - Result := NeedLocalProc(ConverterName, Referrer); - if Assigned(Result) then - exit; - - Result := TPasProcedureImpl.Create(ConverterName, Method); - i := Method.Locals.IndexOf(Referrer); - if i < 0 then - i := 0; - Method.Locals.Insert(i, Result); - Result.ProcType := TPasFunctionType.Create('', Result); - Result.ProcType.CreateArgument('Inst', AClass.Name); - TPasFunctionType(Result.ProcType).ResultEl := - TPasResultElement.Create('', Result); - TPasFunctionType(Result.ProcType).ResultEl.ResultType := - TPasUnresolvedTypeRef.Create('TXMLRPCStruct', Result); - - Result.Body := TPasImplBlock.Create('', Result); - Commands := Result.Body.AddCommands; - Commands.Commands.Add('Result := AWriter.CreateStruct'); - for i := 0 to AClass.Members.Count - 1 do - begin - LocalMember := TPasElement(AClass.Members[i]); - if LocalMember.ClassType = TPasProperty then - begin - ConversionInfo := GetConversionInfo(LocalMember, Result); - if ConversionInfo.ArgIsParent then - s := 'Inst' - else - s := 'Inst.' + LocalMember.Name; - s := 'AWriter.AddStructMember(Result, ''' + LocalMember.Name + ''', ' + - MakeAccessor(ConversionInfo, s, '') + ')'; - Commands.Commands.Add(s); - end; - end; - end; - - function MakeArrayConverter(Member, ArraySizeProp: TPasProperty; - ProcessProc, Referrer: TPasProcedureImpl): TPasProcedureImpl; - var - i: Integer; - ConverterName, s: String; - Commands: TPasImplCommands; - VarMember: TPasVariable; - ForLoop: TPasImplForLoop; - ConversionInfo: TConversionInfo; - begin - ConverterName := 'Convert' + Member.Parent.Name + '_' + Member.Name; - Result := NeedLocalProc(ConverterName, Referrer); - if Assigned(Result) then - exit; - - Result := TPasProcedureImpl.Create(ConverterName, Method); - i := Method.Locals.IndexOf(Referrer); - if i < 0 then - i := 0; - Method.Locals.Insert(i, Result); - Result.ProcType := TPasFunctionType.Create('', Result); - Result.ProcType.CreateArgument('Inst', Member.Parent.Name); - TPasFunctionType(Result.ProcType).ResultEl := - TPasResultElement.Create('', Result); - TPasFunctionType(Result.ProcType).ResultEl.ResultType := - TPasUnresolvedTypeRef.Create('TXMLRPCArray', Result); - - Result.Body := TPasImplBlock.Create('', Result); - Commands := Result.Body.AddCommands; - Commands.Commands.Add('Result := AWriter.CreateArray'); - - VarMember := TPasVariable.Create('i', Result); - Result.Locals.Add(VarMember); - VarMember.VarType := TPasUnresolvedTypeRef.Create('Integer', VarMember); - - ForLoop := Result.Body.AddForLoop(TPasVariable.Create('i', Result), - '0', MethodPrefix + ArraySizeProp.Name + ' - 1'); - ForLoop.Body := TPasImplCommand.Create('', ForLoop); - ConversionInfo := GetConversionInfo(Member.VarType, Result); - if ConversionInfo.ArgIsParent then - s := 'Inst' - else - s := 'Inst.' + Member.Name + '[i]'; - s := 'AWriter.AddArrayElement(Result, ' + - MakeAccessor(ConversionInfo, s, '') + ')'; - TPasImplCommand(ForLoop.Body).Command := s; - end; - - function CreateDispatcher(VarType: TPasClassType; - Referrer: TPasProcedureImpl): TPasProcedureImpl; - var - DispatcherName: String; - begin - DispatcherName := 'Dispatch' + VarType.Name; - Result := NeedLocalProc(DispatcherName, Referrer); - if Assigned(Result) then - exit; - - // Create new dispatcher method - Result := TPasProcedureImpl.Create(DispatcherName, Method); - if ProcImpl = Method then - Method.Locals.Insert(0, Result) - else - Method.Locals.Insert(Method.Locals.IndexOf(Referrer), Result); - Result.ProcType := TPasProcedureType.Create('', Result); - Result.ProcType.CreateArgument('Inst', VarType.Name); - Result.ProcType.CreateArgument('Level', 'Integer'); - WriteClassServerSource(VarType, - ImplementationSection, Method, Result, 'Inst.', NestingLevel + 1); - end; - - -var - IfElse, ParentIfElse: TPasImplIfElse; - - procedure CreateBranch(const MethodName: String); - begin - if Assigned(ParentIfElse) then - begin - IfElse := TPasImplIfElse.Create('', ParentIfElse); - ParentIfElse.ElseBranch := IfElse; - end else - begin - IfElse := TPasImplIfElse.Create('', ProcImpl.Body); - ProcImpl.Body.Elements.Add(IfElse); - end; - ParentIfElse := IfElse; - IfElse.Condition := 's = ''' + UpperCase(MethodName) + ''''; - end; - - procedure ProcessMethodCall(Member: TPasProcedure); - - function MakeProcArgs(Args: TList): String; - var - i: Integer; - begin - if (not Assigned(Args)) or (Args.Count = 0) then - Result := '' - else - begin - Result := '('; - for i := 0 to Args.Count - 1 do - begin - if i > 0 then - Result := Result + ', '; - Result := Result + 'AParser.GetPrev' + GetParseValueFnName(TPasType(Args[i])); - end; - Result := Result + ')'; - end; - end; - - var - Commands: TPasImplCommands; - s: String; - begin - CreateBranch(Member.Name); - Commands := TPasImplCommands.Create('', IfElse); - IfElse.IfBranch := Commands; - - if TPasProcedure(Member).ProcType.Args.Count > 0 then - Commands.Commands.Add('AParser.ResetValueCursor'); - if Member.ClassType = TPasProcedure then - begin - Commands.Commands.Add(MethodPrefix + Member.Name + - MakeProcArgs(TPasProcedure(Member).ProcType.Args)); - Commands.Commands.Add('AWriter.WriteResponse(nil)'); - end else - begin - // function - s := MethodPrefix + Member.Name + - MakeProcArgs(TPasProcedure(Member).ProcType.Args); - Commands.Commands.Add('AWriter.WriteResponse(' + - MakeAccessor(GetConversionInfo(TPasFunctionType(TPasFunction(Member). - ProcType).ResultEl.ResultType, ProcImpl), s, '') + ')'); - end; - end; - - procedure ProcessProperty(Member: TPasProperty); - var - LocalIfElse: TPasImplIfElse; - IsArray, IsStruct: Boolean; - s, s2: String; - Commands: TPasImplCommands; - Command: TPasImplCommand; - ConversionInfo: TConversionInfo; - begin - if Member.ReadAccessorName <> '' then - begin - CreateBranch('Get' + Member.Name); - - IsArray := (Member.Args.Count = 1) and - Assigned(FindArraySizeProperty(Member)); - IsStruct := Member.VarType.ClassType = TPasClassType; - - if IsStruct then - s := CreateDispatcher(TPasClassType(Member.VarType), ProcImpl).Name + - '(' + MethodPrefix + Member.Name; - - if NestingLevel = 0 then - s2 := '1' - else - s2 := 'Level + 1'; - - if IsArray or (IsStruct and (Member.Args.Count = 0)) then - begin - LocalIfElse := TPasImplIfElse.Create('', IfElse); - IfElse.IfBranch := LocalIfElse; - LocalIfElse.Condition := 'APath.Count <= ' + s2; - end; - - if IsStruct then - if IsArray then - begin - LocalIfElse.IfBranch := TPasImplCommand.Create('', LocalIfElse); - TPasImplCommand(LocalIfElse.IfBranch).Command := - 'AWriter.WriteResponse(' + - MakeAccessor(GetConversionInfo(Member, ProcImpl), - Copy(MethodPrefix, 1, Length(MethodPrefix) - 1), '') + ')'; - - LocalIfElse.ElseBranch := TPasImplCommand.Create('', LocalIfElse); - TPasImplCommand(LocalIfElse.ElseBranch).Command := - s + '[AParser.GetNext' + - GetParseValueFnName(TPasArgument(Member.Args[0]).ArgType) + '], ' + - s2 + ')'; - end else - begin - if Member.Args.Count = 0 then - begin - LocalIfElse.IfBranch := TPasImplCommand.Create('', LocalIfElse); - TPasImplCommand(LocalIfElse.IfBranch).Command := - 'AWriter.WriteResponse(' + - MakeAccessor(GetConversionInfo(Member, ProcImpl), - MethodPrefix + Member.Name, '') + ')'; - LocalIfElse.ElseBranch := TPasImplCommand.Create('', LocalIfElse); - TPasImplCommand(LocalIfElse.ElseBranch).Command := s + ', ' + s2 + ')'; - end else - begin - IfElse.IfBranch := TPasImplCommand.Create('', IfElse); - TPasImplCommand(IfElse.IfBranch).Command := s + '[AParser.GetNext' + - GetParseValueFnName(TPasArgument(Member.Args[0]).ArgType) + '], ' + - s2 + ')'; - end; - end - else if IsArray then - begin - LocalIfElse.IfBranch := TPasImplCommand.Create('', LocalIfElse); - TPasImplCommand(LocalIfElse.IfBranch).Command := - 'AWriter.WriteResponse(' + - MakeAccessor(GetConversionInfo(Member, ProcImpl), - Copy(MethodPrefix, 1, Length(MethodPrefix) - 1), '') + ')'; - - LocalIfElse.ElseBranch := TPasImplCommand.Create('', LocalIfElse); - TPasImplCommand(LocalIfElse.ElseBranch).Command := - 'AWriter.WriteResponse(' + - MakeAccessor(GetConversionInfo(Member.VarType, ProcImpl), - MethodPrefix + Member.Name, 'AParser.GetNext' + - GetParseValueFnName(TPasArgument(Member.Args[0]).ArgType)) + ')'; - end else - begin - IfElse.IfBranch := TPasImplCommand.Create('', IfElse); - TPasImplCommand(IfElse.IfBranch).Command := 'AWriter.WriteResponse(' + - MakeAccessor(GetConversionInfo(Member.VarType, ProcImpl), - MethodPrefix + Member.Name, '') + ')'; - end; - end; - - if Member.WriteAccessorName <> '' then - begin - CreateBranch('Set' + Member.Name); - Commands := TPasImplCommands.Create('', IfElse); - IfElse.IfBranch := Commands; - Commands.Commands.Add('// Not supported by mkxmlrpc yet'); - end; - end; - -var - VarMember: TPasVariable; - i: Integer; - Command: TPasImplCommand; - Member: TPasElement; -begin - VarMember := TPasVariable.Create('s', ProcImpl); - ProcImpl.Locals.Add(VarMember); - VarMember.VarType := TPasUnresolvedTypeRef.Create('String', VarMember); - ProcImpl.Body := TPasImplBlock.Create('', ProcImpl); - if NestingLevel = 0 then - ProcImpl.Body.AddCommand('s := APath[' + IntToStr(NestingLevel) + ']') - else - ProcImpl.Body.AddCommand('s := APath[Level]'); - ParentIfElse := nil; - for i := 0 to ServerClass.Members.Count - 1 do - begin - Member := TPasElement(ServerClass.Members[i]); - if Member.Visibility <> visPublic then - continue; - - if (Member.ClassType = TPasProcedure) or (Member.ClassType = TPasFunction) - then - ProcessMethodCall(TPasProcedure(Member)) - else if Member.ClassType = TPasProperty then - ProcessProperty(TPasProperty(Member)) - else if (Member.ClassType <> TPasConstructor) and - (Member.ClassType <> TPasDestructor) then - WriteLn('Warning: Unsupportet member type: ', Member.ElementTypeName); - end; - - if Assigned(ParentIfElse) then - begin - Command := TPasImplCommand.Create('', ParentIfElse); - ParentIfElse.ElseBranch := Command; - end else - begin - Command := TPasImplCommand.Create('', ProcImpl.Body); - ProcImpl.Body.Elements.Add(Command); - end; - Command.Command := 'AWriter.WriteFaultResponse(2, ''Invalid method name'')'; -end; - -procedure WriteFPCServerSource; -var - i, j: Integer; - Module: TPasModule; - InterfaceSection:TInterfaceSection; - ImplementationSection: TImplementationSection; - VarMember: TPasVariable; - PropertyMember: TPasProperty; - ProcMember: TPasProcedure; - Arg: TPasArgument; - ServerClass: TPasClassType; - Stream: TStream; - ProcImpl: TPasProcedureImpl; - Found: Boolean; -begin - Module := TPasModule.Create(UnitName, nil); - try - InterfaceSection := TInterfaceSection.Create('', Module); - Module.InterfaceSection := InterfaceSection; - ImplementationSection := TImplementationSection.Create('', Module); - Module.ImplementationSection := ImplementationSection; - InterfaceSection.AddUnitToUsesList('Classes'); - InterfaceSection.AddUnitToUsesList('XMLRPC'); - for i := 0 to RPCList.UsedModules.Count - 1 do - InterfaceSection.AddUnitToUsesList(RPCList.UsedModules[i]); - - for i := 0 to RPCList.ServerClasses.Count - 1 do - with TServerClass(RPCList.ServerClasses[i]) do - begin - ServerClass := TPasClassType.Create('T' + ImplName + 'XMLRPCServlet', - InterfaceSection); - InterfaceSection.Declarations.Add(ServerClass); - ServerClass.ObjKind := okClass; - ServerClass.AncestorType := - TPasUnresolvedTypeRef.Create('TXMLRPCServlet', ServerClass); - - // Create private field which holds the implementation instance - VarMember := TPasVariable.Create('F' + ImplName, ServerClass); - VarMember.Visibility := visPrivate; - VarMember.VarType := TPasUnresolvedTypeRef.Create(Element.Name, VarMember); - ServerClass.Members.Add(VarMember); - - // Create dispatcher method - ProcMember := TPasProcedure.Create('Dispatch', ServerClass); - ProcMember.Visibility := visProtected; - ProcMember.AddModifier(pmOverride); - ProcMember.ProcType := TPasProcedureType.Create('', ProcMember); - ProcMember.ProcType.CreateArgument('AParser', 'TXMLRPCParser'). - Visibility := visPublic; - ProcMember.ProcType.CreateArgument('AWriter', 'TXMLRPCWriter'). - Visibility := visPublic; - ProcMember.ProcType.CreateArgument('APath', 'TStrings'). - Visibility := visPublic; - ServerClass.Members.Add(ProcMember); - - // Create published property for implementation instance - PropertyMember := TPasProperty.Create(ImplName, ServerClass); - PropertyMember.Visibility := visPublished; - PropertyMember.VarType := VarMember.VarType; - VarMember.VarType.AddRef; - PropertyMember.ReadAccessorName := 'F' + ImplName; - PropertyMember.WriteAccessorName := 'F' + ImplName; - ServerClass.Members.Add(PropertyMember); - - // Create dispatcher implementation - ProcImpl := TPasProcedureImpl.Create('Dispatch', ServerClass); - ImplementationSection.Declarations.Add(ProcImpl); - ProcImpl.ProcType := ProcMember.ProcType; - ProcMember.ProcType.AddRef; - ProcImpl.ProcType.AddRef; - WriteClassServerSource(Element, ImplementationSection, ProcImpl, - ProcImpl, ImplName + '.', 0); - end; - - for i := 0 to Engine.UsedModules.Count - 1 do - begin - Found := False; - for j := 0 to RPCList.UsedModules.Count - 1 do - if CompareText(RPCList.UsedModules[j], - TPasModule(Engine.UsedModules[i]).Name) = 0 then - begin - Found := True; - break; - end; - if not Found then - ImplementationSection.AddUnitToUsesList( - TPasModule(Engine.UsedModules[i]).Name); - end; - - Stream := THandleStream.Create(StdOutputHandle); - try - WritePasFile(Module, Stream); - finally - Stream.Free; - end; - - Stream := TFileStream.Create(OutputFilename, fmCreate); - try - WritePasFile(Module, Stream); - finally - Stream.Free; - end; - finally - Module.Free; - end; -end; - - -var - i, j: Integer; - s, Cmd, Arg: String; - InputFiles, ClassList: TStringList; -begin - InputFiles := TStringList.Create; - ClassList := TStringList.Create; - try - for i := 1 to ParamCount do - begin - s := ParamStr(i); - j := Pos('=', s); - if j > 0 then - begin - Cmd := Copy(s, 1, j - 1); - Arg := Copy(s, j + 1, Length(s)); - end else - begin - Cmd := s; - SetLength(Arg, 0); - end; - if (Cmd = '-i') or (Cmd = '--input') then - InputFiles.Add(Arg) - else if Cmd = '--output' then - OutputFilename := Arg - else if Cmd = '--unitname' then - UnitName := Arg - else if Cmd = '--serverclass' then - ClassList.Add(Arg) - else - WriteLn(StdErr, Format(SCmdLineInvalidOption, [s])); - end; - - if ClassList.Count = 0 then - begin - WriteLn(StdErr, SNoServerClassNameProvided); - Halt(2); - end; - - if UnitName = '' then - begin - WriteLn(StdErr, SNoUnitNameProvided); - Halt(2); - end; - - Engine := TParserEngine.Create; - try - // Engine.SetPackageName('XMLRPC'); - for i := 0 to InputFiles.Count - 1 do - ParseSource(Engine, InputFiles[i], '', ''); - - RPCList := TRPCList.Create; - try - for i := 0 to ClassList.Count - 1 do - RPCList.AddServerClass(ClassList[i]); - WriteFPCServerSource; - finally - RPCList.Free; - end; - finally - Engine.Free; - end; - finally - InputFiles.Free; - ClassList.Free; - end; -end. diff --git a/packages/fcl-net/src/servlets.pp b/packages/fcl-net/src/servlets.pp deleted file mode 100644 index 34dca4ba9a..0000000000 --- a/packages/fcl-net/src/servlets.pp +++ /dev/null @@ -1,114 +0,0 @@ -{ - - Basic Servlet Support - Copyright (c) 2003 by - Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -} -{$mode objfpc}{$H+} -unit Servlets; - -interface - -uses SysUtils, Classes; - -type - - EServlet = class(Exception); - - TServletContext = class - public - property Attributes[const AName: String]: TObject; // !!!: Implement this rw - // function GetContext(const URIPath: String): TServletContext; // !!!: How to implement? - // function GetRealPath(const APath: String): String; // !!!: How to implement? - property ServletContextName: String; // !!!: How to implement? - // procedure Log(const AMsg: String); // !!!: Implement this - // procedure RemoveAttribute(const AName: String); // !!!: Implement this - end; - - TServletRequest = class - private - FInputStream: TStream; - FScheme: String; - protected - FPathInfo: String; - - function GetContentLength: Integer; virtual; abstract; - function GetContentType: String; virtual; abstract; - function GetProtocol: String; virtual; abstract; - public - constructor Create(AInputStream: TStream; const AScheme, APathInfo: String); - property Attributes[const AName: String]: TObject; // !!!: Implement this rw - property CharacterEncoding: String; // !!!: Implement this rw - property ContentLength: Integer read GetContentLength; - property ContentType: String read GetContentType; - property InputStream: TStream read FInputStream; - property Parameters[const AName: String]: String; // !!!: Implement this - property ParameterValues[const AName: String]: TStrings; // !!!: Implement this - property Protocol: String read GetProtocol; - property RemoteAddr: String; // !!!: Implement this - property RemoteHost: String; // !!!: Implement this - property Scheme: String read FScheme; - property ServerName: String; // !!!: How to implement? - property ServerPort: Integer; // !!!: How to implement? - property IsSecure: Boolean; // !!!: Implement this - - // procedure RemoveAttribute(const AName: String); // !!!: Implement this - end; - - TServletResponse = class - private - FOutputStream: TStream; - protected - procedure SetContentType(const Value: String); virtual; abstract; - procedure SetContentLength(Value: Int64); virtual; abstract; - public - constructor Create(AOutputStream: TStream); - property BufferSize: Integer; // !!!: How to implement? rw - property CharacterEncoding: String; // !!!: Implement this - property ContentLength: Int64 write SetContentLength; - property ContentType: String write SetContentType; - property OutputStream: TStream read FOutputStream; - property IsCommitted: Boolean; // !!!: Implement this - - // procedure FlushBuffer; // !!!: Implement this - // procedure Reset; // !!!: Implement this - // procedure ResetBuffer; // !!!: Implement this - end; - - TGenericServlet = class(TComponent) - public - procedure Service(Req: TServletRequest; Resp: TServletResponse); - virtual; abstract; - property ServletContext: TServletContext; // !!!: Implement this - end; - - - -implementation - - -constructor TServletRequest.Create(AInputStream: TStream; - const AScheme, APathInfo: String); -begin - inherited Create; - FInputStream := AInputStream; - FScheme := AScheme; - FPathInfo := APathInfo; -end; - - -constructor TServletResponse.Create(AOutputStream: TStream); -begin - inherited Create; - FOutputStream := AOutputStream; -end; - - -end. diff --git a/packages/fcl-net/src/xmlrpc.pp b/packages/fcl-net/src/xmlrpc.pp deleted file mode 100644 index a998df30b3..0000000000 --- a/packages/fcl-net/src/xmlrpc.pp +++ /dev/null @@ -1,941 +0,0 @@ -{ - - XML-RPC server and client library - Copyright (c) 2003-2004 by - Areca Systems GmbH / Sebastian Guenther, sg@freepascal.org - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -} -{$mode objfpc}{$H+} -unit XMLRPC; - -interface - -uses SysUtils, Classes, fpAsync, ssockets, DOM, HTTPClient, HTTPSvlt; - -type - EXMLRPCParser = class(Exception); - - TXMLRPCParams = class(TDOMElement); - TXMLRPCValue = class(TDOMElement); - TXMLRPCStruct = class(TXMLRPCValue); - TXMLRPCArray = class(TXMLRPCValue); - - TXMLRPCWriter = class - private - Doc: TXMLDocument; - protected - function CreateValueEl: TXMLRPCValue; - public - constructor Create; - destructor Destroy; override; - function MakeStream: TMemoryStream; - - procedure WriteMethodCall(const AMethodName: DOMString; - Params: TXMLRPCParams); - procedure WriteResponse(Value: TXMLRPCValue); - procedure WriteFaultResponse(FaultCode: LongInt; - const FaultString: DOMString); - function CreateParams: TXMLRPCParams; - procedure AddParam(Params: TXMLRPCParams; Value: TXMLRPCValue); - function CreateIntValue(i: LongInt): TXMLRPCValue; - function CreateBooleanValue(b: Boolean): TXMLRPCValue; - function CreateStringValue(const s: DOMString): TXMLRPCValue; - function CreateDoubleValue(d: Double): TXMLRPCValue; - function CreateDateTimeValue(dt: TDateTime): TXMLRPCValue; - function CreateStruct: TXMLRPCStruct; - procedure AddStructMember(Struct: TXMLRPCStruct; const Name: DOMString; - Member: TXMLRPCValue); - function CreateArray: TXMLRPCArray; - procedure AddArrayElement(AArray: TXMLRPCArray; Value: TXMLRPCValue); - // !!!: Missing: Binary data - end; - - TXMLRPCPostType = ( - xmlrpcInvalid, // Invalid post type - xmlrpcMethodCall, // Method call - xmlrpcResponse, // Method call response (successfull) - xmlrpcFaultResponse); // Method call response (failed) - - TXMLRPCParser = class - private - Doc: TXMLDocument; - CurDataNode: TDOMNode; - InArray: Boolean; - procedure NextNode; - procedure PrevNode; - function GetValue: String; - function FindStructMember(AStruct: TXMLRPCStruct; - const AMemberName: String): TDOMElement; - function GetStructMemberValue(MemberNode: TDOMElement): String; - public - constructor Create(AStream: TStream); - destructor Destroy; override; - function GetPostType: TXMLRPCPostType; - function GetMethodName: String; - procedure ResetValueCursor; - // Simple values - function GetNextInt: LongInt; - function GetPrevInt: LongInt; - function GetNextBoolean: Boolean; - function GetPrevBoolean: Boolean; - function GetNextString: String; - function GetPrevString: String; - function GetNextDouble: Double; - function GetPrevDouble: Double; - // !!!: Missing: DateTime, Binary data - // Struct values - function GetNextStruct: TXMLRPCStruct; - function GetIntMember(AStruct: TXMLRPCStruct; const AName: String; - ADefault: Integer): Integer; - function GetBooleanMember(AStruct: TXMLRPCStruct; const AName: String; - ADefault: Boolean): Boolean; - function GetStringMember(AStruct: TXMLRPCStruct; const AName: String; - const ADefault: String): String; - function GetDoubleMember(AStruct: TXMLRPCStruct; const AName: String; - ADefault: Double): Double; - // Array values - procedure BeginArray; - procedure EndArray; - end; - - -{$ifdef NEVERTRUE} - TOnXMLRPCCallCompleted = procedure(AParser: TXMLRPCParser) of object; - - TXMLRPCClient = class - private - FEventLoop: TEventLoop; - FServerURL: String; - FOnBeginRPC, FOnEndRPC: TNotifyEvent; - RequestStream, ResponseStream: TMemoryStream; - CurCallback: TOnXMLRPCCallCompleted; - LocalEventLoop: TEventLoop; - Connection: TCustomHttpClient; - - procedure MakeRequest(const AProcName: String; AArgs: array of const); - procedure ProcessAnswer; - procedure StreamSent(Sender: TObject); - procedure DataAvailable(Sender: TObject); - public - constructor Create(AEventLoop: TEventLoop); - procedure Call(ACallback: TOnXMLRPCCallCompleted; - const AProcName: String; AArgs: array of const); - procedure CallAsync(ACallback: TOnXMLRPCCallCompleted; - const AProcName: String; AArgs: array of const); - - property EventLoop: TEventLoop read FEventLoop; - property ServerURL: String read FServerURL write FServerURL; - - property OnBeginRPC: TNotifyEvent read FOnBeginRPC write FOnBeginRPC; - property OnEndRPC: TNotifyEvent read FOnEndRPC write FOnEndRPC; - end; -{$endif} - - TCheckCallEvent = procedure(AParser: TXMLRPCParser; const APath: TStrings; - var ExecCall: Boolean) of object; - TExceptionEvent = procedure(e: Exception) of object; - - TXMLRPCServlet = class(THttpServlet) - private - FOnCheckCall: TCheckCallEvent; - FOnException: TExceptionEvent; - protected - procedure DoPost(Req: THttpServletRequest; Resp: THttpServletResponse); - override; - public - procedure Dispatch(AParser: TXMLRPCParser; AWriter: TXMLRPCWriter; - APath: TStrings); virtual; abstract; - property OnCheckCall: TCheckCallEvent read FOnCheckCall write FOnCheckCall; - property OnException: TExceptionEvent read FOnException write FOnException; - end; - - -implementation - -uses XMLWrite, XMLRead; - - -// Debugging stuff - -{$IFDEF XMLRPCDebug} -const - NodeNames: array[ELEMENT_NODE..NOTATION_NODE] of String = ( - 'Element', - 'Attribute', - 'Text', - 'CDATA section', - 'Entity reference', - 'Entity', - 'Processing instruction', - 'Comment', - 'Document', - 'Document type', - 'Document fragment', - 'Notation' - ); - -procedure DumpNode(node: TDOMNode; spc: String); -var - i: Integer; - attr: TDOMNode; -begin - Write(spc, NodeNames[node.NodeType]); - if Copy(node.NodeName, 1, 1) <> '#' then - Write(' "', node.NodeName, '"'); - if node.NodeValue <> '' then - Write(' "', node.NodeValue, '"'); - - if (node.Attributes <> nil) and (node.Attributes.Length > 0) then begin - Write(','); - for i := 0 to node.Attributes.Length - 1 do begin - attr := node.Attributes.Item[i]; - Write(' ', attr.NodeName, ' = "', attr.NodeValue, '"'); - end; - end; - WriteLn; - - node := node.FirstChild; - while Assigned(node) do - begin - DumpNode(node, spc + ' '); - node := node.NextSibling; - end; -end; -{$ENDIF} - - -// XML-RPC Writer - -constructor TXMLRPCWriter.Create; -begin - inherited Create; - Doc := TXMLDocument.Create; -end; - -destructor TXMLRPCWriter.Destroy; -begin - Doc.Free; - inherited Destroy; -end; - -function TXMLRPCWriter.MakeStream: TMemoryStream; -begin - Result := TMemoryStream.Create; - try - WriteXMLFile(Doc, Result); -// WriteXMLFile(Doc, THandleStream.Create(StdOutputHandle)); - Result.Position := 0; - except - on e: Exception do - Result.Free; - end; -end; - -procedure TXMLRPCWriter.WriteMethodCall(const AMethodName: DOMString; - Params: TXMLRPCParams); -var - El, El2: TDOMElement; -begin - El := Doc.CreateElement('methodCall'); - Doc.AppendChild(El); - El2 := Doc.CreateElement('methodName'); - El.AppendChild(El2); - El2.AppendChild(Doc.CreateTextNode(AMethodName)); - El.AppendChild(Params); -end; - -procedure TXMLRPCWriter.WriteResponse(Value: TXMLRPCValue); -var - El, El2: TDOMElement; -begin - ASSERT(Value is TXMLRPCValue); - El := Doc.CreateElement('methodResponse'); - Doc.AppendChild(El); - El2 := Doc.CreateElement('params'); - El.AppendChild(El2); - if not Assigned(Value) then - Value := CreateBooleanValue(True); - El := Doc.CreateElement('param'); - El2.AppendChild(El); - El.AppendChild(Value); -end; - -procedure TXMLRPCWriter.WriteFaultResponse(FaultCode: LongInt; - const FaultString: DOMString); -var - El, El2: TDOMElement; - Struct: TXMLRPCStruct; -begin - El := Doc.CreateElement('methodResponse'); - Doc.AppendChild(El); - El2 := Doc.CreateElement('fault'); - El.AppendChild(El2); - Struct := CreateStruct; - AddStructMember(Struct, 'faultCode', CreateIntValue(FaultCode)); - AddStructMember(Struct, 'faultString', CreateStringValue(FaultString)); - El2.AppendChild(Struct); -end; - -function TXMLRPCWriter.CreateParams: TXMLRPCParams; -begin - Result := TXMLRPCParams(Doc.CreateElement('params')); -end; - -procedure TXMLRPCWriter.AddParam(Params: TXMLRPCParams; Value: TXMLRPCValue); -var - El: TDOMElement; -begin - ASSERT((Params is TXMLRPCParams) and (Value is TXMLRPCValue)); - El := Doc.CreateElement('param'); - Params.AppendChild(El); - El.AppendChild(Value); -end; - -function TXMLRPCWriter.CreateIntValue(i: LongInt): TXMLRPCValue; -var - El: TDOMElement; -begin - Result := CreateValueEl; - El := Doc.CreateElement('int'); - Result.AppendChild(El); - El.AppendChild(Doc.CreateTextNode(IntToStr(i))); -end; - -function TXMLRPCWriter.CreateBooleanValue(b: Boolean): TXMLRPCValue; -var - El: TDOMElement; -begin - Result := CreateValueEl; - El := Doc.CreateElement('boolean'); - Result.AppendChild(El); - El.AppendChild(Doc.CreateTextNode(IntToStr(Ord(b)))); -end; - -function TXMLRPCWriter.CreateStringValue(const s: DOMString): TXMLRPCValue; -var - El: TDOMElement; -begin - Result := CreateValueEl; - El := Doc.CreateElement('string'); - Result.AppendChild(El); - if Length(s) > 0 then - El.AppendChild(Doc.CreateTextNode(s)); -end; - -function TXMLRPCWriter.CreateDoubleValue(d: Double): TXMLRPCValue; -var - El: TDOMElement; -begin - Result := CreateValueEl; - El := Doc.CreateElement('double'); - Result.AppendChild(El); - El.AppendChild(Doc.CreateTextNode(FloatToStr(d))); -end; - -function TXMLRPCWriter.CreateDateTimeValue(dt: TDateTime): TXMLRPCValue; -var - El: TDOMElement; -begin - Result := CreateValueEl; - El := Doc.CreateElement('dateTime.iso8601'); - Result.AppendChild(El); - El.AppendChild(Doc.CreateTextNode(FormatDateTime('ddmmyyyyThh:nn:ss', dt))); -end; - -function TXMLRPCWriter.CreateStruct: TXMLRPCStruct; -begin - Result := TXMLRPCStruct(CreateValueEl); - Result.AppendChild(Doc.CreateElement('struct')); -end; - -procedure TXMLRPCWriter.AddStructMember(Struct: TXMLRPCStruct; - const Name: DOMString; Member: TXMLRPCValue); -var - MemberEl, El: TDOMElement; -begin - ASSERT((Struct is TXMLRPCStruct) and (Name <> '') and - (Member is TXMLRPCValue)); - MemberEl := Doc.CreateElement('member'); - Struct.FirstChild.AppendChild(MemberEl); - El := Doc.CreateElement('name'); - MemberEl.AppendChild(El); - El.AppendChild(Doc.CreateTextNode(Name)); - MemberEl.AppendChild(Member); -end; - -function TXMLRPCWriter.CreateArray: TXMLRPCArray; -var - ArrayEl: TDOMElement; -begin - Result := TXMLRPCArray(CreateValueEl); - ArrayEl := Doc.CreateElement('array'); - Result.AppendChild(ArrayEl); - ArrayEl.AppendChild(Doc.CreateElement('data')); -end; - -procedure TXMLRPCWriter.AddArrayElement(AArray: TXMLRPCArray; - Value: TXMLRPCValue); -begin - ASSERT((AArray is TXMLRPCArray) and (Value is TXMLRPCValue)); - AArray.FirstChild.FirstChild.AppendChild(Value); -end; - -function TXMLRPCWriter.CreateValueEl: TXMLRPCValue; -begin - Result := TXMLRPCValue(Doc.CreateElement('value')); -end; - - -// XML-RPC Parser - -constructor TXMLRPCParser.Create(AStream: TStream); -var - Node: TDOMNode; -begin - inherited Create; - ReadXMLFile(Doc, AStream); - Node := Doc.DocumentElement; - {$IFDEF XMLRPCDebug}DumpNode(Node, 'Parser> ');{$ENDIF} - if (Node.NodeName = 'methodCall') or (Node.NodeName = 'methodResponse') then - begin - Node := Node.FirstChild; - while Assigned(Node) and (Node.NodeName <> 'params') do - Node := Node.NextSibling; - if Assigned(Node) then - begin - Node := Node.FirstChild; - while Assigned(Node) and (Node.NodeName <> 'param') do - Node := Node.NextSibling; - CurDataNode := Node; - end; - end; -end; - -destructor TXMLRPCParser.Destroy; -begin - Doc.Free; - inherited Destroy; -end; - -function TXMLRPCParser.GetPostType: TXMLRPCPostType; -var - Node: TDOMNode; -begin - Result := xmlrpcInvalid; - Node := Doc.DocumentElement; - if Node.NodeName = 'methodCall' then - Result := xmlrpcMethodCall - else if Node.NodeName = 'methodResponse' then - begin - Node := Node.FirstChild; - while Assigned(Node) and (Node.NodeType <> ELEMENT_NODE) do - Node := Node.NextSibling; - if Assigned(Node) then - if Node.NodeName = 'params' then - Result := xmlrpcResponse - else if Node.NodeName = 'fault' then - Result := xmlrpcFaultResponse; - end; -end; - -function TXMLRPCParser.GetMethodName: String; -var - Node: TDOMNode; -begin - SetLength(Result, 0); - Node := Doc.DocumentElement; - if (not Assigned(Node)) or (Node.NodeName <> 'methodCall') then - exit; - Node := Node.FindNode('methodName'); - if not Assigned(Node) then - exit; - Node := Node.FirstChild; - while Assigned(Node) do - begin - if Node.NodeType = TEXT_NODE then - Result := Result + Node.NodeValue; - Node := Node.NextSibling; - end; -end; - -procedure TXMLRPCParser.ResetValueCursor; -begin - CurDataNode := CurDataNode.ParentNode.FirstChild; - {$IFDEF XMLRPCDebug}DumpNode(CurDataNode, 'ResetValueCursor> ');{$ENDIF} -end; - -function TXMLRPCParser.GetNextInt: LongInt; -begin - Result := StrToInt(GetValue); - NextNode; -end; - -function TXMLRPCParser.GetPrevInt: LongInt; -begin - PrevNode; - Result := StrToInt(GetValue); -end; - -function TXMLRPCParser.GetNextBoolean: Boolean; -begin - Result := GetValue = '1'; - NextNode; -end; - -function TXMLRPCParser.GetPrevBoolean: Boolean; -begin - PrevNode; - Result := GetValue = '1'; -end; - -function TXMLRPCParser.GetNextString: String; -begin - Result := GetValue; - NextNode; -end; - -function TXMLRPCParser.GetPrevString: String; -begin - PrevNode; - Result := GetValue; -end; - -function TXMLRPCParser.GetNextDouble: Double; -begin - Result := StrToFloat(GetValue); - NextNode; -end; - -function TXMLRPCParser.GetPrevDouble: Double; -begin - PrevNode; - Result := StrToFloat(GetValue); -end; - -function TXMLRPCParser.GetNextStruct: TXMLRPCStruct; -begin - if Assigned(CurDataNode) and Assigned(CurDataNode.FirstChild) then - begin - Result := TXMLRPCStruct(CurDataNode.FirstChild); - while Assigned(Result) and (Result.NodeName <> 'struct') do - Result := TXMLRPCStruct(Result.NextSibling); - NextNode; - end else - Result := nil; -end; - -function TXMLRPCParser.GetIntMember(AStruct: TXMLRPCStruct; - const AName: String; ADefault: Integer): Integer; -var - MemberNode: TDOMElement; -begin - MemberNode := FindStructMember(AStruct, AName); - if Assigned(MemberNode) then - Result := StrToInt(GetStructMemberValue(MemberNode)) - else - Result := ADefault; -end; - -function TXMLRPCParser.GetBooleanMember(AStruct: TXMLRPCStruct; - const AName: String; ADefault: Boolean): Boolean; -var - MemberNode: TDOMElement; -begin - MemberNode := FindStructMember(AStruct, AName); - if Assigned(MemberNode) then - Result := GetStructMemberValue(MemberNode) = '1' - else - Result := ADefault; -end; - -function TXMLRPCParser.GetStringMember(AStruct: TXMLRPCStruct; - const AName: String; const ADefault: String): String; -var - MemberNode: TDOMElement; -begin - MemberNode := FindStructMember(AStruct, AName); - if Assigned(MemberNode) then - Result := GetStructMemberValue(MemberNode) - else - Result := ADefault; -end; - -function TXMLRPCParser.GetDoubleMember(AStruct: TXMLRPCStruct; - const AName: String; ADefault: Double): Double; -var - MemberNode: TDOMElement; -begin - MemberNode := FindStructMember(AStruct, AName); - if Assigned(MemberNode) then - Result := StrToFloat(GetStructMemberValue(MemberNode)) - else - Result := ADefault; -end; - -procedure TXMLRPCParser.BeginArray; -begin - if Assigned(CurDataNode) then - begin - CurDataNode := CurDataNode.FirstChild; - while Assigned(CurDataNode) and (CurDataNode.NodeName <> 'array') do - CurDataNode := CurDataNode.NextSibling; - if Assigned(CurDataNode) then - begin - CurDataNode := CurDataNode.FirstChild; - while Assigned(CurDataNode) and (CurDataNode.NodeName <> 'data') do - CurDataNode := CurDataNode.NextSibling; -{ if Assigned(CurDataNode) then - begin - CurDataNodeParent := CurDataNode; - CurDataNode := nil; - ResetValueCursor; - end;} - end; - //NextNode; - end; -end; - -procedure TXMLRPCParser.EndArray; -begin -end; - -procedure TXMLRPCParser.NextNode; -begin - repeat - CurDataNode := CurDataNode.NextSibling; - until (not Assigned(CurDataNode)) or (CurDataNode.NodeType = ELEMENT_NODE); -end; - -procedure TXMLRPCParser.PrevNode; -begin - {$IFDEF XMLRPCDebug}DumpNode(CurDataNode, 'PrevNode before> ');{$ENDIF} - if Assigned(CurDataNode.PreviousSibling) then - CurDataNode := CurDataNode.PreviousSibling - else - CurDataNode := CurDataNode.ParentNode.LastChild; - {$IFDEF XMLRPCDebug}DumpNode(CurDataNode, 'PrevNode result> ');{$ENDIF} -end; - -function TXMLRPCParser.GetValue: String; -var - Node: TDOMNode; -begin - if not Assigned(CurDataNode) then - Result := '' - else - begin - Node := CurDataNode; - if Node.NodeName <> 'value' then - Node := Node.FirstChild; - Node := Node.FirstChild; - if Node.NodeType = TEXT_NODE then - Result := Node.NodeValue - else begin - while Assigned(Node) and (Node.NodeType <> ELEMENT_NODE) do - Node := Node.NextSibling; - if Assigned(Node) then - begin - Node := Node.FirstChild; - if Assigned(Node) and (Node.NodeType = TEXT_NODE) then - Result := Node.NodeValue - else - Result := ''; - end; - end; - end; -end; - -function TXMLRPCParser.FindStructMember(AStruct: TXMLRPCStruct; - const AMemberName: String): TDOMElement; -var - Node: TDOMNode; -begin - Result := TDOMElement(AStruct.FirstChild); - while Assigned(Result) and (Result.NodeName = 'member') do - begin - Node := Result.FirstChild; - while Assigned(Node) do - begin - if Node.NodeName = 'name' then - begin - if Assigned(Node.FirstChild) and - (CompareText(Node.FirstChild.NodeValue, AMemberName) = 0) then - exit; - end; - Node := Node.NextSibling; - end; - Result := TDOMElement(Result.NextSibling); - end; -end; - -function TXMLRPCParser.GetStructMemberValue(MemberNode: TDOMElement): String; -var - Node, Subnode: TDOMNode; -begin - Node := MemberNode.FirstChild; - while Assigned(Node) do - begin - if Node.NodeName = 'value' then - begin - Subnode := Node.FirstChild; - if Assigned(Subnode) and (Subnode.NodeType = TEXT_NODE) then - begin - Result := Subnode.NodeValue; - exit; - end; - while Assigned(Subnode) do - begin - if Subnode.NodeType = ELEMENT_NODE then - begin - if Assigned(Subnode.FirstChild) then - Result := Subnode.FirstChild.NodeValue - else - Result := ''; - exit; - end; - Subnode := Subnode.NextSibling; - end; - end; - Node := Node.NextSibling; - end; -end; - - -{$IFDEF NEVERTRUE} -// XML-RPC Client - -constructor TXMLRPCClient.Create(AEventLoop: TEventLoop); -begin - inherited Create; - FEventLoop := AEventLoop; -end; - -procedure TXMLRPCClient.Call(ACallback: TOnXMLRPCCallCompleted; - const AProcName: String; AArgs: array of const); -var - Host: String; - Port: Word; - Socket: TInetSocket; -begin - CurCallback := ACallback; - MakeRequest(AProcName, AArgs); - try - ResponseStream := TMemoryStream.Create; - if Assigned(OnBeginRPC) then - OnBeginRPC(Self); - - Host := 'localhost'; - Port := 12345; - - Socket := TInetSocket.Create(Host, Port); - try - RequestStream.Position := 0; -// Socket.Write(RequestStream.Memory^, RequestStream.Size); - LocalEventLoop := TEventLoop.Create; - try - Connection := TCustomHttpClient.Create(LocalEventLoop, Socket); - try - Connection.HeaderToSend := THttpRequestHeader.Create; - with THttpRequestHeader(Connection.HeaderToSend) do - begin - Command := 'POST'; - URI := '/xmlrpc'; - UserAgent := 'Free Pascal XML-RPC'; - ContentType := 'text/xml'; - ContentLength := RequestStream.Size; - end; - Connection.StreamToSend := RequestStream; - Connection.ReceivedHeader := THttpResponseHeader.Create; - Connection.ReceivedStream := ResponseStream; - Connection.OnStreamSent := @StreamSent; - Connection.Send; - LocalEventLoop.Run; - finally - if Assigned(Connection) then - begin - Connection.HeaderToSend.Free; - Connection.ReceivedHeader.Free; - end; - Connection.Free; - end; - finally - LocalEventLoop.Free; - end; - finally - Socket.Free; - end; - finally - FreeAndNil(RequestStream); - end; - -// HTTPConnection.Post(ServerURL, RequestStream, ResponseStream); - ProcessAnswer; -end; - -procedure TXMLRPCClient.CallAsync(ACallback: TOnXMLRPCCallCompleted; - const AProcName: String; AArgs: array of const); -begin - CurCallback := ACallback; - MakeRequest(AProcName, AArgs); - ResponseStream := TMemoryStream.Create; - if Assigned(OnBeginRPC) then - OnBeginRPC(Self); - -// CurRPCThread := TRPCThread.Create(Self); -end; - -procedure TXMLRPCClient.MakeRequest(const AProcName: String; - AArgs: array of const); -var - Writer: TXMLRPCWriter; - Params: TXMLRPCParams; - i: Integer; -begin - Writer := TXMLRPCWriter.Create; - try - Params := Writer.CreateParams; - try - for i := Low(AArgs) to High(AArgs) do - with AArgs[i] do - case VType of - vtInteger: Writer.AddParam(Params, Writer.CreateIntValue(VInteger)); - vtBoolean: Writer.AddParam(Params, Writer.CreateBooleanValue(VBoolean)); - vtChar: Writer.AddParam(Params, Writer.CreateStringValue(VChar)); - vtExtended: Writer.AddParam(Params, Writer.CreateDoubleValue(VExtended^)); - vtString: Writer.AddParam(Params, Writer.CreateStringValue(VString^)); - vtPChar: Writer.AddParam(Params, Writer.CreateStringValue(VPChar)); - vtWideChar: Writer.AddParam(Params, Writer.CreateStringValue(VWideChar)); - vtPWideChar: Writer.AddParam(Params, Writer.CreateStringValue(VPWideChar)); - vtAnsiString: Writer.AddParam(Params, Writer.CreateStringValue(String(VAnsiString))); - // vtCurrency: ? - // vtVariant: ? - vtInt64: Writer.AddParam(Params, Writer.CreateIntValue(VInt64^)); - else - raise Exception.Create('Unsupported data type in RPC argument list'); - end; - Writer.WriteMethodCall(AProcName, Params); - RequestStream := Writer.MakeStream; - except - Params.Free; - end; - finally - Writer.Free; - end; -end; - -procedure TXMLRPCClient.ProcessAnswer; -var - Parser: TXMLRPCParser; -begin - ResponseStream.Position := 0; - Parser := TXMLRPCParser.Create(ResponseStream); - FreeAndNil(ResponseStream); - try - case Parser.GetPostType of - xmlrpcFaultResponse: -} {raise Exception.Create(Format('%d - %s', [Parser.GetNextInt, - Parser.GetNextString]));} -{ raise Exception.Create('Fehler bei XML-RPC-Befehlsausführung'); - xmlrpcResponse: - if Assigned(CurCallback) then - CurCallback(Parser); - else - raise Exception.Create('Invalid response'); - end; - finally - Parser.Free; - if Assigned(OnEndRPC) then - OnEndRPC(Self); - end; -end; - -procedure TXMLRPCClient.StreamSent(Sender: TObject); -begin -// LocalEventLoop.Break; - Connection.Receive; -end; - -procedure TXMLRPCClient.DataAvailable(Sender: TObject); -begin - LocalEventLoop.Break; -end; -} -{$ENDIF NEVERTRUE} - -// XML-RPC Server - -procedure TXMLRPCServlet.DoPost(Req: THttpServletRequest; - Resp: THttpServletResponse); -var - Parser: TXMLRPCParser; - Writer: TXMLRPCWriter; - Path: TStringList; - LastDot, i: Integer; - s, PathStr: String; - AnswerStream: TStream; - ExecCall: Boolean; -begin - Parser := TXMLRPCParser.Create(Req.InputStream); - try - if Parser.GetPostType <> xmlrpcMethodCall then - exit; - - Resp.ContentType := 'text/xml'; - - Writer := TXMLRPCWriter.Create; - try - try - // ...Header auswerten und zum Dispatcher springen... - PathStr := Parser.GetMethodName + '.'; - Path := TStringList.Create; - try - LastDot := 1; - for i := 1 to Length(PathStr) do - if PathStr[i] = '.' then - begin - Path.Add(UpperCase(Copy(PathStr, LastDot, i - LastDot))); - LastDot := i + 1; - end; - ExecCall := True; - if Assigned(OnCheckCall) then - OnCheckCall(Parser, Path, ExecCall); - if ExecCall then - Dispatch(Parser, Writer, Path) - else - Writer.WriteFaultResponse(2, 'May not execute request'); - finally - Path.Free; - end; - except - on e: Exception do - begin - if Assigned(OnException) then - OnException(e); - Writer.WriteFaultResponse(2, - 'Execution error: ' + e.ClassName + ': ' + e.Message); - end; - end; - - AnswerStream := Writer.MakeStream; - try - Resp.ContentLength := AnswerStream.Size; - Resp.OutputStream.CopyFrom(AnswerStream, AnswerStream.Size); - finally - AnswerStream.Free; - end; - finally - Writer.Free; - end; - finally - Parser.Free; - end; -end; - - -end. |
