summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormichael <michael@3ad0048d-3df7-0310-abae-a5850022a9f2>2010-05-30 14:14:18 +0000
committermichael <michael@3ad0048d-3df7-0310-abae-a5850022a9f2>2010-05-30 14:14:18 +0000
commitc7ee013c37a34146d51cefd47c8262ecc25603ef (patch)
treec6d19f971ee0a7c2043785bfbad656643c077e07
parentf1db4ecbec0a3f5f075c6aaea4f85ab5e943fd0f (diff)
downloadfpc-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.pp488
-rw-r--r--packages/fcl-net/src/httpclient.pp307
-rw-r--r--packages/fcl-net/src/mkxmlrpc.pp871
-rw-r--r--packages/fcl-net/src/servlets.pp114
-rw-r--r--packages/fcl-net/src/xmlrpc.pp941
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.