paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-17 00:19:19 +02:00
Code Issues Packages Projects Releases Wiki Activity

* update lNet so latest fpc can compile it (property changes)

Browse Source 
git-svn-id: trunk@7323 -
This commit is contained in:
Almindor 2007-05-13 09:04:46 +00:00
parent 73d861e3e9
commit 5736142382
4 changed files with 116 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
utils/fppkg/lnet/levents.pp
View File

@ -46,9 +46,7 @@ type
TLHandleEvent = procedure (aHandle: TLHandle) of object; TLHandleEvent = procedure (aHandle: TLHandle) of object;
TLHandleErrorEvent = procedure (aHandle: TLHandle; const msg: string) of object; TLHandleErrorEvent = procedure (aHandle: TLHandle; const msg: string) of object;
TLEventerErrorCallback = procedure (const msg: string; Sender: TLEventer) of object; TLEventerErrorEvent = procedure (const msg: string; Sender: TLEventer) of object;
TArrayP = array of Pointer;
{ TLHandle } { TLHandle }
@ -67,12 +65,12 @@ type
FPrev: TLHandle; FPrev: TLHandle;
FNext: TLHandle; FNext: TLHandle;
FFreeNext: TLHandle; FFreeNext: TLHandle;
FUserData: Pointer;
FInternalData: Pointer; FInternalData: Pointer;
procedure SetIgnoreError(const aValue: Boolean); procedure SetIgnoreError(const aValue: Boolean);
procedure SetIgnoreWrite(const aValue: Boolean); procedure SetIgnoreWrite(const aValue: Boolean);
procedure SetIgnoreRead(const aValue: Boolean); procedure SetIgnoreRead(const aValue: Boolean);
public public
UserData: Pointer;
constructor Create; virtual; constructor Create; virtual;
destructor Destroy; override; destructor Destroy; override;
procedure Free; virtual; // this is a trick procedure Free; virtual; // this is a trick
@ -85,7 +83,6 @@ type
property OnRead: TLHandleEvent read FOnRead write FOnRead; property OnRead: TLHandleEvent read FOnRead write FOnRead;
property OnWrite: TLHandleEvent read FOnWrite write FOnWrite; property OnWrite: TLHandleEvent read FOnWrite write FOnWrite;
property OnError: TLHandleErrorEvent read FOnError write FOnError; property OnError: TLHandleErrorEvent read FOnError write FOnError;
property UserData: Pointer read FUserData write FUserData;
property Dispose: Boolean read FDispose write FDispose; property Dispose: Boolean read FDispose write FDispose;
property Handle: THandle read FHandle write FHandle; property Handle: THandle read FHandle write FHandle;
property Eventer: TLEventer read FEventer; property Eventer: TLEventer read FEventer;
@ -138,7 +135,7 @@ type
protected protected
FRoot: TLHandle; FRoot: TLHandle;
FCount: Integer; FCount: Integer;
FOnError: TLEventerErrorCallback; FOnError: TLEventerErrorEvent;
FReferences: Integer; FReferences: Integer;
FFreeRoot: TLHandle; // the root of "free" list if any FFreeRoot: TLHandle; // the root of "free" list if any
FFreeIter: TLHandle; // the last of "free" list if any FFreeIter: TLHandle; // the last of "free" list if any
@ -166,7 +163,7 @@ type
procedure AddRef; procedure AddRef;
procedure DeleteRef; procedure DeleteRef;
property Timeout: DWord read GetTimeout write SetTimeout; property Timeout: DWord read GetTimeout write SetTimeout;
property OnError: TLEventerErrorCallback read FOnError write FOnError; property OnError: TLEventerErrorEvent read FOnError write FOnError;
property Count: Integer read FCount; property Count: Integer read FCount;
end; end;
TLEventerClass = class of TLEventer; TLEventerClass = class of TLEventer;
@ -231,7 +228,7 @@ begin
FOnRead := nil; FOnRead := nil;
FOnWrite := nil; FOnWrite := nil;
FOnError := nil; FOnError := nil;
FUserData := nil; UserData := nil;
FEventer := nil; FEventer := nil;
FPrev := nil; FPrev := nil;
FNext := nil; FNext := nil;

37
utils/fppkg/lnet/lhttp.pp
View File

@ -33,6 +33,7 @@ uses
type type
TLHTTPMethod = (hmHead, hmGet, hmPost, hmUnknown); TLHTTPMethod = (hmHead, hmGet, hmPost, hmUnknown);
TLHTTPMethods = set of TLHTTPMethod;
TLHTTPParameter = (hpConnection, hpContentLength, hpContentType, TLHTTPParameter = (hpConnection, hpContentLength, hpContentType,
hpAccept, hpAcceptCharset, hpAcceptEncoding, hpAcceptLanguage, hpHost, hpAccept, hpAcceptCharset, hpAcceptEncoding, hpAcceptLanguage, hpHost,
hpFrom, hpReferer, hpUserAgent, hpRange, hpTransferEncoding, hpFrom, hpReferer, hpUserAgent, hpRange, hpTransferEncoding,
@ -338,9 +339,6 @@ type
TLHTTPServerSocket = class(TLHTTPSocket) TLHTTPServerSocket = class(TLHTTPSocket)
protected protected
FLogMessage: TStringBuffer; FLogMessage: TStringBuffer;
FRequestInfo: TRequestInfo;
FResponseInfo: TResponseInfo;
FHeaderOut: THeaderOutInfo;
FSetupEncodingState: TSetupEncodingState; FSetupEncodingState: TSetupEncodingState;
procedure AddContentLength(ALength: integer); override; procedure AddContentLength(ALength: integer); override;
@ -358,24 +356,29 @@ type
procedure WriteError(AStatus: TLHTTPStatus); override; procedure WriteError(AStatus: TLHTTPStatus); override;
procedure WriteHeaders(AHeaderResponse, ADataResponse: TOutputItem); procedure WriteHeaders(AHeaderResponse, ADataResponse: TOutputItem);
public public
FHeaderOut: THeaderOutInfo;
FRequestInfo: TRequestInfo;
FResponseInfo: TResponseInfo;
constructor Create; override; constructor Create; override;
destructor Destroy; override; destructor Destroy; override;
function SetupEncoding(AOutputItem: TBufferOutput): boolean; function SetupEncoding(AOutputItem: TBufferOutput): boolean;
procedure StartMemoryResponse(AOutputItem: TMemoryOutput; ACustomErrorMessage: boolean = false); procedure StartMemoryResponse(AOutputItem: TMemoryOutput; ACustomErrorMessage: boolean = false);
procedure StartResponse(AOutputItem: TBufferOutput; ACustomErrorMessage: boolean = false); procedure StartResponse(AOutputItem: TBufferOutput; ACustomErrorMessage: boolean = false);
property HeaderOut: THeaderOutInfo read FHeaderOut;
property RequestInfo: TRequestInfo read FRequestInfo;
property ResponseInfo: TResponseInfo read FResponseInfo;
end; end;
TURIHandler = class(TObject) TURIHandler = class(TObject)
private private
FNext: TURIHandler; FNext: TURIHandler;
FMethods: TLHTTPMethods;
protected protected
function HandleURI(ASocket: TLHTTPServerSocket): TOutputItem; virtual; abstract; function HandleURI(ASocket: TLHTTPServerSocket): TOutputItem; virtual; abstract;
procedure RegisterWithEventer(AEventer: TLEventer); virtual; procedure RegisterWithEventer(AEventer: TLEventer); virtual;
public
constructor Create;
property Methods: TLHTTPMethods read FMethods write FMethods;
end; end;
TLAccessEvent = procedure(AMessage: string) of object; TLAccessEvent = procedure(AMessage: string) of object;
@ -558,6 +561,11 @@ end;
{ TURIHandler } { TURIHandler }
constructor TURIHandler.Create;
begin
FMethods := [hmHead, hmGet, hmPost];
end;
procedure TURIHandler.RegisterWithEventer(AEventer: TLEventer); procedure TURIHandler.RegisterWithEventer(AEventer: TLEventer);
begin begin
end; end;
@ -1594,14 +1602,8 @@ begin
lPos^ := #0; lPos^ := #0;
for I := Low(TLHTTPMethod) to High(TLHTTPMethod) do for I := Low(TLHTTPMethod) to High(TLHTTPMethod) do
begin begin
if I = hmUnknown then if (I = hmUnknown) or (((lPos-FBufferPos) = Length(HTTPMethodStrings[I]))
begin and CompareMem(FBufferPos, PChar(HTTPMethodStrings[I]), lPos-FBufferPos)) then
WriteError(hsNotImplemented);
exit;
end;
if ((lPos-FBufferPos) = Length(HTTPMethodStrings[I]))
and CompareMem(FBufferPos, PChar(HTTPMethodStrings[I]), lPos-FBufferPos) then
begin begin
repeat repeat
inc(lPos); inc(lPos);
@ -1912,10 +1914,13 @@ begin
Result := nil; Result := nil;
lHandler := FHandlerList; lHandler := FHandlerList;
while lHandler <> nil do while lHandler <> nil do
begin
if ASocket.FRequestInfo.RequestType in lHandler.Methods then
begin begin
Result := lHandler.HandleURI(ASocket); Result := lHandler.HandleURI(ASocket);
if ASocket.ResponseInfo.Status <> hsOK then break; if ASocket.FResponseInfo.Status <> hsOK then break;
if Result <> nil then break; if Result <> nil then break;
end;
lHandler := lHandler.FNext; lHandler := lHandler.FNext;
end; end;
end; end;

63
utils/fppkg/lnet/lnet.pp
View File

@ -93,8 +93,6 @@ type
FPeerAddress: TInetSockAddr; FPeerAddress: TInetSockAddr;
FConnected: Boolean; FConnected: Boolean;
FConnecting: Boolean; FConnecting: Boolean;
FSocketClass: Integer;
FProtocol: Integer;
FNextSock: TLSocket; FNextSock: TLSocket;
FPrevSock: TLSocket; FPrevSock: TLSocket;
FIgnoreShutdown: Boolean; FIgnoreShutdown: Boolean;
@ -104,6 +102,8 @@ type
FOnFree: TLSocketEvent; FOnFree: TLSocketEvent;
FBlocking: Boolean; FBlocking: Boolean;
FListenBacklog: Integer; FListenBacklog: Integer;
FProtocol: Integer;
FSocketType: Integer;
FCreator: TLComponent; FCreator: TLComponent;
protected protected
function DoSend(const TheData; const TheSize: Integer): Integer; function DoSend(const TheData; const TheSize: Integer): Integer;
@ -142,10 +142,10 @@ type
public public
property Connected: Boolean read FConnected; property Connected: Boolean read FConnected;
property Connecting: Boolean read FConnecting; property Connecting: Boolean read FConnecting;
property Blocking: Boolean read FBlocking write SetBlocking;
property ListenBacklog: Integer read FListenBacklog write FListenBacklog; property ListenBacklog: Integer read FListenBacklog write FListenBacklog;
property Protocol: Integer read FProtocol write FProtocol; property Protocol: Integer read FProtocol write FProtocol;
property SocketType: Integer read FSocketClass write FSocketClass; property SocketType: Integer read FSocketType write FSocketType;
property Blocking: Boolean read FBlocking write SetBlocking;
property PeerAddress: string read GetPeerAddress; property PeerAddress: string read GetPeerAddress;
property PeerPort: Word read GetPeerPort; property PeerPort: Word read GetPeerPort;
property LocalAddress: string read GetLocalAddress; property LocalAddress: string read GetLocalAddress;
@ -200,14 +200,13 @@ type
protected protected
FHost: string; FHost: string;
FPort: Word; FPort: Word;
FSocketClass: TLSocketClass;
FCreator: TLComponent; FCreator: TLComponent;
public public
constructor Create(aOwner: TComponent); override; constructor Create(aOwner: TComponent); override;
procedure Disconnect; virtual; abstract; procedure Disconnect; virtual; abstract;
procedure CallAction; virtual; abstract; procedure CallAction; virtual; abstract;
public
property SocketClass: TLSocketClass read FSocketClass write FSocketClass; SocketClass: TLSocketClass;
property Host: string read FHost write FHost; property Host: string read FHost write FHost;
property Port: Word read FPort write FPort; property Port: Word read FPort write FPort;
property Creator: TLComponent read FCreator write FCreator; property Creator: TLComponent read FCreator write FCreator;
@ -281,8 +280,6 @@ type
function IterNext: Boolean; virtual; abstract; function IterNext: Boolean; virtual; abstract;
procedure IterReset; virtual; abstract; procedure IterReset; virtual; abstract;
public public
property Host: string read FHost write FHost;
property Port: Word read FPort write FPort;
property OnError: TLSocketErrorEvent read FOnError write FOnError; property OnError: TLSocketErrorEvent read FOnError write FOnError;
property OnReceive: TLSocketEvent read FOnReceive write FOnReceive; property OnReceive: TLSocketEvent read FOnReceive write FOnReceive;
property OnDisconnect: TLSocketEvent read FOnDisconnect write FOnDisconnect; property OnDisconnect: TLSocketEvent read FOnDisconnect write FOnDisconnect;
@ -293,7 +290,6 @@ type
property ListenBacklog: Integer read FListenBacklog write FListenBacklog; property ListenBacklog: Integer read FListenBacklog write FListenBacklog;
property Iterator: TLSocket read FIterator; property Iterator: TLSocket read FIterator;
property Timeout: DWord read GetTimeout write SetTimeout; property Timeout: DWord read GetTimeout write SetTimeout;
property SocketClass: TLSocketClass read FSocketClass write FSocketClass;
property Eventer: TLEventer read FEventer write SetEventer; property Eventer: TLEventer read FEventer write SetEventer;
property EventerClass: TLEventerClass read FEventerClass write FEventerClass; property EventerClass: TLEventerClass read FEventerClass write FEventerClass;
end; end;
@ -404,7 +400,7 @@ begin
FConnected := False; FConnected := False;
FConnecting := False; FConnecting := False;
FIgnoreShutdown := False; FIgnoreShutdown := False;
FSocketClass := SOCK_STREAM; FSocketType := SOCK_STREAM;
FProtocol := LPROTO_TCP; FProtocol := LPROTO_TCP;
end; end;
@ -428,8 +424,8 @@ begin
if FConnected or FConnecting then begin if FConnected or FConnecting then begin
FConnected := False; FConnected := False;
FConnecting := False; FConnecting := False;
if (FSocketClass = SOCK_STREAM) and (not FIgnoreShutdown) and WasConnected then if (FSocketType = SOCK_STREAM) and (not FIgnoreShutdown) and WasConnected then
if ShutDown(FHandle, 2) <> 0 then if fpShutDown(FHandle, 2) <> 0 then
LogError('Shutdown error', LSocketError); LogError('Shutdown error', LSocketError);
if CloseSocket(FHandle) <> 0 then if CloseSocket(FHandle) <> 0 then
LogError('Closesocket error', LSocketError); LogError('Closesocket error', LSocketError);
@ -457,7 +453,7 @@ end;
function TLSocket.GetPeerAddress: string; function TLSocket.GetPeerAddress: string;
begin begin
Result := ''; Result := '';
if FSocketClass = SOCK_STREAM then if FSocketType = SOCK_STREAM then
Result := NetAddrtoStr(FAddress.Addr) Result := NetAddrtoStr(FAddress.Addr)
else else
Result := NetAddrtoStr(FPeerAddress.Addr); Result := NetAddrtoStr(FPeerAddress.Addr);
@ -469,7 +465,7 @@ var
l: Integer; l: Integer;
begin begin
l := SizeOf(a); l := SizeOf(a);
GetSocketName(FHandle, a, l); fpGetSockName(FHandle, @a, @l);
Result := HostAddrToStr(LongWord(a.sin_addr)); Result := HostAddrToStr(LongWord(a.sin_addr));
end; end;
@ -510,10 +506,10 @@ var
begin begin
Result := 0; Result := 0;
if CanReceive then begin if CanReceive then begin
if FSocketClass = SOCK_STREAM then if FSocketType = SOCK_STREAM then
Result := sockets.Recv(FHandle, aData, aSize, LMSG) Result := sockets.fpRecv(FHandle, @aData, aSize, LMSG)
else else
Result := sockets.Recvfrom(FHandle, aData, aSize, LMSG, FPeerAddress, AddressLength); Result := sockets.fpRecvfrom(FHandle, @aData, aSize, LMSG, @FPeerAddress, @AddressLength);
if Result = 0 then if Result = 0 then
Disconnect; Disconnect;
if Result = SOCKET_ERROR then begin if Result = SOCKET_ERROR then begin
@ -527,11 +523,14 @@ begin
end; end;
function TLSocket.DoSend(const TheData; const TheSize: Integer): Integer; function TLSocket.DoSend(const TheData; const TheSize: Integer): Integer;
var
AddressLength: Integer;
begin begin
if FSocketClass = SOCK_STREAM then AddressLength := SizeOf(FPeerAddress);
Result := sockets.send(FHandle, TheData, TheSize, LMSG) if FSocketType = SOCK_STREAM then
Result := sockets.fpsend(FHandle, @TheData, TheSize, LMSG)
else else
Result := sockets.sendto(FHandle, TheData, TheSize, LMSG, FPeerAddress, SizeOf(FPeerAddress)); Result := sockets.fpsendto(FHandle, @TheData, TheSize, LMSG, @FPeerAddress, AddressLength);
end; end;
function TLSocket.SetupSocket(const APort: Word; const Address: string): Boolean; function TLSocket.SetupSocket(const APort: Word; const Address: string): Boolean;
@ -542,13 +541,13 @@ begin
Result := false; Result := false;
if not FConnected and not FConnecting then begin if not FConnected and not FConnecting then begin
Done := true; Done := true;
FHandle := fpSocket(AF_INET, FSocketClass, FProtocol); FHandle := fpSocket(AF_INET, FSocketType, FProtocol);
if FHandle = INVALID_SOCKET then if FHandle = INVALID_SOCKET then
Bail('Socket error', LSocketError); Bail('Socket error', LSocketError);
SetOptions; SetOptions;
if FSocketClass = SOCK_DGRAM then begin if FSocketType = SOCK_DGRAM then begin
Arg := 1; Arg := 1;
if SetSocketOptions(FHandle, SOL_SOCKET, SO_BROADCAST, Arg, Sizeof(Arg)) = SOCKET_ERROR then if fpsetsockopt(FHandle, SOL_SOCKET, SO_BROADCAST, @Arg, Sizeof(Arg)) = SOCKET_ERROR then
Bail('SetSockOpt error', LSocketError); Bail('SetSockOpt error', LSocketError);
end; end;
@ -579,7 +578,7 @@ begin
Bail('Error on bind', LSocketError) Bail('Error on bind', LSocketError)
else else
Result := true; Result := true;
if (FSocketClass = SOCK_STREAM) and Result then if (FSocketType = SOCK_STREAM) and Result then
if fpListen(FHandle, FListenBacklog) = SOCKET_ERROR then if fpListen(FHandle, FListenBacklog) = SOCKET_ERROR then
Result := Bail('Error on Listen', LSocketError) Result := Bail('Error on Listen', LSocketError)
else else
@ -650,7 +649,7 @@ begin
FPort := 0; FPort := 0;
FListenBacklog := LDEFAULT_BACKLOG; FListenBacklog := LDEFAULT_BACKLOG;
FTimeout := 0; FTimeout := 0;
FSocketClass := TLSocket; SocketClass := TLSocket;
FOnReceive := nil; FOnReceive := nil;
FOnError := nil; FOnError := nil;
FOnDisconnect := nil; FOnDisconnect := nil;
@ -857,7 +856,7 @@ begin
if Assigned(FRootSock) and FRootSock.Connected then if Assigned(FRootSock) and FRootSock.Connected then
Disconnect; Disconnect;
FRootSock := InitSocket(FSocketClass.Create); FRootSock := InitSocket(SocketClass.Create);
FIterator := FRootSock; FIterator := FRootSock;
Result := FRootSock.SetupSocket(APort, LADDR_ANY); Result := FRootSock.SetupSocket(APort, LADDR_ANY);
@ -876,7 +875,7 @@ begin
if Assigned(FRootSock) and FRootSock.Connected then if Assigned(FRootSock) and FRootSock.Connected then
Disconnect; Disconnect;
FRootSock := InitSocket(FSocketClass.Create); FRootSock := InitSocket(SocketClass.Create);
FIterator := FRootSock; FIterator := FRootSock;
if FRootSock.Listen(APort, AIntf) then begin if FRootSock.Listen(APort, AIntf) then begin
@ -1031,7 +1030,7 @@ begin
if Assigned(FRootSock) then if Assigned(FRootSock) then
Disconnect; Disconnect;
FRootSock := InitSocket(FSocketClass.Create); FRootSock := InitSocket(SocketClass.Create);
Result := FRootSock.Connect(Address, aPort); Result := FRootSock.Connect(Address, aPort);
if Result then begin if Result then begin
@ -1051,7 +1050,7 @@ begin
if Assigned(FRootSock) then if Assigned(FRootSock) then
Disconnect; Disconnect;
FRootSock := InitSocket(FSocketClass.Create); FRootSock := InitSocket(SocketClass.Create);
FRootSock.FIgnoreShutdown := True; FRootSock.FIgnoreShutdown := True;
if FRootSock.Listen(APort, AIntf) then begin if FRootSock.Listen(APort, AIntf) then begin
FRootSock.FConnected := True; FRootSock.FConnected := True;
@ -1139,7 +1138,7 @@ var
begin begin
with TLSocket(aSocket) do begin with TLSocket(aSocket) do begin
l := SizeOf(a); l := SizeOf(a);
if Sockets.GetPeerName(FHandle, a, l) <> 0 then if Sockets.fpGetPeerName(FHandle, @a, @l) <> 0 then
Self.Bail('Error on connect: connection refused', TLSocket(aSocket)) Self.Bail('Error on connect: connection refused', TLSocket(aSocket))
else begin else begin
FConnected := True; FConnected := True;
@ -1153,7 +1152,7 @@ procedure TLTcp.AcceptAction(aSocket: TLHandle);
var var
Tmp: TLSocket; Tmp: TLSocket;
begin begin
Tmp := InitSocket(FSocketClass.Create); Tmp := InitSocket(SocketClass.Create);
if Tmp.Accept(FRootSock.FHandle) then begin if Tmp.Accept(FRootSock.FHandle) then begin
if Assigned(FRootSock.FNextSock) then begin if Assigned(FRootSock.FNextSock) then begin
Tmp.FNextSock := FRootSock.FNextSock; Tmp.FNextSock := FRootSock.FNextSock;

123
utils/fppkg/lnet/lwebserver.pp
View File

@ -70,11 +70,6 @@ type
FParsePos: pchar; FParsePos: pchar;
FReadPos: integer; FReadPos: integer;
FParsingHeaders: boolean; FParsingHeaders: boolean;
FDocumentRoot: string;
FExtraPath: string;
FEnvPath: string;
FScriptFileName: string;
FScriptName: string;
procedure AddEnvironment(const AName, AValue: string); virtual; abstract; procedure AddEnvironment(const AName, AValue: string); virtual; abstract;
procedure AddHTTPParam(const AName: string; AParam: TLHTTPParameter); procedure AddHTTPParam(const AName: string; AParam: TLHTTPParameter);
@ -83,17 +78,17 @@ type
procedure WriteCGIBlock; procedure WriteCGIBlock;
function WriteCGIData: TWriteBlockStatus; virtual; abstract; function WriteCGIData: TWriteBlockStatus; virtual; abstract;
public public
FDocumentRoot: string;
FExtraPath: string;
FEnvPath: string;
FScriptFileName: string;
FScriptName: string;
constructor Create(ASocket: TLHTTPSocket); constructor Create(ASocket: TLHTTPSocket);
destructor Destroy; override; destructor Destroy; override;
function FillBuffer: TWriteBlockStatus; override; function FillBuffer: TWriteBlockStatus; override;
procedure StartRequest; virtual; procedure StartRequest; virtual;
property DocumentRoot: string read FDocumentRoot write FDocumentRoot;
property EnvPath: string read FEnvPath write FEnvPath;
property ExtraPath: string read FExtraPath write FExtraPath;
property ScriptFileName: string read FScriptFileName write FScriptFileName;
property ScriptName: string read FScriptName write FScriptName;
end; end;
TSimpleCGIOutput = class(TCGIOutput) TSimpleCGIOutput = class(TCGIOutput)
@ -142,17 +137,12 @@ type
TCGIHandler = class(TURIHandler) TCGIHandler = class(TURIHandler)
protected protected
FScriptPathPrefix: string;
FCGIRoot: string;
FDocumentRoot: string;
FEnvPath: string;
function HandleURI(ASocket: TLHTTPServerSocket): TOutputItem; override; function HandleURI(ASocket: TLHTTPServerSocket): TOutputItem; override;
public public
property CGIRoot: string read FCGIRoot write FCGIRoot; FCGIRoot: string;
property DocumentRoot: string read FDocumentRoot write FDocumentRoot; FEnvPath: string;
property EnvPath: string read FEnvPath write FEnvPath; FDocumentRoot: string;
property ScriptPathPrefix: string read FScriptPathPrefix write FScriptPathPrefix; FScriptPathPrefix: string;
end; end;
TDocumentRequest = record TDocumentRequest = record
@ -183,8 +173,6 @@ type
protected protected
FDocHandlerList: TDocumentHandler; FDocHandlerList: TDocumentHandler;
FDirIndexList: TStrings; FDirIndexList: TStrings;
protected
FDocumentRoot: string;
FMimeTypeFile: string; FMimeTypeFile: string;
procedure SetMimeTypeFile(const AValue: string); procedure SetMimeTypeFile(const AValue: string);
@ -192,13 +180,14 @@ type
function HandleURI(ASocket: TLHTTPServerSocket): TOutputItem; override; function HandleURI(ASocket: TLHTTPServerSocket): TOutputItem; override;
procedure RegisterWithEventer(AEventer: TLEventer); override; procedure RegisterWithEventer(AEventer: TLEventer); override;
public public
DocumentRoot: string;
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
procedure RegisterHandler(AHandler: TDocumentHandler); procedure RegisterHandler(AHandler: TDocumentHandler);
property DirIndexList: TStrings read FDirIndexList; property DirIndexList: TStrings read FDirIndexList;
property DocumentRoot: string read FDocumentRoot write FDocumentRoot;
property MimeTypeFile: string read FMimeTypeFile write SetMimeTypeFile; property MimeTypeFile: string read FMimeTypeFile write SetMimeTypeFile;
end; end;
@ -321,25 +310,25 @@ var
lOutput: TSimpleCGIOutput; lOutput: TSimpleCGIOutput;
lExecPath: string; lExecPath: string;
begin begin
if StrLComp(ASocket.RequestInfo.Argument, PChar(ScriptPathPrefix), if StrLComp(ASocket.FRequestInfo.Argument, PChar(FScriptPathPrefix),
Length(ScriptPathPrefix)) = 0 then Length(FScriptPathPrefix)) = 0 then
begin begin
lOutput := TSimpleCGIOutput.Create(ASocket); lOutput := TSimpleCGIOutput.Create(ASocket);
lOutput.DocumentRoot := FDocumentRoot; lOutput.FDocumentRoot := FDocumentRoot;
lOutput.EnvPath := FEnvPath; lOutput.FEnvPath := FEnvPath;
lOutput.Process.CurrentDirectory := FCGIRoot; lOutput.Process.CurrentDirectory := FCGIRoot;
lExecPath := (ASocket.RequestInfo.Argument+Length(ScriptPathPrefix)); lExecPath := ASocket.FRequestInfo.Argument+Length(FScriptPathPrefix);
DoDirSeparators(lExecPath); DoDirSeparators(lExecPath);
lExecPath := FCGIRoot+lExecPath; lExecPath := FCGIRoot+lExecPath;
if SeparatePath(lExecPath, lOutput.ExtraPath, faAnyFile and not faDirectory) then if SeparatePath(lExecPath, lOutput.FExtraPath, faAnyFile and not faDirectory) then
begin begin
lOutput.Process.CommandLine := lExecPath; lOutput.Process.CommandLine := lExecPath;
lOutput.ScriptFileName := lExecPath; lOutput.FScriptFileName := lExecPath;
lOutput.ScriptName := Copy(lExecPath, Length(FCGIRoot), lOutput.FScriptName := Copy(lExecPath, Length(FCGIRoot),
Length(lExecPath)-Length(FCGIRoot)+1); Length(lExecPath)-Length(FCGIRoot)+1);
lOutput.StartRequest; lOutput.StartRequest;
end else end else
ASocket.ResponseInfo.Status := hsNotFound; ASocket.FResponseInfo.Status := hsNotFound;
Result := lOutput; Result := lOutput;
end else end else
Result := nil; Result := nil;
@ -388,9 +377,9 @@ begin
Result := nil; Result := nil;
if ARequest.InfoValid then if ARequest.InfoValid then
begin begin
lReqInfo := @ARequest.Socket.RequestInfo; lReqInfo := @ARequest.Socket.FRequestInfo;
lRespInfo := @ARequest.Socket.ResponseInfo; lRespInfo := @ARequest.Socket.FResponseInfo;
lHeaderOut := @ARequest.Socket.HeaderOut; lHeaderOut := @ARequest.Socket.FHeaderOut;
if not (lReqInfo^.RequestType in [hmHead, hmGet]) then if not (lReqInfo^.RequestType in [hmHead, hmGet]) then
begin begin
lRespInfo^.Status := hsNotAllowed; lRespInfo^.Status := hsNotAllowed;
@ -422,10 +411,11 @@ var
begin begin
Result := nil; Result := nil;
lDocRequest.Socket := ASocket; lDocRequest.Socket := ASocket;
lDocRequest.URIPath := ASocket.RequestInfo.Argument; lDocRequest.URIPath := ASocket.FRequestInfo.Argument;
lDocRequest.Document := lDocRequest.URIPath; lDocRequest.Document := lDocRequest.URIPath;
DoDirSeparators(LDocRequest.Document); DoDirSeparators(LDocRequest.Document);
lDocRequest.Document := IncludeTrailingPathDelimiter(FDocumentRoot)+lDocRequest.Document; lDocRequest.Document := IncludeTrailingPathDelimiter(DocumentRoot)
+ lDocRequest.Document;
lDocRequest.InfoValid := SeparatePath(lDocRequest.Document,lDocRequest.ExtraPath, lDocRequest.InfoValid := SeparatePath(lDocRequest.Document,lDocRequest.ExtraPath,
faAnyFile, @lDocRequest.Info); faAnyFile, @lDocRequest.Info);
if not lDocRequest.InfoValid then if not lDocRequest.InfoValid then
@ -461,7 +451,7 @@ begin
begin begin
Result := lHandler.HandleDocument(lDocRequest); Result := lHandler.HandleDocument(lDocRequest);
if Result <> nil then exit; if Result <> nil then exit;
if ASocket.ResponseInfo.Status <> hsOK then exit; if ASocket.FResponseInfo.Status <> hsOK then exit;
lHandler := lHandler.FNext; lHandler := lHandler.FNext;
end; end;
@ -484,12 +474,12 @@ begin
if ExtractFileExt(ARequest.Document) = '.php' then if ExtractFileExt(ARequest.Document) = '.php' then
begin begin
lOutput := TSimpleCGIOutput.Create(ARequest.Socket); lOutput := TSimpleCGIOutput.Create(ARequest.Socket);
lOutput.DocumentRoot := FFileHandler.DocumentRoot; lOutput.FDocumentRoot := FFileHandler.DocumentRoot;
lOutput.Process.CommandLine := FAppName; lOutput.Process.CommandLine := FAppName;
lOutput.ScriptName := ARequest.URIPath; lOutput.FScriptName := ARequest.URIPath;
lOutput.ScriptFileName := ARequest.Document; lOutput.FScriptFileName := ARequest.Document;
lOutput.ExtraPath := ARequest.ExtraPath; lOutput.FExtraPath := ARequest.ExtraPath;
lOutput.EnvPath := FEnvPath; lOutput.FEnvPath := FEnvPath;
lOutput.StartRequest; lOutput.StartRequest;
Result := lOutput; Result := lOutput;
end else end else
@ -564,17 +554,17 @@ begin
if fcgiRequest <> nil then if fcgiRequest <> nil then
begin begin
lOutput := TFastCGIOutput.Create(ARequest.Socket); lOutput := TFastCGIOutput.Create(ARequest.Socket);
lOutput.DocumentRoot := FFileHandler.DocumentRoot; lOutput.FDocumentRoot := FFileHandler.DocumentRoot;
lOutput.ScriptName := ARequest.URIPath; lOutput.FScriptName := ARequest.URIPath;
lOutput.ScriptFileName := ARequest.Document; lOutput.FScriptFileName := ARequest.Document;
lOutput.ExtraPath := ARequest.ExtraPath; lOutput.FExtraPath := ARequest.ExtraPath;
lOutput.EnvPath := FEnvPath; lOutput.FEnvPath := FEnvPath;
lOutput.Request := fcgiRequest; lOutput.Request := fcgiRequest;
ARequest.Socket.SetupEncoding(lOutput); ARequest.Socket.SetupEncoding(lOutput);
lOutput.StartRequest; lOutput.StartRequest;
Result := lOutput; Result := lOutput;
end else begin end else begin
ARequest.Socket.ResponseInfo.Status := hsInternalError; ARequest.Socket.FResponseInfo.Status := hsInternalError;
ARequest.Socket.StartResponse(nil); ARequest.Socket.StartResponse(nil);
Result := nil; Result := nil;
end; end;
@ -666,21 +656,21 @@ begin
AddEnvironment('SERVER_SOFTWARE', tempStr); AddEnvironment('SERVER_SOFTWARE', tempStr);
AddEnvironment('GATEWAY_INTERFACE', 'CGI/1.1'); AddEnvironment('GATEWAY_INTERFACE', 'CGI/1.1');
AddEnvironment('SERVER_PROTOCOL', lServerSocket.RequestInfo.VersionStr); AddEnvironment('SERVER_PROTOCOL', lServerSocket.FRequestInfo.VersionStr);
AddEnvironment('REQUEST_METHOD', lServerSocket.RequestInfo.Method); AddEnvironment('REQUEST_METHOD', lServerSocket.FRequestInfo.Method);
AddEnvironment('REQUEST_URI', '/'+lServerSocket.RequestInfo.Argument); AddEnvironment('REQUEST_URI', '/'+lServerSocket.FRequestInfo.Argument);
if Length(FExtraPath) > 0 then if Length(FExtraPath) > 0 then
begin begin
AddEnvironment('PATH_INFO', FExtraPath); AddEnvironment('PATH_INFO', FExtraPath);
{ do not set PATH_TRANSLATED: bug in PHP } { do not set PATH_TRANSLATED: bug in PHP }
// AddEnvironment('PATH_TRANSLATED', FDocumentRoot+FExtraPath); // AddEnvironment('PATH_TRANSLATED', DocumentRoot+FExtraPath);
end; end;
AddEnvironment('SCRIPT_NAME', FScriptName); AddEnvironment('SCRIPT_NAME', FScriptName);
AddEnvironment('SCRIPT_FILENAME', FScriptFileName); AddEnvironment('SCRIPT_FILENAME', FScriptFileName);
AddEnvironment('QUERY_STRING', lServerSocket.RequestInfo.QueryParams); AddEnvironment('QUERY_STRING', lServerSocket.FRequestInfo.QueryParams);
AddHTTPParam('CONTENT_TYPE', hpContentType); AddHTTPParam('CONTENT_TYPE', hpContentType);
AddHTTPParam('CONTENT_LENGTH', hpContentLength); AddHTTPParam('CONTENT_LENGTH', hpContentLength);
@ -716,7 +706,8 @@ var
procedure AddExtraHeader; procedure AddExtraHeader;
begin begin
AppendString(lServerSocket.HeaderOut.ExtraHeaders, FParsePos + ': ' + pValue + #13#10); AppendString(lServerSocket.FHeaderOut.ExtraHeaders,
FParsePos + ': ' + pValue + #13#10);
end; end;
begin begin
@ -745,13 +736,13 @@ begin
pValue := FParsePos+iEnd+2; pValue := FParsePos+iEnd+2;
if StrIComp(FParsePos, 'Content-type') = 0 then if StrIComp(FParsePos, 'Content-type') = 0 then
begin begin
lServerSocket.ResponseInfo.ContentType := pValue; lServerSocket.FResponseInfo.ContentType := pValue;
end else end else
if StrIComp(FParsePos, 'Location') = 0 then if StrIComp(FParsePos, 'Location') = 0 then
begin begin
if StrLIComp(pValue, 'http://', 7) = 0 then if StrLIComp(pValue, 'http://', 7) = 0 then
begin begin
lServerSocket.ResponseInfo.Status := hsMovedPermanently; lServerSocket.FResponseInfo.Status := hsMovedPermanently;
{ add location header as-is to response } { add location header as-is to response }
AddExtraHeader; AddExtraHeader;
end else end else
@ -768,19 +759,19 @@ begin
break; break;
for lHttpStatus := Low(TLHTTPStatus) to High(TLHTTPStatus) do for lHttpStatus := Low(TLHTTPStatus) to High(TLHTTPStatus) do
if HTTPStatusCodes[lHttpStatus] = lStatus then if HTTPStatusCodes[lHttpStatus] = lStatus then
lServerSocket.ResponseInfo.Status := lHttpStatus; lServerSocket.FResponseInfo.Status := lHttpStatus;
end else end else
if StrIComp(FParsePos, 'Content-Length') = 0 then if StrIComp(FParsePos, 'Content-Length') = 0 then
begin begin
Val(pValue, lLength, lCode); Val(pValue, lLength, lCode);
if lCode <> 0 then if lCode <> 0 then
break; break;
lServerSocket.HeaderOut.ContentLength := lLength; lServerSocket.FHeaderOut.ContentLength := lLength;
end else end else
if StrIComp(FParsePos, 'Last-Modified') = 0 then if StrIComp(FParsePos, 'Last-Modified') = 0 then
begin begin
if not TryHTTPDateStrToDateTime(pValue, if not TryHTTPDateStrToDateTime(pValue,
lServerSocket.ResponseInfo.LastModified) then lServerSocket.FResponseInfo.LastModified) then
InternalWrite('WARNING: unable to parse last-modified string from CGI script: ' + pValue); InternalWrite('WARNING: unable to parse last-modified string from CGI script: ' + pValue);
end else end else
AddExtraHeader; AddExtraHeader;
@ -788,7 +779,7 @@ begin
until false; until false;
{ error happened } { error happened }
lServerSocket.ResponseInfo.Status := hsInternalError; lServerSocket.FResponseInfo.Status := hsInternalError;
exit(true); exit(true);
end; end;
@ -886,9 +877,9 @@ var
ServerSocket: TLHTTPServerSocket absolute FSocket; ServerSocket: TLHTTPServerSocket absolute FSocket;
begin begin
if FProcess.ExitStatus = 127 then if FProcess.ExitStatus = 127 then
ServerSocket.ResponseInfo.Status := hsNotFound ServerSocket.FResponseInfo.Status := hsNotFound
else else
ServerSocket.ResponseInfo.Status := hsInternalError; ServerSocket.FResponseInfo.Status := hsInternalError;
end; end;
procedure TSimpleCGIOutput.CGIProcNeedInput(AHandle: TLHandle); procedure TSimpleCGIOutput.CGIProcNeedInput(AHandle: TLHandle);
@ -939,7 +930,7 @@ end;
procedure TFastCGIOutput.CGIOutputError; procedure TFastCGIOutput.CGIOutputError;
begin begin
TLHTTPServerSocket(FSocket).ResponseInfo.Status := hsInternalError; TLHTTPServerSocket(FSocket).FResponseInfo.Status := hsInternalError;
end; end;
procedure TFastCGIOutput.DoneInput; procedure TFastCGIOutput.DoneInput;
@ -1201,7 +1192,7 @@ procedure TFormOutput.SetCookie(const AName, AValue: string; const AExpires: TDa
var var
headers: PStringBuffer; headers: PStringBuffer;
begin begin
headers := @TLHTTPServerSocket(FSocket).HeaderOut.ExtraHeaders; headers := @TLHTTPServerSocket(FSocket).FHeaderOut.ExtraHeaders;
AppendString(headers^, 'Set-Cookie: ' + HTTPEncode(AName) + '=' + HTTPEncode(AValue)); AppendString(headers^, 'Set-Cookie: ' + HTTPEncode(AName) + '=' + HTTPEncode(AValue));
AppendString(headers^, ';path=' + APath + ';expires=' + FormatDateTime(HTTPDateFormat, AExpires)); AppendString(headers^, ';path=' + APath + ';expires=' + FormatDateTime(HTTPDateFormat, AExpires));
if Length(ADomain) > 0 then if Length(ADomain) > 0 then
@ -1247,7 +1238,7 @@ begin
if newFormOutput = nil then if newFormOutput = nil then
exit(nil); exit(nil);
newFormOutput.AddVariables(ASocket.RequestInfo.QueryParams, -1, URIParamSepChar); newFormOutput.AddVariables(ASocket.FRequestInfo.QueryParams, -1, URIParamSepChar);
newFormOutput.AddVariables(ASocket.Parameters[hpCookie], -1, CookieSepChar); newFormOutput.AddVariables(ASocket.Parameters[hpCookie], -1, CookieSepChar);
contentType := TLHTTPServerSocket(ASocket).Parameters[hpContentType]; contentType := TLHTTPServerSocket(ASocket).Parameters[hpContentType];
if StrIComp(contentType, FormURLContentType) = 0 then if StrIComp(contentType, FormURLContentType) = 0 then