mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-10-27 10:31:41 +01:00
* re-add some somehow missed units, update to latest
git-svn-id: trunk@5857 -
This commit is contained in:
Almindor
parent
b6b9582d8e
commit
2ddc5fed76
10
.gitattributes
vendored
10
.gitattributes
vendored
@ -8136,18 +8136,26 @@ utils/fppkg/fppkg.pp svneol=native#text/plain
|
|||||||
utils/fppkg/fprepos.pp svneol=native#text/plain
|
utils/fppkg/fprepos.pp svneol=native#text/plain
|
||||||
utils/fppkg/fpxmlrep.pp svneol=native#text/plain
|
utils/fppkg/fpxmlrep.pp svneol=native#text/plain
|
||||||
utils/fppkg/lnet/LICENSE -text
|
utils/fppkg/lnet/LICENSE -text
|
||||||
|
utils/fppkg/lnet/LICENSE.ADDON -text
|
||||||
utils/fppkg/lnet/fastcgi.pp svneol=native#text/plain
|
utils/fppkg/lnet/fastcgi.pp svneol=native#text/plain
|
||||||
utils/fppkg/lnet/lcommon.pp svneol=native#text/plain
|
utils/fppkg/lnet/lcommon.pp svneol=native#text/plain
|
||||||
utils/fppkg/lnet/lcontainers.inc svneol=native#text/plain
|
utils/fppkg/lnet/lcontainers.inc svneol=native#text/plain
|
||||||
utils/fppkg/lnet/lcontainersh.inc svneol=native#text/plain
|
utils/fppkg/lnet/lcontainersh.inc svneol=native#text/plain
|
||||||
utils/fppkg/lnet/lcontrolstack.pp svneol=native#text/plain
|
utils/fppkg/lnet/lcontrolstack.pp svneol=native#text/plain
|
||||||
utils/fppkg/lnet/levents.pp svneol=native#text/plain
|
utils/fppkg/lnet/levents.pp svneol=native#text/plain
|
||||||
|
utils/fppkg/lnet/lfastcgi.pp svneol=native#text/plain
|
||||||
utils/fppkg/lnet/lftp.pp svneol=native#text/plain
|
utils/fppkg/lnet/lftp.pp svneol=native#text/plain
|
||||||
|
utils/fppkg/lnet/lhttp.pp svneol=native#text/plain
|
||||||
|
utils/fppkg/lnet/lhttputil.pp svneol=native#text/plain
|
||||||
|
utils/fppkg/lnet/lmimetypes.pp svneol=native#text/plain
|
||||||
utils/fppkg/lnet/lnet.pp svneol=native#text/plain
|
utils/fppkg/lnet/lnet.pp svneol=native#text/plain
|
||||||
|
utils/fppkg/lnet/lprocess.pp svneol=native#text/plain
|
||||||
|
utils/fppkg/lnet/lsmtp.pp svneol=native#text/plain
|
||||||
|
utils/fppkg/lnet/lspawnfcgi.pp svneol=native#text/plain
|
||||||
utils/fppkg/lnet/lstrbuffer.pp svneol=native#text/plain
|
utils/fppkg/lnet/lstrbuffer.pp svneol=native#text/plain
|
||||||
utils/fppkg/lnet/ltelnet.pp svneol=native#text/plain
|
utils/fppkg/lnet/ltelnet.pp svneol=native#text/plain
|
||||||
|
utils/fppkg/lnet/ltimer.pp svneol=native#text/plain
|
||||||
utils/fppkg/lnet/lwebserver.pp svneol=native#text/plain
|
utils/fppkg/lnet/lwebserver.pp svneol=native#text/plain
|
||||||
utils/fppkg/lnet/openssl.pp -text svneol=unset#text/plain
|
|
||||||
utils/fppkg/lnet/sys/lepolleventer.inc svneol=native#text/plain
|
utils/fppkg/lnet/sys/lepolleventer.inc svneol=native#text/plain
|
||||||
utils/fppkg/lnet/sys/lepolleventerh.inc svneol=native#text/plain
|
utils/fppkg/lnet/sys/lepolleventerh.inc svneol=native#text/plain
|
||||||
utils/fppkg/lnet/sys/lkqueueeventer.inc svneol=native#text/plain
|
utils/fppkg/lnet/sys/lkqueueeventer.inc svneol=native#text/plain
|
||||||
|
|||||||
19
utils/fppkg/lnet/LICENSE.ADDON
Normal file
19
utils/fppkg/lnet/LICENSE.ADDON
Normal file
@ -0,0 +1,19 @@
|
|||||||
|
This is the file LICENSE.Addon, it applies to the Lighweight Network Library (lnet).
|
||||||
|
|
||||||
|
The source code of the Lightweight Network library are
|
||||||
|
distributed under the Library GNU General Public License
|
||||||
|
(see the file LICENSE) with the following modification:
|
||||||
|
|
||||||
|
- object files and libraries linked into an application may be
|
||||||
|
distributed without source code.
|
||||||
|
|
||||||
|
The unit tomwinsock.pas is EXLUDED from both the GPL and this addon license.
|
||||||
|
It is distributed under the terms of BSD license as mentioned in the file.
|
||||||
|
I am NOT the author of tomwinsock.pas
|
||||||
|
|
||||||
|
If you didn't receive a copy of the file LICENSE, contact:
|
||||||
|
Free Software Foundation, Inc.,
|
||||||
|
59 Temple Place - Suite 330
|
||||||
|
Boston, MA 02111
|
||||||
|
USA
|
||||||
|
|
||||||
@ -317,7 +317,7 @@ function TLEventer.Bail(const msg: string; const Ernum: Integer): Boolean;
|
|||||||
begin
|
begin
|
||||||
Result := False; // always false, substitute for caller's result
|
Result := False; // always false, substitute for caller's result
|
||||||
if Assigned(FOnError) then
|
if Assigned(FOnError) then
|
||||||
FOnError(msg + ': ' + LStrError(Ernum), Self);
|
FOnError(msg + '[' + IntToStr(Ernum) + ']: ' + LStrError(Ernum), Self);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
procedure TLEventer.AddForFree(aHandle: TLHandle);
|
procedure TLEventer.AddForFree(aHandle: TLHandle);
|
||||||
|
|||||||
910
utils/fppkg/lnet/lfastcgi.pp
Normal file
910
utils/fppkg/lnet/lfastcgi.pp
Normal file
@ -0,0 +1,910 @@
|
|||||||
|
{ FastCGI requester support for lNet
|
||||||
|
|
||||||
|
Copyright (C) 2006 Micha Nelissen
|
||||||
|
|
||||||
|
This library is Free software; you can redistribute it and/or modify it
|
||||||
|
under the terms of the GNU Library General Public License as published by
|
||||||
|
the Free Software Foundation; either version 2 of the License, or (at your
|
||||||
|
option) any later version.
|
||||||
|
|
||||||
|
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. See the GNU Library General Public License
|
||||||
|
for more details.
|
||||||
|
|
||||||
|
You should have received a Copy of the GNU Library General Public License
|
||||||
|
along with This library; if not, Write to the Free Software Foundation,
|
||||||
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
This license has been modified. See file LICENSE.ADDON for more information.
|
||||||
|
Should you find these sources without a LICENSE File, please contact
|
||||||
|
me at ales@chello.sk
|
||||||
|
}
|
||||||
|
|
||||||
|
unit lfastcgi;
|
||||||
|
|
||||||
|
{$mode objfpc}{$h+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
classes, sysutils, fastcgi, lnet, levents, lstrbuffer, ltimer;
|
||||||
|
|
||||||
|
type
|
||||||
|
TLFastCGIClient = class;
|
||||||
|
TLFastCGIRequest = class;
|
||||||
|
TLFastCGIPool = class;
|
||||||
|
|
||||||
|
TLFastCGIRequestEvent = procedure(ARequest: TLFastCGIRequest) of object;
|
||||||
|
|
||||||
|
PLFastCGIRequest = ^TLFastCGIRequest;
|
||||||
|
TLFastCGIRequest = class(TObject)
|
||||||
|
protected
|
||||||
|
FID: integer;
|
||||||
|
FClient: TLFastCGIClient;
|
||||||
|
FBuffer: TStringBuffer;
|
||||||
|
FBufferSendPos: integer;
|
||||||
|
FHeader: FCGI_Header;
|
||||||
|
FHeaderPos: integer;
|
||||||
|
FContentLength: integer;
|
||||||
|
FInputBuffer: pchar;
|
||||||
|
FInputSize: integer;
|
||||||
|
FOutputDone: boolean;
|
||||||
|
FStderrDone: boolean;
|
||||||
|
FOutputPending: boolean;
|
||||||
|
FNextFree: TLFastCGIRequest;
|
||||||
|
FNextSend: TLFastCGIRequest;
|
||||||
|
FOnEndRequest: TLFastCGIRequestEvent;
|
||||||
|
FOnInput: TLFastCGIRequestEvent;
|
||||||
|
FOnOutput: TLFastCGIRequestEvent;
|
||||||
|
FOnStderr: TLFastCGIRequestEvent;
|
||||||
|
|
||||||
|
procedure HandleReceive;
|
||||||
|
procedure HandleReceiveEnd;
|
||||||
|
function HandleSend: boolean;
|
||||||
|
procedure DoEndRequest;
|
||||||
|
procedure DoOutput;
|
||||||
|
procedure DoStderr;
|
||||||
|
procedure EndRequest;
|
||||||
|
procedure RewindBuffer;
|
||||||
|
procedure SetContentLength(NewLength: integer);
|
||||||
|
procedure SendEmptyRec(AType: integer);
|
||||||
|
procedure SendGetValues;
|
||||||
|
procedure SetID(const NewID: integer);
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
destructor Destroy; override;
|
||||||
|
|
||||||
|
procedure AbortRequest;
|
||||||
|
function Get(ABuffer: pchar; ASize: integer): integer;
|
||||||
|
procedure ParseClientBuffer;
|
||||||
|
function SendBuffer: integer;
|
||||||
|
function SendPrivateBuffer: boolean;
|
||||||
|
procedure SendBeginRequest(AType: integer);
|
||||||
|
procedure SendParam(const AName, AValue: string; AReqType: integer = FCGI_PARAMS);
|
||||||
|
function SendInput(const ABuffer: pchar; ASize: integer): integer;
|
||||||
|
procedure DoneParams;
|
||||||
|
procedure DoneInput;
|
||||||
|
|
||||||
|
property ID: integer read FID write SetID;
|
||||||
|
property StderrDone: boolean read FStderrDone;
|
||||||
|
property OutputDone: boolean read FOutputDone;
|
||||||
|
property OutputPending: boolean read FOutputPending;
|
||||||
|
property OnEndRequest: TLFastCGIRequestEvent read FOnEndRequest write FOnEndRequest;
|
||||||
|
property OnInput: TLFastCGIRequestEvent read FOnInput write FOnInput;
|
||||||
|
property OnOutput: TLFastCGIRequestEvent read FOnOutput write FOnOutput;
|
||||||
|
property OnStderr: TLFastCGIRequestEvent read FOnStderr write FOnStderr;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TFastCGIClientState = (fsIdle, fsConnecting, fsConnectingAgain,
|
||||||
|
fsStartingServer, fsHeader, fsData, fsFlush);
|
||||||
|
|
||||||
|
PLFastCGIClient = ^TLFastCGIClient;
|
||||||
|
TLFastCGIClient = class(TLTcp)
|
||||||
|
protected
|
||||||
|
FRequests: PLFastCGIRequest;
|
||||||
|
FRequestsCount: integer;
|
||||||
|
FNextRequestID: integer;
|
||||||
|
FRequestsSent: integer;
|
||||||
|
FFreeRequest: TLFastCGIRequest;
|
||||||
|
FSendRequest: TLFastCGIRequest;
|
||||||
|
FRequest: TLFastCGIRequest;
|
||||||
|
FState: TFastCGIClientState;
|
||||||
|
FNextFree: TLFastCGIClient;
|
||||||
|
FPool: TLFastCGIPool;
|
||||||
|
FBuffer: pchar;
|
||||||
|
FBufferEnd: pchar;
|
||||||
|
FBufferPos: pchar;
|
||||||
|
FBufferSize: dword;
|
||||||
|
FReqType: byte;
|
||||||
|
FContentLength: integer;
|
||||||
|
FPaddingLength: integer;
|
||||||
|
|
||||||
|
function Connect: Boolean; override;
|
||||||
|
procedure ConnectEvent(ASocket: TLHandle); override;
|
||||||
|
procedure DisconnectEvent(ASocket: TLHandle); override;
|
||||||
|
procedure ErrorEvent(const Msg: string; ASocket: TLHandle); override;
|
||||||
|
function CreateRequester: TLFastCGIRequest;
|
||||||
|
procedure HandleGetValuesResult;
|
||||||
|
procedure HandleReceive(ASocket: TLSocket);
|
||||||
|
procedure HandleSend(ASocket: TLSocket);
|
||||||
|
procedure ParseBuffer;
|
||||||
|
public
|
||||||
|
constructor Create(AOwner: TComponent); override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
|
||||||
|
procedure AddToSendQueue(ARequest: TLFastCGIRequest);
|
||||||
|
function BeginRequest(AType: integer): TLFastCGIRequest;
|
||||||
|
procedure EndRequest(ARequest: TLFastCGIRequest);
|
||||||
|
procedure Flush;
|
||||||
|
function GetBuffer(ABuffer: pchar; ASize: integer): integer;
|
||||||
|
|
||||||
|
property ReqType: byte read FReqType;
|
||||||
|
property RequestsSent: integer read FRequestsSent;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TSpawnState = (ssNone, ssSpawning, ssSpawned);
|
||||||
|
|
||||||
|
TLFastCGIPool = class(TObject)
|
||||||
|
protected
|
||||||
|
FClients: PLFastCGIClient;
|
||||||
|
FClientsCount: integer;
|
||||||
|
FClientsAvail: integer;
|
||||||
|
FClientsMax: integer;
|
||||||
|
FMaxRequestsConn: integer;
|
||||||
|
FFreeClient: TLFastCGIClient;
|
||||||
|
FTimer: TLTimer;
|
||||||
|
FEventer: TLEventer;
|
||||||
|
FAppName: string;
|
||||||
|
FAppEnv: string;
|
||||||
|
FHost: string;
|
||||||
|
FPort: integer;
|
||||||
|
FSpawnState: TSpawnState;
|
||||||
|
|
||||||
|
procedure AddToFreeClients(AClient: TLFastCGIClient);
|
||||||
|
function CreateClient: TLFastCGIClient;
|
||||||
|
procedure ConnectClients(Sender: TObject);
|
||||||
|
procedure StartServer;
|
||||||
|
public
|
||||||
|
constructor Create;
|
||||||
|
destructor Destroy; override;
|
||||||
|
|
||||||
|
function BeginRequest(AType: integer): TLFastCGIRequest;
|
||||||
|
procedure EndRequest(AClient: TLFastCGIClient);
|
||||||
|
|
||||||
|
property AppEnv: string read FAppEnv write FAppEnv;
|
||||||
|
property AppName: string read FAppName write FAppName;
|
||||||
|
property ClientsMax: integer read FClientsMax write FClientsMax;
|
||||||
|
property Eventer: TLEventer read FEventer write FEventer;
|
||||||
|
property MaxRequestsConn: integer read FMaxRequestsConn write FMaxRequestsConn;
|
||||||
|
property Host: string read FHost write FHost;
|
||||||
|
property Port: integer read FPort write FPort;
|
||||||
|
property Timer: TLTimer read FTimer;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
lSpawnFCGI;
|
||||||
|
|
||||||
|
{ TLFastCGIRequest }
|
||||||
|
|
||||||
|
constructor TLFastCGIRequest.Create;
|
||||||
|
begin
|
||||||
|
inherited;
|
||||||
|
|
||||||
|
FBuffer := InitStringBuffer(504);
|
||||||
|
FHeader.Version := FCGI_VERSION_1;
|
||||||
|
FHeaderPos := -1;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TLFastCGIRequest.Destroy;
|
||||||
|
begin
|
||||||
|
inherited;
|
||||||
|
FreeMem(FBuffer.Memory);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.HandleReceive;
|
||||||
|
begin
|
||||||
|
case FClient.ReqType of
|
||||||
|
FCGI_STDOUT: DoOutput;
|
||||||
|
FCGI_STDERR: DoStderr;
|
||||||
|
FCGI_END_REQUEST: EndRequest;
|
||||||
|
FCGI_GET_VALUES_RESULT: FClient.HandleGetValuesResult;
|
||||||
|
else
|
||||||
|
FClient.Flush;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.HandleReceiveEnd;
|
||||||
|
begin
|
||||||
|
case FClient.ReqType of
|
||||||
|
FCGI_STDOUT: FOutputDone := true;
|
||||||
|
FCGI_STDERR: FStderrDone := true;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLFastCGIRequest.HandleSend: boolean;
|
||||||
|
begin
|
||||||
|
if FOnInput <> nil then
|
||||||
|
FOnInput(Self);
|
||||||
|
Result := FInputBuffer = nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.DoOutput;
|
||||||
|
begin
|
||||||
|
if FOnOutput <> nil then
|
||||||
|
FOnOutput(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.DoStderr;
|
||||||
|
begin
|
||||||
|
if FOnStderr <> nil then
|
||||||
|
FOnStderr(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.DoEndRequest;
|
||||||
|
begin
|
||||||
|
if FOnEndRequest <> nil then
|
||||||
|
FOnEndRequest(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.EndRequest;
|
||||||
|
begin
|
||||||
|
FOutputDone := false;
|
||||||
|
FStderrDone := false;
|
||||||
|
FClient.EndRequest(Self);
|
||||||
|
FClient.Flush;
|
||||||
|
RewindBuffer;
|
||||||
|
DoEndRequest;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLFastCGIRequest.Get(ABuffer: pchar; ASize: integer): integer;
|
||||||
|
begin
|
||||||
|
Result := FClient.GetBuffer(ABuffer, ASize);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.ParseClientBuffer;
|
||||||
|
begin
|
||||||
|
FOutputPending := false;
|
||||||
|
if (FClient.Iterator <> nil) and FClient.Iterator.IgnoreRead then
|
||||||
|
FClient.HandleReceive(nil)
|
||||||
|
else
|
||||||
|
FClient.ParseBuffer;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.SetID(const NewID: integer);
|
||||||
|
begin
|
||||||
|
FID := NewID;
|
||||||
|
FHeader.RequestIDB0 := byte(NewID and $FF);
|
||||||
|
FHeader.RequestIDB1 := byte((NewID shr 8) and $FF);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.SetContentLength(NewLength: integer);
|
||||||
|
begin
|
||||||
|
FContentLength := NewLength;
|
||||||
|
FHeader.ContentLengthB0 := byte(NewLength and $FF);
|
||||||
|
FHeader.ContentLengthB1 := byte((NewLength shr 8) and $FF);
|
||||||
|
FHeader.PaddingLength := byte(7-((NewLength+7) and 7));
|
||||||
|
end;
|
||||||
|
|
||||||
|
const
|
||||||
|
PaddingBuffer: array[0..7] of char = (#0, #0, #0, #0, #0, #0, #0, #0);
|
||||||
|
type
|
||||||
|
TLFastCGIStringSize = record
|
||||||
|
Size: integer;
|
||||||
|
SizeBuf: array[0..3] of char;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function GetFastCGIStringSize(ABufferPos: pbyte; var ASize: integer): integer;
|
||||||
|
begin
|
||||||
|
ASize := ABufferPos[0];
|
||||||
|
if ASize >= 128 then
|
||||||
|
begin
|
||||||
|
ASize := ((ABufferPos[0] shl 24) and $7f) or (ABufferPos[1] shl 16)
|
||||||
|
or (ABufferPos[2] shl 8) or ABufferPos[3];
|
||||||
|
Result := 4;
|
||||||
|
end else
|
||||||
|
Result := 1;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure FillFastCGIStringSize(const AStr: string; var AFastCGIStr: TLFastCGIStringSize);
|
||||||
|
var
|
||||||
|
lLen: dword;
|
||||||
|
begin
|
||||||
|
lLen := dword(Length(AStr));
|
||||||
|
if lLen > 127 then
|
||||||
|
begin
|
||||||
|
AFastCGIStr.Size := 4;
|
||||||
|
AFastCGIStr.SizeBuf[0] := char($80 + ((lLen shr 24) and $ff));
|
||||||
|
AFastCGIStr.SizeBuf[1] := char((lLen shr 16) and $ff);
|
||||||
|
AFastCGIStr.SizeBuf[2] := char((lLen shr 8) and $ff);
|
||||||
|
AFastCGIStr.SizeBuf[3] := char(lLen and $ff);
|
||||||
|
end else begin
|
||||||
|
AFastCGIStr.Size := 1;
|
||||||
|
AFastCGIStr.SizeBuf[0] := char(lLen);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.SendBeginRequest(AType: integer);
|
||||||
|
var
|
||||||
|
lBody: FCGI_BeginRequestBody;
|
||||||
|
begin
|
||||||
|
lBody.roleB1 := byte((AType shr 8) and $ff);
|
||||||
|
lBody.roleB0 := byte(AType and $ff);
|
||||||
|
lBody.flags := FCGI_KEEP_CONN;
|
||||||
|
FHeader.ReqType := FCGI_BEGIN_REQUEST;
|
||||||
|
SetContentLength(sizeof(lBody));
|
||||||
|
AppendString(FBuffer, @FHeader, sizeof(FHeader));
|
||||||
|
AppendString(FBuffer, @lBody, sizeof(lBody));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.SendParam(const AName, AValue: string; AReqType: integer = FCGI_PARAMS);
|
||||||
|
var
|
||||||
|
lNameLen: TLFastCGIStringSize;
|
||||||
|
lValueLen: TLFastCGIStringSize;
|
||||||
|
lTotalLen: integer;
|
||||||
|
begin
|
||||||
|
FillFastCGIStringSize(AName, lNameLen);
|
||||||
|
FillFastCGIStringSize(AValue, lValueLen);
|
||||||
|
lTotalLen := lNameLen.Size+lValueLen.Size+Length(AName)+Length(AValue);
|
||||||
|
if (FHeader.ReqType = AReqType) and (FBufferSendPos = 0)
|
||||||
|
and (0 <= FHeaderPos) and (FHeaderPos < FBuffer.Pos - FBuffer.Memory) then
|
||||||
|
begin
|
||||||
|
{ undo padding }
|
||||||
|
Dec(FBuffer.Pos, FHeader.PaddingLength);
|
||||||
|
SetContentLength(FContentLength+lTotalLen);
|
||||||
|
Move(FHeader, FBuffer.Memory[FHeaderPos], sizeof(FHeader));
|
||||||
|
end else begin
|
||||||
|
FHeader.ReqType := AReqType;
|
||||||
|
SetContentLength(lTotalLen);
|
||||||
|
FHeaderPos := FBuffer.Pos - FBuffer.Memory;
|
||||||
|
AppendString(FBuffer, @FHeader, sizeof(FHeader));
|
||||||
|
end;
|
||||||
|
AppendString(FBuffer, @lNameLen.SizeBuf[0], lNameLen.Size);
|
||||||
|
AppendString(FBuffer, @lValueLen.SizeBuf[0], lValueLen.Size);
|
||||||
|
AppendString(FBuffer, AName);
|
||||||
|
AppendString(FBuffer, AValue);
|
||||||
|
AppendString(FBuffer, @PaddingBuffer[0], FHeader.PaddingLength);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.SendGetValues;
|
||||||
|
var
|
||||||
|
lRequestID: integer;
|
||||||
|
begin
|
||||||
|
{ management record type has request id 0 }
|
||||||
|
lRequestID := ID;
|
||||||
|
ID := 0;
|
||||||
|
SendParam('FCGI_MAX_REQS', '', FCGI_GET_VALUES);
|
||||||
|
{ if we're the first connection, ask max. # connections }
|
||||||
|
if FClient.FPool.FClientsAvail = 1 then
|
||||||
|
SendParam('FCGI_MAX_CONNS', '', FCGI_GET_VALUES);
|
||||||
|
ID := lRequestID;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLFastCGIRequest.SendInput(const ABuffer: pchar; ASize: integer): integer;
|
||||||
|
begin
|
||||||
|
{ first send current buffer if any }
|
||||||
|
if FInputBuffer <> nil then
|
||||||
|
begin
|
||||||
|
Result := SendBuffer;
|
||||||
|
if FInputBuffer <> nil then exit;
|
||||||
|
end else Result := 0;
|
||||||
|
if Result >= ASize then exit;
|
||||||
|
if FInputBuffer = nil then
|
||||||
|
begin
|
||||||
|
FInputBuffer := ABuffer+Result;
|
||||||
|
FInputSize := ASize-Result;
|
||||||
|
FHeader.ReqType := FCGI_STDIN;
|
||||||
|
SetContentLength(FInputSize);
|
||||||
|
AppendString(FBuffer, @FHeader, sizeof(FHeader));
|
||||||
|
end;
|
||||||
|
Inc(Result, SendBuffer);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.RewindBuffer;
|
||||||
|
begin
|
||||||
|
FBufferSendPos := 0;
|
||||||
|
FHeaderPos := -1;
|
||||||
|
{ rewind stringbuffer }
|
||||||
|
FBuffer.Pos := FBuffer.Memory;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLFastCGIRequest.SendPrivateBuffer: boolean;
|
||||||
|
var
|
||||||
|
lWritten: integer;
|
||||||
|
begin
|
||||||
|
{ nothing to send ? }
|
||||||
|
if FBuffer.Pos-FBuffer.Memory = FBufferSendPos then
|
||||||
|
exit(true);
|
||||||
|
{ already a queue and we are not first in line ? no use in trying to send then }
|
||||||
|
if (FClient.FSendRequest = nil) or (FClient.FSendRequest = Self) then
|
||||||
|
begin
|
||||||
|
lWritten := FClient.Send(FBuffer.Memory[FBufferSendPos],
|
||||||
|
FBuffer.Pos-FBuffer.Memory-FBufferSendPos);
|
||||||
|
Inc(FBufferSendPos, lWritten);
|
||||||
|
Result := FBufferSendPos = FBuffer.Pos-FBuffer.Memory;
|
||||||
|
{ do not rewind buffer, unless remote side has had chance to disconnect }
|
||||||
|
if Result then
|
||||||
|
RewindBuffer;
|
||||||
|
end else
|
||||||
|
Result := false;
|
||||||
|
if not Result then
|
||||||
|
FClient.AddToSendQueue(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLFastCGIRequest.SendBuffer: integer;
|
||||||
|
var
|
||||||
|
lWritten: integer;
|
||||||
|
begin
|
||||||
|
{ already a queue and we are not first in line ? no use in trying to send then }
|
||||||
|
if (FClient.FSendRequest <> nil) and (FClient.FSendRequest <> Self) then
|
||||||
|
exit(0);
|
||||||
|
|
||||||
|
{ header to be sent? }
|
||||||
|
if not SendPrivateBuffer then exit(0);
|
||||||
|
{ first write request header, then wait for possible disconnect }
|
||||||
|
if FBufferSendPos > 0 then exit(0);
|
||||||
|
if FInputBuffer = nil then exit(0);
|
||||||
|
|
||||||
|
lWritten := FClient.Send(FInputBuffer^, FInputSize);
|
||||||
|
Inc(FInputBuffer, lWritten);
|
||||||
|
Dec(FInputSize, lWritten);
|
||||||
|
if FInputSize = 0 then
|
||||||
|
begin
|
||||||
|
FInputBuffer := nil;
|
||||||
|
AppendString(FBuffer, @PaddingBuffer[0], FHeader.PaddingLength);
|
||||||
|
end else
|
||||||
|
FClient.AddToSendQueue(Self);
|
||||||
|
Result := lWritten;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.SendEmptyRec(AType: integer);
|
||||||
|
begin
|
||||||
|
FHeader.ReqType := AType;
|
||||||
|
SetContentLength(0);
|
||||||
|
AppendString(FBuffer, @FHeader, sizeof(FHeader));
|
||||||
|
{ no padding needed for empty string }
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.DoneParams;
|
||||||
|
begin
|
||||||
|
SendEmptyRec(FCGI_PARAMS);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.DoneInput;
|
||||||
|
begin
|
||||||
|
SendEmptyRec(FCGI_STDIN);
|
||||||
|
SendPrivateBuffer;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIRequest.AbortRequest;
|
||||||
|
begin
|
||||||
|
FHeader.ReqType := FCGI_ABORT_REQUEST;
|
||||||
|
SetContentLength(0);
|
||||||
|
AppendString(FBuffer, @FHeader, sizeof(FHeader));
|
||||||
|
SendPrivateBuffer;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TLFastCGIClient }
|
||||||
|
|
||||||
|
const
|
||||||
|
DataBufferSize = 64*1024-1;
|
||||||
|
|
||||||
|
constructor TLFastCGIClient.Create(AOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited;
|
||||||
|
|
||||||
|
FBuffer := GetMem(DataBufferSize+1);
|
||||||
|
FBufferPos := FBuffer;
|
||||||
|
FBufferEnd := FBuffer;
|
||||||
|
FRequests := AllocMem(sizeof(TLFastCGIRequest));
|
||||||
|
FRequestsCount := 1;
|
||||||
|
FFreeRequest := nil;
|
||||||
|
OnReceive := @HandleReceive;
|
||||||
|
OnCanSend := @HandleSend;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TLFastCGIClient.Destroy;
|
||||||
|
var
|
||||||
|
I: integer;
|
||||||
|
begin
|
||||||
|
for I := 0 to FNextRequestID-1 do
|
||||||
|
FRequests[I].Free;
|
||||||
|
FreeMem(FRequests);
|
||||||
|
FreeMem(FBuffer);
|
||||||
|
inherited;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLFastCGIClient.GetBuffer(ABuffer: pchar; ASize: integer): integer;
|
||||||
|
begin
|
||||||
|
Result := FBufferEnd - FBufferPos;
|
||||||
|
if Result > FContentLength then
|
||||||
|
Result := FContentLength;
|
||||||
|
if Result > ASize then
|
||||||
|
Result := ASize;
|
||||||
|
Move(FBufferPos^, ABuffer^, Result);
|
||||||
|
Inc(FBufferPos, Result);
|
||||||
|
Dec(FContentLength, Result);
|
||||||
|
{ buffer empty? reset }
|
||||||
|
if FBufferPos = FBufferEnd then
|
||||||
|
begin
|
||||||
|
FBufferPos := FBuffer;
|
||||||
|
FBufferEnd := FBuffer;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIClient.ConnectEvent(ASocket: TLHandle);
|
||||||
|
begin
|
||||||
|
if FState = fsStartingServer then
|
||||||
|
FPool.FSpawnState := ssSpawned;
|
||||||
|
FState := fsHeader;
|
||||||
|
if FPool <> nil then
|
||||||
|
FPool.AddToFreeClients(Self);
|
||||||
|
|
||||||
|
inherited;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIClient.DisconnectEvent(ASocket: TLHandle);
|
||||||
|
var
|
||||||
|
I: integer;
|
||||||
|
needReconnect: boolean;
|
||||||
|
begin
|
||||||
|
inherited;
|
||||||
|
FRequestsSent := 0;
|
||||||
|
needReconnect := false;
|
||||||
|
for I := 0 to FNextRequestID-1 do
|
||||||
|
if FRequests[I].FNextFree = nil then
|
||||||
|
begin
|
||||||
|
{ see if buffer contains request, then assume we can resend that }
|
||||||
|
if FRequests[I].FBufferSendPos > 0 then
|
||||||
|
begin
|
||||||
|
needReconnect := true;
|
||||||
|
FRequests[I].FBufferSendPos := 0;
|
||||||
|
FRequests[I].SendPrivateBuffer;
|
||||||
|
end else
|
||||||
|
if FRequests[I].FBuffer.Memory = FRequests[I].FBuffer.Pos then
|
||||||
|
needReconnect := true
|
||||||
|
else
|
||||||
|
FRequests[I].EndRequest;
|
||||||
|
end;
|
||||||
|
if needReconnect then
|
||||||
|
Connect;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIClient.ErrorEvent(const Msg: string; ASocket: TLHandle);
|
||||||
|
begin
|
||||||
|
if (FState = fsConnectingAgain)
|
||||||
|
or ((FState = fsConnecting) and (FPool.FSpawnState = ssSpawned)) then
|
||||||
|
begin
|
||||||
|
FRequest.DoEndRequest;
|
||||||
|
EndRequest(FRequest);
|
||||||
|
FState := fsIdle;
|
||||||
|
end else
|
||||||
|
if FState = fsConnecting then
|
||||||
|
begin
|
||||||
|
FPool.StartServer;
|
||||||
|
FState := fsStartingServer;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIClient.HandleGetValuesResult;
|
||||||
|
var
|
||||||
|
lNameLen, lValueLen, lIntVal, lCode: integer;
|
||||||
|
lBufferPtr: pchar;
|
||||||
|
lPrevChar: char;
|
||||||
|
|
||||||
|
procedure GetIntVal;
|
||||||
|
begin
|
||||||
|
lPrevChar := lBufferPtr[lNameLen+lValueLen];
|
||||||
|
lBufferPtr[lNameLen+lValueLen] := #0;
|
||||||
|
Val(lBufferPtr+lNameLen, lIntVal, lCode);
|
||||||
|
lBufferPtr[lNameLen+lValueLen] := lPrevChar;
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
repeat
|
||||||
|
lBufferPtr := FBufferPos;
|
||||||
|
Inc(lBufferPtr, GetFastCGIStringSize(PByte(lBufferPtr), lNameLen));
|
||||||
|
Inc(lBufferPtr, GetFastCGIStringSize(PByte(lBufferPtr), lValueLen));
|
||||||
|
if lBufferPtr + lNameLen + lValueLen > FBufferEnd then exit;
|
||||||
|
if StrLComp(lBufferPtr, 'FCGI_MAX_REQS', lNameLen) = 0 then
|
||||||
|
begin
|
||||||
|
GetIntVal;
|
||||||
|
if (lCode = 0) and (FRequestsCount <> lIntVal) then
|
||||||
|
begin
|
||||||
|
FRequestsCount := lIntVal;
|
||||||
|
ReallocMem(FRequests, sizeof(TLFastCGIRequest)*lIntVal);
|
||||||
|
end;
|
||||||
|
end else
|
||||||
|
if StrLComp(lBufferPtr, 'FCGI_MAX_CONNS', lNameLen) = 0 then
|
||||||
|
begin
|
||||||
|
GetIntVal;
|
||||||
|
if lCode = 0 then
|
||||||
|
FPool.ClientsMax := lIntVal;
|
||||||
|
end;
|
||||||
|
Inc(lBufferPtr, lNameLen+lValueLen);
|
||||||
|
Dec(FContentLength, lBufferPtr-FBufferPos);
|
||||||
|
FBufferPos := lBufferPtr;
|
||||||
|
until FContentLength = 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIClient.HandleReceive(ASocket: TLSocket);
|
||||||
|
var
|
||||||
|
lRead: integer;
|
||||||
|
begin
|
||||||
|
lRead := Get(FBufferEnd^, DataBufferSize-PtrUInt(FBufferEnd-FBuffer));
|
||||||
|
if lRead = 0 then exit;
|
||||||
|
{ remote side has had chance to disconnect, clear buffer }
|
||||||
|
Inc(FBufferEnd, lRead);
|
||||||
|
ParseBuffer;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIClient.HandleSend(ASocket: TLSocket);
|
||||||
|
var
|
||||||
|
lRequest: TLFastCGIRequest;
|
||||||
|
begin
|
||||||
|
if FSendRequest = nil then exit;
|
||||||
|
lRequest := FSendRequest.FNextSend;
|
||||||
|
repeat
|
||||||
|
if not lRequest.SendPrivateBuffer or not lRequest.HandleSend then
|
||||||
|
exit;
|
||||||
|
|
||||||
|
lRequest.FNextSend := nil;
|
||||||
|
{ only this one left in list ? }
|
||||||
|
if FSendRequest = lRequest then
|
||||||
|
begin
|
||||||
|
FSendRequest := nil;
|
||||||
|
exit;
|
||||||
|
end else begin
|
||||||
|
lRequest := lRequest.FNextSend;
|
||||||
|
FSendRequest.FNextSend := lRequest;
|
||||||
|
end;
|
||||||
|
until false;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIClient.AddToSendQueue(ARequest: TLFastCGIRequest);
|
||||||
|
begin
|
||||||
|
if ARequest.FNextSend <> nil then exit;
|
||||||
|
|
||||||
|
if FSendRequest = nil then
|
||||||
|
FSendRequest := ARequest
|
||||||
|
else
|
||||||
|
ARequest.FNextSend := FSendRequest.FNextSend;
|
||||||
|
FSendRequest.FNextSend := ARequest;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIClient.ParseBuffer;
|
||||||
|
var
|
||||||
|
lHeader: PFCGI_Header;
|
||||||
|
lReqIndex: integer;
|
||||||
|
begin
|
||||||
|
repeat
|
||||||
|
case FState of
|
||||||
|
fsHeader:
|
||||||
|
begin
|
||||||
|
if FBufferEnd-FBufferPos < sizeof(FCGI_Header) then
|
||||||
|
exit;
|
||||||
|
lHeader := PFCGI_Header(FBufferPos);
|
||||||
|
FReqType := lHeader^.ReqType;
|
||||||
|
lReqIndex := (lHeader^.RequestIDB1 shl 8) or lHeader^.RequestIDB0;
|
||||||
|
FContentLength := (lHeader^.ContentLengthB1 shl 8) or lHeader^.ContentLengthB0;
|
||||||
|
FPaddingLength := lHeader^.PaddingLength;
|
||||||
|
Inc(FBufferPos, sizeof(lHeader^));
|
||||||
|
if lReqIndex > 0 then
|
||||||
|
Dec(lReqIndex);
|
||||||
|
if (lReqIndex < FRequestsCount) and (FRequests[lReqIndex] <> nil) then
|
||||||
|
begin
|
||||||
|
FRequest := FRequests[lReqIndex];
|
||||||
|
if FContentLength > 0 then
|
||||||
|
FState := fsData
|
||||||
|
else begin
|
||||||
|
FRequest.HandleReceiveEnd;
|
||||||
|
Flush;
|
||||||
|
end;
|
||||||
|
end else
|
||||||
|
Flush;
|
||||||
|
end;
|
||||||
|
fsData:
|
||||||
|
begin
|
||||||
|
FRequest.HandleReceive;
|
||||||
|
if FContentLength = 0 then
|
||||||
|
Flush
|
||||||
|
else begin
|
||||||
|
FRequest.FOutputPending := true;
|
||||||
|
exit;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
fsFlush: Flush;
|
||||||
|
end;
|
||||||
|
until FBufferPos = FBufferEnd;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIClient.Flush;
|
||||||
|
|
||||||
|
function FlushSize(var ANumBytes: integer): boolean;
|
||||||
|
var
|
||||||
|
lFlushBytes: integer;
|
||||||
|
begin
|
||||||
|
lFlushBytes := ANumBytes;
|
||||||
|
if lFlushBytes > FBufferEnd - FBufferPos then
|
||||||
|
lFlushBytes := FBufferEnd - FBufferPos;
|
||||||
|
Dec(ANumBytes, lFlushBytes);
|
||||||
|
Inc(FBufferPos, lFlushBytes);
|
||||||
|
Result := ANumBytes = 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
begin
|
||||||
|
FState := fsFlush;
|
||||||
|
if FlushSize(FContentLength) and FlushSize(FPaddingLength) then
|
||||||
|
begin
|
||||||
|
{ buffer empty? reset }
|
||||||
|
if FBufferPos = FBufferEnd then
|
||||||
|
begin
|
||||||
|
FBufferPos := FBuffer;
|
||||||
|
FBufferEnd := FBuffer;
|
||||||
|
end;
|
||||||
|
FState := fsHeader;
|
||||||
|
FRequest := nil;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLFastCGIClient.CreateRequester: TLFastCGIRequest;
|
||||||
|
begin
|
||||||
|
if FRequests[FNextRequestID] = nil then
|
||||||
|
FRequests[FNextRequestID] := TLFastCGIRequest.Create;
|
||||||
|
Result := FRequests[FNextRequestID];
|
||||||
|
Inc(FNextRequestID);
|
||||||
|
Result.FClient := Self;
|
||||||
|
Result.ID := FNextRequestID; { request ids start at 1 }
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLFastCGIClient.Connect: Boolean;
|
||||||
|
begin
|
||||||
|
Result := inherited Connect(FPool.Host, FPool.Port);
|
||||||
|
FRequest := FRequests[0];
|
||||||
|
if FRequest.FBuffer.Pos = FRequest.FBuffer.Memory then
|
||||||
|
FRequest.SendGetValues;
|
||||||
|
if FState <> fsStartingServer then
|
||||||
|
FState := fsConnecting
|
||||||
|
else
|
||||||
|
FState := fsConnectingAgain;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLFastCGIClient.BeginRequest(AType: integer): TLFastCGIRequest;
|
||||||
|
begin
|
||||||
|
if FFreeRequest <> nil then
|
||||||
|
begin
|
||||||
|
Result := FFreeRequest.FNextFree;
|
||||||
|
if FFreeRequest = FFreeRequest.FNextFree then
|
||||||
|
FFreeRequest := nil
|
||||||
|
else
|
||||||
|
FFreeRequest.FNextFree := FFreeRequest.FNextFree.FNextFree;
|
||||||
|
Result.FNextFree := nil;
|
||||||
|
end else
|
||||||
|
if FNextRequestID = FRequestsCount then
|
||||||
|
exit(nil)
|
||||||
|
else begin
|
||||||
|
Result := CreateRequester;
|
||||||
|
end;
|
||||||
|
|
||||||
|
if not Connected then
|
||||||
|
Connect;
|
||||||
|
|
||||||
|
Result.SendBeginRequest(AType);
|
||||||
|
Inc(FRequestsSent);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIClient.EndRequest(ARequest: TLFastCGIRequest);
|
||||||
|
begin
|
||||||
|
if FFreeRequest <> nil then
|
||||||
|
ARequest.FNextFree := FFreeRequest.FNextFree
|
||||||
|
else
|
||||||
|
FFreeRequest := ARequest;
|
||||||
|
FFreeRequest.FNextFree := ARequest;
|
||||||
|
if FPool <> nil then
|
||||||
|
FPool.EndRequest(Self);
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TLFastCGIPool }
|
||||||
|
|
||||||
|
constructor TLFastCGIPool.Create;
|
||||||
|
begin
|
||||||
|
FClientsMax := 1;
|
||||||
|
FMaxRequestsConn := 1;
|
||||||
|
inherited;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TLFastCGIPool.Destroy;
|
||||||
|
var
|
||||||
|
I: integer;
|
||||||
|
begin
|
||||||
|
for I := 0 to FClientsAvail-1 do
|
||||||
|
FClients[I].Free;
|
||||||
|
FreeMem(FClients);
|
||||||
|
if FTimer <> nil then
|
||||||
|
FTimer.Free;
|
||||||
|
inherited;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLFastCGIPool.CreateClient: TLFastCGIClient;
|
||||||
|
begin
|
||||||
|
if FClientsAvail = FClientsCount then
|
||||||
|
begin
|
||||||
|
Inc(FClientsCount, 64);
|
||||||
|
ReallocMem(FClients, FClientsCount*sizeof(TLFastCGIRequest));
|
||||||
|
end;
|
||||||
|
Result := TLFastCGIClient.Create(nil);
|
||||||
|
Result.FPool := Self;
|
||||||
|
Result.Eventer := FEventer;
|
||||||
|
FClients[FClientsAvail] := Result;
|
||||||
|
Inc(FClientsAvail);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLFastCGIPool.BeginRequest(AType: integer): TLFastCGIRequest;
|
||||||
|
var
|
||||||
|
lTempClient: TLFastCGIClient;
|
||||||
|
begin
|
||||||
|
Result := nil;
|
||||||
|
while FFreeClient <> nil do
|
||||||
|
begin
|
||||||
|
lTempClient := FFreeClient.FNextFree;
|
||||||
|
Result := lTempClient.BeginRequest(AType);
|
||||||
|
if Result <> nil then break;
|
||||||
|
{ Result = nil -> no free requesters on next free client }
|
||||||
|
if lTempClient = FFreeClient then
|
||||||
|
FFreeClient := nil
|
||||||
|
else
|
||||||
|
FFreeClient.FNextFree := lTempClient.FNextFree;
|
||||||
|
lTempClient.FNextFree := nil;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ all clients busy }
|
||||||
|
if Result = nil then
|
||||||
|
if FClientsAvail < FClientsMax then
|
||||||
|
Result := CreateClient.BeginRequest(AType);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIPool.EndRequest(AClient: TLFastCGIClient);
|
||||||
|
begin
|
||||||
|
{ TODO: wait for other requests to be completed }
|
||||||
|
if AClient.RequestsSent = FMaxRequestsConn then
|
||||||
|
AClient.Disconnect;
|
||||||
|
AddToFreeClients(AClient);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIPool.AddToFreeClients(AClient: TLFastCGIClient);
|
||||||
|
begin
|
||||||
|
if AClient.FNextFree <> nil then exit;
|
||||||
|
|
||||||
|
if FFreeClient = nil then
|
||||||
|
FFreeClient := AClient
|
||||||
|
else
|
||||||
|
AClient.FNextFree := FFreeClient.FNextFree;
|
||||||
|
FFreeClient.FNextFree := AClient;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIPool.ConnectClients(Sender: TObject);
|
||||||
|
var
|
||||||
|
I: integer;
|
||||||
|
begin
|
||||||
|
for I := 0 to FClientsAvail-1 do
|
||||||
|
if FClients[I].FState = fsStartingServer then
|
||||||
|
FClients[I].Connect;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLFastCGIPool.StartServer;
|
||||||
|
begin
|
||||||
|
if FSpawnState = ssNone then
|
||||||
|
begin
|
||||||
|
FSpawnState := ssSpawning;
|
||||||
|
SpawnFCGIProcess(FAppName, FAppEnv, FPort);
|
||||||
|
if FTimer = nil then
|
||||||
|
FTimer := TLTimer.Create;
|
||||||
|
FTimer.OneShot := true;
|
||||||
|
FTimer.OnTimer := @ConnectClients;
|
||||||
|
end;
|
||||||
|
FTimer.Interval := 2000;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
@ -35,9 +35,9 @@ type
|
|||||||
TLFTP = class;
|
TLFTP = class;
|
||||||
TLFTPClient = class;
|
TLFTPClient = class;
|
||||||
|
|
||||||
TLFTPStatus = (fsNone, fsCon, fsAuth, fsPasv, fsPort, fsList, fsRetr, fsStor,
|
TLFTPStatus = (fsNone, fsCon, fsAuth, fsPass, fsPasv, fsPort, fsList, fsRetr,
|
||||||
fsType, fsCWD, fsMKD, fsRMD, fsDEL, fsRNFR, fsRNTO, fsSYS,
|
fsStor, fsType, fsCWD, fsMKD, fsRMD, fsDEL, fsRNFR, fsRNTO,
|
||||||
fsFeat, fsPWD, fsHelp, fsLast);
|
fsSYS, fsFeat, fsPWD, fsHelp, fsLast);
|
||||||
|
|
||||||
TLFTPStatusSet = set of TLFTPStatus;
|
TLFTPStatusSet = set of TLFTPStatus;
|
||||||
|
|
||||||
@ -131,6 +131,7 @@ type
|
|||||||
procedure OnControlEr(const msg: string; aSocket: TLSocket);
|
procedure OnControlEr(const msg: string; aSocket: TLSocket);
|
||||||
procedure OnControlRe(aSocket: TLSocket);
|
procedure OnControlRe(aSocket: TLSocket);
|
||||||
procedure OnControlCo(aSocket: TLSocket);
|
procedure OnControlCo(aSocket: TLSocket);
|
||||||
|
procedure OnControlDs(aSocket: TLSocket);
|
||||||
|
|
||||||
function GetTransfer: Boolean;
|
function GetTransfer: Boolean;
|
||||||
|
|
||||||
@ -170,6 +171,8 @@ type
|
|||||||
|
|
||||||
function Authenticate(const aUsername, aPassword: string): Boolean;
|
function Authenticate(const aUsername, aPassword: string): Boolean;
|
||||||
|
|
||||||
|
function SendPassword(const aPassword: string): Boolean;
|
||||||
|
|
||||||
function GetData(var aData; const aSize: Integer): Integer;
|
function GetData(var aData; const aSize: Integer): Integer;
|
||||||
function GetDataMessage: string;
|
function GetDataMessage: string;
|
||||||
|
|
||||||
@ -211,6 +214,8 @@ type
|
|||||||
property OnFailure: TLFTPClientStatusEvent read FOnFailure write FOnFailure;
|
property OnFailure: TLFTPClientStatusEvent read FOnFailure write FOnFailure;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
function FTPStatusToStr(const aStatus: TLFTPStatus): string;
|
||||||
|
|
||||||
implementation
|
implementation
|
||||||
|
|
||||||
uses
|
uses
|
||||||
@ -222,7 +227,7 @@ const
|
|||||||
|
|
||||||
EMPTY_REC: TLFTPStatusRec = (Status: fsNone; Args: ('', ''));
|
EMPTY_REC: TLFTPStatusRec = (Status: fsNone; Args: ('', ''));
|
||||||
|
|
||||||
FTPStatusStr: array[TLFTPStatus] of string = ('None', 'Connect', 'Authenticate',
|
FTPStatusStr: array[TLFTPStatus] of string = ('None', 'Connect', 'Authenticate', 'Password',
|
||||||
'Passive', 'Active', 'List', 'Retrieve',
|
'Passive', 'Active', 'List', 'Retrieve',
|
||||||
'Store', 'Type', 'CWD', 'MKDIR',
|
'Store', 'Type', 'CWD', 'MKDIR',
|
||||||
'RMDIR', 'Delete', 'RenameFrom',
|
'RMDIR', 'Delete', 'RenameFrom',
|
||||||
@ -258,6 +263,11 @@ begin
|
|||||||
Result.Args[2] := Arg2;
|
Result.Args[2] := Arg2;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
function FTPStatusToStr(const aStatus: TLFTPStatus): string;
|
||||||
|
begin
|
||||||
|
Result := FTPStatusStr[aStatus];
|
||||||
|
end;
|
||||||
|
|
||||||
{$i lcontainers.inc}
|
{$i lcontainers.inc}
|
||||||
|
|
||||||
{ TLFTP }
|
{ TLFTP }
|
||||||
@ -331,6 +341,7 @@ begin
|
|||||||
FControl.OnReceive := @OnControlRe;
|
FControl.OnReceive := @OnControlRe;
|
||||||
FControl.OnConnect := @OnControlCo;
|
FControl.OnConnect := @OnControlCo;
|
||||||
FControl.OnError := @OnControlEr;
|
FControl.OnError := @OnControlEr;
|
||||||
|
FControl.OnDisconnect := @OnControlDs;
|
||||||
|
|
||||||
FData.OnReceive := @OnRe;
|
FData.OnReceive := @OnRe;
|
||||||
FData.OnDisconnect := @OnDs;
|
FData.OnDisconnect := @OnDs;
|
||||||
@ -372,7 +383,6 @@ end;
|
|||||||
|
|
||||||
procedure TLFTPClient.OnDs(aSocket: TLSocket);
|
procedure TLFTPClient.OnDs(aSocket: TLSocket);
|
||||||
begin
|
begin
|
||||||
// TODO: figure it out brainiac
|
|
||||||
FSending := False;
|
FSending := False;
|
||||||
Writedbg(['Disconnected']);
|
Writedbg(['Disconnected']);
|
||||||
end;
|
end;
|
||||||
@ -409,6 +419,12 @@ begin
|
|||||||
FOnConnect(aSocket);
|
FOnConnect(aSocket);
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
procedure TLFTPClient.OnControlDs(aSocket: TLSocket);
|
||||||
|
begin
|
||||||
|
if Assigned(FOnError) then
|
||||||
|
FOnError('Connection lost', aSocket);
|
||||||
|
end;
|
||||||
|
|
||||||
function TLFTPClient.GetTransfer: Boolean;
|
function TLFTPClient.GetTransfer: Boolean;
|
||||||
begin
|
begin
|
||||||
Result := FData.Connected;
|
Result := FData.Connected;
|
||||||
@ -586,9 +602,21 @@ begin
|
|||||||
FStatus.Remove;
|
FStatus.Remove;
|
||||||
end;
|
end;
|
||||||
331,
|
331,
|
||||||
332: begin
|
332: SendPassword(FPassword);
|
||||||
|
else
|
||||||
|
begin
|
||||||
FStatusFlags[FStatus.First.Status] := False;
|
FStatusFlags[FStatus.First.Status] := False;
|
||||||
FControl.SendMessage('PASS ' + FPassword + FLE);
|
Eventize(FStatus.First.Status, False);
|
||||||
|
FStatus.Remove;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
fsPass : case x of
|
||||||
|
230:
|
||||||
|
begin
|
||||||
|
FStatusFlags[FStatus.First.Status] := True;
|
||||||
|
Eventize(FStatus.First.Status, True);
|
||||||
|
FStatus.Remove;
|
||||||
end;
|
end;
|
||||||
else
|
else
|
||||||
begin
|
begin
|
||||||
@ -819,6 +847,7 @@ begin
|
|||||||
case Status of
|
case Status of
|
||||||
fsNone : Exit;
|
fsNone : Exit;
|
||||||
fsAuth : Authenticate(Args[1], Args[2]);
|
fsAuth : Authenticate(Args[1], Args[2]);
|
||||||
|
fsPass : SendPassword(Args[1]);
|
||||||
fsList : List(Args[1]);
|
fsList : List(Args[1]);
|
||||||
fsRetr : Retrieve(Args[1]);
|
fsRetr : Retrieve(Args[1]);
|
||||||
fsStor : Put(Args[1]);
|
fsStor : Put(Args[1]);
|
||||||
@ -909,6 +938,17 @@ begin
|
|||||||
end;
|
end;
|
||||||
end;
|
end;
|
||||||
|
|
||||||
|
function TLFTPClient.SendPassword(const aPassword: string): Boolean;
|
||||||
|
begin
|
||||||
|
Result := not FPipeLine;
|
||||||
|
if CanContinue(fsPass, aPassword, '') then begin
|
||||||
|
FControl.SendMessage('PASS ' + aPassword + FLE);
|
||||||
|
FStatus.Insert(MakeStatusRec(fsPass, '', ''));
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
function TLFTPClient.Retrieve(const FileName: string): Boolean;
|
function TLFTPClient.Retrieve(const FileName: string): Boolean;
|
||||||
begin
|
begin
|
||||||
Result := not FPipeLine;
|
Result := not FPipeLine;
|
||||||
|
|||||||
2264
utils/fppkg/lnet/lhttp.pp
Normal file
2264
utils/fppkg/lnet/lhttp.pp
Normal file
File diff suppressed because it is too large
Load Diff
232
utils/fppkg/lnet/lhttputil.pp
Normal file
232
utils/fppkg/lnet/lhttputil.pp
Normal file
@ -0,0 +1,232 @@
|
|||||||
|
{ Utility routines for HTTP server component
|
||||||
|
|
||||||
|
Copyright (C) 2006 Micha Nelissen
|
||||||
|
|
||||||
|
This library is Free software; you can redistribute it and/or modify it
|
||||||
|
under the terms of the GNU Library General Public License as published by
|
||||||
|
the Free Software Foundation; either version 2 of the License, or (at your
|
||||||
|
option) any later version.
|
||||||
|
|
||||||
|
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. See the GNU Library General Public License
|
||||||
|
for more details.
|
||||||
|
|
||||||
|
You should have received a Copy of the GNU Library General Public License
|
||||||
|
along with This library; if not, Write to the Free Software Foundation,
|
||||||
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
This license has been modified. See file LICENSE.ADDON for more information.
|
||||||
|
Should you find these sources without a LICENSE File, please contact
|
||||||
|
me at ales@chello.sk
|
||||||
|
}
|
||||||
|
|
||||||
|
unit lHTTPUtil;
|
||||||
|
|
||||||
|
{$mode objfpc}{$h+}
|
||||||
|
{$inline on}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
sysutils,
|
||||||
|
strutils;
|
||||||
|
|
||||||
|
const
|
||||||
|
HTTPDateFormat: string = 'ddd, dd mmm yyyy hh:nn:ss';
|
||||||
|
HTTPAllowedChars = ['A'..'Z','a'..'z', '*','@','.','_','-',
|
||||||
|
'0'..'9', '$','!','''','(',')'];
|
||||||
|
|
||||||
|
type
|
||||||
|
PSearchRec = ^TSearchRec;
|
||||||
|
|
||||||
|
function GMTToLocalTime(ADateTime: TDateTime): TDateTime;
|
||||||
|
function LocalTimeToGMT(ADateTime: TDateTime): TDateTime;
|
||||||
|
function TryHTTPDateStrToDateTime(ADateStr: pchar; var ADest: TDateTime): boolean;
|
||||||
|
|
||||||
|
function SeparatePath(var InPath: string; out ExtraPath: string; const Mode:Longint;
|
||||||
|
ASearchRec: PSearchRec = nil): boolean;
|
||||||
|
function CheckPermission(const ADocument: pchar): boolean;
|
||||||
|
function HTTPDecode(AStr: pchar): pchar;
|
||||||
|
function HTTPEncode(const AStr: string): string;
|
||||||
|
function HexToNum(AChar: char): byte;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
lCommon;
|
||||||
|
|
||||||
|
function GMTToLocalTime(ADateTime: TDateTime): TDateTime;
|
||||||
|
begin
|
||||||
|
Result := ADateTime + (TZSeconds*1000/MSecsPerDay);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function LocalTimeToGMT(ADateTime: TDateTime): TDateTime;
|
||||||
|
begin
|
||||||
|
Result := ADateTime - (TZSeconds*1000/MSecsPerDay);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TryHTTPDateStrToDateTime(ADateStr: pchar; var ADest: TDateTime): boolean;
|
||||||
|
var
|
||||||
|
lYear, lMonth, lDay: word;
|
||||||
|
lTime: array[0..2] of word;
|
||||||
|
I, lCode: integer;
|
||||||
|
begin
|
||||||
|
if StrLen(ADateStr) < Length(HTTPDateFormat)+4 then exit(false);
|
||||||
|
{ skip redundant short day string }
|
||||||
|
Inc(ADateStr, 5);
|
||||||
|
{ day }
|
||||||
|
if ADateStr[2] = ' ' then
|
||||||
|
ADateStr[2] := #0
|
||||||
|
else
|
||||||
|
exit(false);
|
||||||
|
Val(ADateStr, lDay, lCode);
|
||||||
|
if lCode <> 0 then exit(false);
|
||||||
|
Inc(ADateStr, 3);
|
||||||
|
{ month }
|
||||||
|
lMonth := 1;
|
||||||
|
repeat
|
||||||
|
if CompareMem(ADateStr, @ShortMonthNames[lMonth][1], 3) then break;
|
||||||
|
inc(lMonth);
|
||||||
|
if lMonth = 13 then exit(false);
|
||||||
|
until false;
|
||||||
|
Inc(ADateStr, 4);
|
||||||
|
{ year }
|
||||||
|
if ADateStr[4] = ' ' then
|
||||||
|
ADateStr[4] := #0
|
||||||
|
else
|
||||||
|
exit(false);
|
||||||
|
Val(ADateStr, lYear, lCode);
|
||||||
|
if lCode <> 0 then exit(false);
|
||||||
|
Inc(ADateStr, 5);
|
||||||
|
{ hour, minute, second }
|
||||||
|
for I := 0 to 2 do
|
||||||
|
begin
|
||||||
|
ADateStr[2] := #0;
|
||||||
|
Val(ADateStr, lTime[I], lCode);
|
||||||
|
Inc(ADateStr, 3);
|
||||||
|
if lCode <> 0 then exit(false);
|
||||||
|
end;
|
||||||
|
ADest := EncodeDate(lYear, lMonth, lDay) + EncodeTime(lTime[0], lTime[1], lTime[2], 0);
|
||||||
|
Result := true;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function SeparatePath(var InPath: string; out ExtraPath: string; const Mode:Longint;
|
||||||
|
ASearchRec: PSearchRec = nil): boolean;
|
||||||
|
var
|
||||||
|
lFullPath: string;
|
||||||
|
lPos: integer;
|
||||||
|
lSearchRec: TSearchRec;
|
||||||
|
begin
|
||||||
|
if ASearchRec = nil then
|
||||||
|
ASearchRec := @lSearchRec;
|
||||||
|
ExtraPath := '';
|
||||||
|
if Length(InPath) <= 2 then exit(false);
|
||||||
|
lFullPath := InPath;
|
||||||
|
if InPath[Length(InPath)] = PathDelim then
|
||||||
|
SetLength(InPath, Length(InPath)-1);
|
||||||
|
repeat
|
||||||
|
Result := SysUtils.FindFirst(InPath, Mode, ASearchRec^) = 0;
|
||||||
|
SysUtils.FindClose(ASearchRec^);
|
||||||
|
if Result then
|
||||||
|
begin
|
||||||
|
ExtraPath := Copy(lFullPath, Length(InPath)+1, Length(lFullPath)-Length(InPath));
|
||||||
|
break;
|
||||||
|
end;
|
||||||
|
lPos := RPos(PathDelim, InPath);
|
||||||
|
if lPos > 0 then
|
||||||
|
SetLength(InPath, lPos-1)
|
||||||
|
else
|
||||||
|
break;
|
||||||
|
until false;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function HexToNum(AChar: char): byte;
|
||||||
|
begin
|
||||||
|
if ('0' <= AChar) and (AChar <= '9') then
|
||||||
|
Result := ord(AChar) - ord('0')
|
||||||
|
else if ('A' <= AChar) and (AChar <= 'F') then
|
||||||
|
Result := ord(AChar) - (ord('A') - 10)
|
||||||
|
else if ('a' <= AChar) and (AChar <= 'f') then
|
||||||
|
Result := ord(AChar) - (ord('a') - 10)
|
||||||
|
else
|
||||||
|
Result := 0;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function HTTPDecode(AStr: pchar): pchar;
|
||||||
|
var
|
||||||
|
lPos, lNext, lDest: pchar;
|
||||||
|
begin
|
||||||
|
lDest := AStr;
|
||||||
|
repeat
|
||||||
|
lPos := AStr;
|
||||||
|
while not (lPos^ in ['%', '+', #0]) do
|
||||||
|
Inc(lPos);
|
||||||
|
if (lPos[0]='%') and (lPos[1] <> #0) and (lPos[2] <> #0) then
|
||||||
|
begin
|
||||||
|
lPos^ := char((HexToNum(lPos[1]) shl 4) + HexToNum(lPos[2]));
|
||||||
|
lNext := lPos+2;
|
||||||
|
end else if lPos[0] = '+' then
|
||||||
|
begin
|
||||||
|
lPos^ := ' ';
|
||||||
|
lNext := lPos+1;
|
||||||
|
end else
|
||||||
|
lNext := nil;
|
||||||
|
Inc(lPos);
|
||||||
|
if lDest <> AStr then
|
||||||
|
Move(AStr^, lDest^, lPos-AStr);
|
||||||
|
Inc(lDest, lPos-AStr);
|
||||||
|
AStr := lNext;
|
||||||
|
until lNext = nil;
|
||||||
|
Result := lDest;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function HTTPEncode(const AStr: string): string;
|
||||||
|
{ code from MvC's web }
|
||||||
|
var
|
||||||
|
src, srcend, dest: pchar;
|
||||||
|
hex: string[2];
|
||||||
|
len: integer;
|
||||||
|
begin
|
||||||
|
len := Length(AStr);
|
||||||
|
SetLength(Result, len*3); // Worst case scenario
|
||||||
|
if len = 0 then
|
||||||
|
exit;
|
||||||
|
dest := pchar(Result);
|
||||||
|
src := pchar(AStr);
|
||||||
|
srcend := src + len;
|
||||||
|
while src < srcend do
|
||||||
|
begin
|
||||||
|
if src^ in HTTPAllowedChars then
|
||||||
|
dest^ := src^
|
||||||
|
else if src^ = ' ' then
|
||||||
|
dest^ := '+'
|
||||||
|
else begin
|
||||||
|
dest^ := '%';
|
||||||
|
inc(dest);
|
||||||
|
hex := HexStr(Ord(src^),2);
|
||||||
|
dest^ := hex[1];
|
||||||
|
inc(dest);
|
||||||
|
dest^ := hex[2];
|
||||||
|
end;
|
||||||
|
inc(dest);
|
||||||
|
inc(src);
|
||||||
|
end;
|
||||||
|
SetLength(Result, dest - pchar(Result));
|
||||||
|
end;
|
||||||
|
|
||||||
|
function CheckPermission(const ADocument: pchar): boolean;
|
||||||
|
var
|
||||||
|
lPos: pchar;
|
||||||
|
begin
|
||||||
|
lPos := ADocument;
|
||||||
|
repeat
|
||||||
|
lPos := StrScan(lPos, '/');
|
||||||
|
if lPos = nil then exit(true);
|
||||||
|
if (lPos[1] = '.') and (lPos[2] = '.') and ((lPos[3] = '/') or (lPos[3] = #0)) then
|
||||||
|
exit(false);
|
||||||
|
inc(lPos);
|
||||||
|
until false;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
108
utils/fppkg/lnet/lmimetypes.pp
Normal file
108
utils/fppkg/lnet/lmimetypes.pp
Normal file
@ -0,0 +1,108 @@
|
|||||||
|
{ Mime types helper
|
||||||
|
|
||||||
|
Copyright (C) 2006 Micha Nelissen
|
||||||
|
|
||||||
|
This library is Free software; you can redistribute it and/or modify it
|
||||||
|
under the terms of the GNU Library General Public License as published by
|
||||||
|
the Free Software Foundation; either version 2 of the License, or (at your
|
||||||
|
option) any later version.
|
||||||
|
|
||||||
|
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. See the GNU Library General Public License
|
||||||
|
for more details.
|
||||||
|
|
||||||
|
You should have received a Copy of the GNU Library General Public License
|
||||||
|
along with This library; if not, Write to the Free Software Foundation,
|
||||||
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
This license has been modified. See file LICENSE.ADDON for more information.
|
||||||
|
Should you find these sources without a LICENSE File, please contact
|
||||||
|
me at ales@chello.sk
|
||||||
|
}
|
||||||
|
|
||||||
|
unit lMimeTypes;
|
||||||
|
|
||||||
|
{$mode objfpc}{$h+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
classes, sysutils, strutils;
|
||||||
|
|
||||||
|
type
|
||||||
|
TStringObject = class(TObject)
|
||||||
|
Str: string;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure InitMimeList(const aFileName: string);
|
||||||
|
|
||||||
|
var
|
||||||
|
MimeList: TStringList = nil;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
var
|
||||||
|
MimeFileName: string;
|
||||||
|
|
||||||
|
procedure InitMimeList(const aFileName: string);
|
||||||
|
var
|
||||||
|
MimeFile: Text;
|
||||||
|
lPos, lNextPos: integer;
|
||||||
|
lLine, lName: string;
|
||||||
|
lStrObj: TStringObject;
|
||||||
|
lBuffer: array[1..32*1024] of byte;
|
||||||
|
begin
|
||||||
|
if not Assigned(MimeList) then begin
|
||||||
|
MimeFileName := aFileName;
|
||||||
|
MimeList := TStringList.Create;
|
||||||
|
if FileExists(MimeFileName) then
|
||||||
|
begin
|
||||||
|
Assign(MimeFile, MimeFileName);
|
||||||
|
Reset(MimeFile);
|
||||||
|
SetTextBuf(MimeFile, lBuffer);
|
||||||
|
while not Eof(MimeFile) do
|
||||||
|
begin
|
||||||
|
ReadLn(MimeFile, lLine);
|
||||||
|
if (Length(lLine) = 0) or (lLine[1] = '#') then
|
||||||
|
continue;
|
||||||
|
|
||||||
|
lPos := Pos(#9, lLine);
|
||||||
|
if lPos = 0 then
|
||||||
|
continue;
|
||||||
|
lName := Copy(lLine, 1, lPos-1);
|
||||||
|
|
||||||
|
while (lPos <= Length(lLine)) and (lLine[lPos] in [#9,' ']) do
|
||||||
|
Inc(lPos);
|
||||||
|
if lPos > Length(lLine) then
|
||||||
|
continue;
|
||||||
|
repeat
|
||||||
|
lNextPos := PosEx(' ', lLine, lPos);
|
||||||
|
if lNextPos = 0 then
|
||||||
|
lNextPos := Length(lLine)+1;
|
||||||
|
lStrObj := TStringObject.Create;
|
||||||
|
lStrObj.Str := lName;
|
||||||
|
MimeList.AddObject('.'+Copy(lLine, lPos, lNextPos-lPos), lStrObj);
|
||||||
|
lPos := lNextPos+1;
|
||||||
|
until lPos > Length(lLine);
|
||||||
|
end;
|
||||||
|
close(MimeFile);
|
||||||
|
end;
|
||||||
|
MimeList.Sorted := true;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure FreeMimeList;
|
||||||
|
var
|
||||||
|
I: integer;
|
||||||
|
begin
|
||||||
|
if Assigned(MimeList) then begin
|
||||||
|
for I := 0 to MimeList.Count - 1 do
|
||||||
|
MimeList.Objects[I].Free;
|
||||||
|
FreeAndNil(MimeList);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
finalization
|
||||||
|
FreeMimeList;
|
||||||
|
end.
|
||||||
@ -440,7 +440,7 @@ procedure TLSocket.LogError(const msg: string; const ernum: Integer);
|
|||||||
begin
|
begin
|
||||||
if Assigned(FOnError) then
|
if Assigned(FOnError) then
|
||||||
if ernum > 0 then
|
if ernum > 0 then
|
||||||
FOnError(Self, msg + ': ' + LStrError(ernum))
|
FOnError(Self, msg + '[' + IntToStr(ernum) + ']: ' + LStrError(ernum))
|
||||||
else
|
else
|
||||||
FOnError(Self, msg);
|
FOnError(Self, msg);
|
||||||
end;
|
end;
|
||||||
|
|||||||
185
utils/fppkg/lnet/lprocess.pp
Normal file
185
utils/fppkg/lnet/lprocess.pp
Normal file
@ -0,0 +1,185 @@
|
|||||||
|
{ Asynchronous process support
|
||||||
|
|
||||||
|
Copyright (C) 2006 Micha Nelissen
|
||||||
|
|
||||||
|
This library is Free software; you can redistribute it and/or modify it
|
||||||
|
under the terms of the GNU Library General Public License as published by
|
||||||
|
the Free Software Foundation; either version 2 of the License, or (at your
|
||||||
|
option) any later version.
|
||||||
|
|
||||||
|
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. See the GNU Library General Public License
|
||||||
|
for more details.
|
||||||
|
|
||||||
|
You should have received a Copy of the GNU Library General Public License
|
||||||
|
along with This library; if not, Write to the Free Software Foundation,
|
||||||
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
This license has been modified. See file LICENSE.ADDON for more information.
|
||||||
|
Should you find these sources without a LICENSE File, please contact
|
||||||
|
me at ales@chello.sk
|
||||||
|
}
|
||||||
|
|
||||||
|
unit lProcess;
|
||||||
|
|
||||||
|
{$mode objfpc}{$h+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
sysutils, classes, process, levents, pipes;
|
||||||
|
|
||||||
|
type
|
||||||
|
TLInputPipeStream = class(TInputPipeStream)
|
||||||
|
protected
|
||||||
|
FEvent: TLHandle;
|
||||||
|
public
|
||||||
|
function Read(var Buffer; Count: longint): longint; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TLOutputPipeStream = class(TOutputPipeStream)
|
||||||
|
protected
|
||||||
|
FEvent: TLHandle;
|
||||||
|
public
|
||||||
|
function Write(const Buffer; Count: longint): longint; override;
|
||||||
|
end;
|
||||||
|
|
||||||
|
TLProcess = class(TProcess)
|
||||||
|
protected
|
||||||
|
FInputEvent: TLHandle;
|
||||||
|
FOutputEvent: TLHandle;
|
||||||
|
FStderrEvent: TLHandle;
|
||||||
|
FEventer: TLEventer;
|
||||||
|
|
||||||
|
function GetOnNeedInput: TLHandleEvent;
|
||||||
|
function GetOnHasOutput: TLHandleEvent;
|
||||||
|
function GetOnHasStderr: TLHandleEvent;
|
||||||
|
procedure SetOnNeedInput(NewOnInput: TLHandleEvent);
|
||||||
|
procedure SetOnHasOutput(NewOnOutput: TLHandleEvent);
|
||||||
|
procedure SetOnHasStderr(NewOnStderr: TLHandleEvent);
|
||||||
|
public
|
||||||
|
constructor Create(AOwner: TComponent); override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
|
||||||
|
procedure CloseInput; override;
|
||||||
|
procedure CloseOutput; override;
|
||||||
|
procedure CloseStderr; override;
|
||||||
|
procedure Execute; override;
|
||||||
|
|
||||||
|
property InputEvent: TLHandle read FInputEvent;
|
||||||
|
property OutputEvent: TLHandle read FOutputEvent;
|
||||||
|
property StderrEvent: TLHandle read FStderrEvent;
|
||||||
|
property Eventer: TLEventer read FEventer write FEventer;
|
||||||
|
property OnNeedInput: TLHandleEvent read GetOnNeedInput write SetOnNeedInput;
|
||||||
|
property OnHasOutput: TLHandleEvent read GetOnHasOutput write SetOnHasOutput;
|
||||||
|
property OnHasStderr: TLHandleEvent read GetOnHasStderr write SetOnHasStderr;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
function TLInputPipeStream.Read(var Buffer; Count: longint): longint;
|
||||||
|
begin
|
||||||
|
Result := inherited;
|
||||||
|
FEvent.IgnoreRead := false;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLOutputPipeStream.Write(const Buffer; Count: longint): longint;
|
||||||
|
begin
|
||||||
|
Result := inherited;
|
||||||
|
FEvent.IgnoreWrite := false;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TLProcess.Create(AOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited;
|
||||||
|
|
||||||
|
FInputEvent := TLHandle.Create;
|
||||||
|
FOutputEvent := TLHandle.Create;
|
||||||
|
FStderrEvent := TLHandle.Create;
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TLProcess.Destroy;
|
||||||
|
begin
|
||||||
|
inherited;
|
||||||
|
FInputEvent.Free;
|
||||||
|
FOutputEvent.Free;
|
||||||
|
FStderrEvent.Free;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLProcess.CloseInput;
|
||||||
|
begin
|
||||||
|
FEventer.UnplugHandle(FInputEvent);
|
||||||
|
inherited;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLProcess.CloseOutput;
|
||||||
|
begin
|
||||||
|
FEventer.UnplugHandle(FOutputEvent);
|
||||||
|
inherited;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLProcess.CloseStderr;
|
||||||
|
begin
|
||||||
|
FEventer.UnplugHandle(FStderrEvent);
|
||||||
|
inherited;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLProcess.Execute;
|
||||||
|
begin
|
||||||
|
inherited;
|
||||||
|
|
||||||
|
if (poUsePipes in Options) and (FEventer <> nil) then
|
||||||
|
begin
|
||||||
|
if Input <> nil then
|
||||||
|
begin
|
||||||
|
FInputEvent.Handle := Input.Handle;
|
||||||
|
FInputEvent.IgnoreRead := true;
|
||||||
|
FEventer.AddHandle(FInputEvent);
|
||||||
|
end;
|
||||||
|
if Output <> nil then
|
||||||
|
begin
|
||||||
|
FOutputEvent.Handle := Output.Handle;
|
||||||
|
FOutputEvent.IgnoreWrite := true;
|
||||||
|
FEventer.AddHandle(FOutputEvent);
|
||||||
|
end;
|
||||||
|
if Stderr <> nil then
|
||||||
|
begin
|
||||||
|
FStderrEvent.Handle := Stderr.Handle;
|
||||||
|
FStderrEvent.IgnoreWrite := true;
|
||||||
|
FEventer.AddHandle(FStderrEvent);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLProcess.GetOnNeedInput: TLHandleEvent;
|
||||||
|
begin
|
||||||
|
Result := FInputEvent.OnWrite;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLProcess.GetOnHasOutput: TLHandleEvent;
|
||||||
|
begin
|
||||||
|
Result := FOutputEvent.OnRead;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLProcess.GetOnHasStderr: TLHandleEvent;
|
||||||
|
begin
|
||||||
|
Result := FStderrEvent.OnRead;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLProcess.SetOnNeedInput(NewOnInput: TLHandleEvent);
|
||||||
|
begin
|
||||||
|
FInputEvent.OnWrite := NewOnInput;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLProcess.SetOnHasOutput(NewOnOutput: TLHandleEvent);
|
||||||
|
begin
|
||||||
|
FOutputEvent.OnRead := NewOnOutput;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLProcess.SetOnHasStderr(NewOnStderr: TLHandleEvent);
|
||||||
|
begin
|
||||||
|
FStderrEvent.OnRead := NewOnStderr;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
530
utils/fppkg/lnet/lsmtp.pp
Normal file
530
utils/fppkg/lnet/lsmtp.pp
Normal file
@ -0,0 +1,530 @@
|
|||||||
|
{ lNet SMTP unit
|
||||||
|
|
||||||
|
CopyRight (C) 2005-2006 Ales Katona
|
||||||
|
|
||||||
|
This library is Free software; you can rediStribute it and/or modify it
|
||||||
|
under the terms of the GNU Library General Public License as published by
|
||||||
|
the Free Software Foundation; either version 2 of the License, or (at your
|
||||||
|
option) any later version.
|
||||||
|
|
||||||
|
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. See the GNU Library General Public License
|
||||||
|
for more details.
|
||||||
|
|
||||||
|
You should have received a Copy of the GNU Library General Public License
|
||||||
|
along with This library; if not, Write to the Free Software Foundation,
|
||||||
|
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||||
|
|
||||||
|
This license has been modified. See File LICENSE.ADDON for more inFormation.
|
||||||
|
Should you find these sources without a LICENSE File, please contact
|
||||||
|
me at ales@chello.sk
|
||||||
|
}
|
||||||
|
|
||||||
|
unit lsmtp;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
{$inline on}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, lNet, lEvents, lCommon;
|
||||||
|
|
||||||
|
type
|
||||||
|
TLSMTP = class;
|
||||||
|
TLSMTPClient = class;
|
||||||
|
|
||||||
|
TLSMTPStatus = (ssNone, ssCon, ssHelo, ssEhlo, ssMail,
|
||||||
|
ssRcpt, ssData, ssRset, ssQuit);
|
||||||
|
|
||||||
|
TLSMTPStatusSet = set of TLSMTPStatus;
|
||||||
|
|
||||||
|
TLSMTPStatusRec = record
|
||||||
|
Status: TLSMTPStatus;
|
||||||
|
Args: array[1..2] of string;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TLSMTPStatusFront }
|
||||||
|
{$DEFINE __front_type__ := TLSMTPStatusRec}
|
||||||
|
{$i lcontainersh.inc}
|
||||||
|
TLSMTPStatusFront = TLFront;
|
||||||
|
|
||||||
|
TLSMTPClientStatusEvent = procedure (aSocket: TLSocket;
|
||||||
|
const aStatus: TLSMTPStatus) of object;
|
||||||
|
|
||||||
|
TLSMTP = class(TLComponent)
|
||||||
|
protected
|
||||||
|
FConnection: TLTcp;
|
||||||
|
protected
|
||||||
|
function GetTimeout: DWord;
|
||||||
|
procedure SetTimeout(const AValue: DWord);
|
||||||
|
|
||||||
|
function GetConnected: Boolean;
|
||||||
|
|
||||||
|
function GetSocketClass: TLSocketClass;
|
||||||
|
procedure SetSocketClass(const AValue: TLSocketClass);
|
||||||
|
|
||||||
|
function GetEventer: TLEventer;
|
||||||
|
procedure SetEventer(Value: TLEventer);
|
||||||
|
public
|
||||||
|
constructor Create(aOwner: TComponent); override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
public
|
||||||
|
property Connected: Boolean read GetConnected;
|
||||||
|
property Connection: TLTcp read FConnection;
|
||||||
|
|
||||||
|
property SocketClass: TLSocketClass read GetSocketClass write SetSocketClass;
|
||||||
|
property Eventer: TLEventer read GetEventer write SetEventer;
|
||||||
|
property Timeout: DWord read GetTimeout write SetTimeout;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TLSMTPClient }
|
||||||
|
|
||||||
|
TLSMTPClient = class(TLSMTP, ILClient)
|
||||||
|
protected
|
||||||
|
FStatus: TLSMTPStatusFront;
|
||||||
|
FCommandFront: TLSMTPStatusFront;
|
||||||
|
FPipeLine: Boolean;
|
||||||
|
|
||||||
|
FOnConnect: TLSocketEvent;
|
||||||
|
FOnReceive: TLSocketEvent;
|
||||||
|
FOnDisconnect: TLSocketEvent;
|
||||||
|
FOnSuccess: TLSMTPClientStatusEvent;
|
||||||
|
FOnFailure: TLSMTPClientStatusEvent;
|
||||||
|
FOnError: TLSocketErrorEvent;
|
||||||
|
|
||||||
|
FSL: TStringList;
|
||||||
|
FStatusSet: TLSMTPStatusSet;
|
||||||
|
FMessage: string;
|
||||||
|
protected
|
||||||
|
procedure OnEr(const msg: string; aSocket: TLSocket);
|
||||||
|
procedure OnRe(aSocket: TLSocket);
|
||||||
|
procedure OnCo(aSocket: TLSocket);
|
||||||
|
procedure OnDs(aSocket: TLSocket);
|
||||||
|
protected
|
||||||
|
function CanContinue(const aStatus: TLSMTPStatus; const Arg1, Arg2: string): Boolean;
|
||||||
|
|
||||||
|
function CleanInput(var s: string): Integer;
|
||||||
|
|
||||||
|
procedure EvaluateAnswer(const Ans: string);
|
||||||
|
|
||||||
|
procedure ExecuteFrontCommand;
|
||||||
|
public
|
||||||
|
constructor Create(aOwner: TComponent); override;
|
||||||
|
destructor Destroy; override;
|
||||||
|
|
||||||
|
function Connect(const aHost: string; const aPort: Word = 25): Boolean; virtual;
|
||||||
|
function Connect: Boolean; virtual;
|
||||||
|
|
||||||
|
function Get(var aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; virtual;
|
||||||
|
function GetMessage(out msg: string; aSocket: TLSocket = nil): Integer; virtual;
|
||||||
|
|
||||||
|
procedure SendMail(const From, Recipients, Subject, Msg: string);
|
||||||
|
procedure Helo(aHost: string = '');
|
||||||
|
procedure Ehlo(aHost: string = '');
|
||||||
|
procedure Mail(const From: string);
|
||||||
|
procedure Rcpt(const RcptTo: string);
|
||||||
|
procedure Data(const Msg: string);
|
||||||
|
procedure Rset;
|
||||||
|
procedure Quit;
|
||||||
|
|
||||||
|
procedure Disconnect; override;
|
||||||
|
|
||||||
|
procedure CallAction; override;
|
||||||
|
public
|
||||||
|
property PipeLine: Boolean read FPipeLine write FPipeLine;
|
||||||
|
property StatusSet: TLSMTPStatusSet read FStatusSet write FStatusSet;
|
||||||
|
property OnConnect: TLSocketEvent read FOnConnect write FOnConnect;
|
||||||
|
property OnReceive: TLSocketEvent read FOnReceive write FOnReceive;
|
||||||
|
property OnDisconnect: TLSocketEvent read FOnDisconnect write FOnDisconnect;
|
||||||
|
property OnSuccess: TLSMTPClientStatusEvent read FOnSuccess write FOnSuccess;
|
||||||
|
property OnFailure: TLSMTPClientStatusEvent read FOnFailure write FOnFailure;
|
||||||
|
property OnError: TLSocketErrorEvent read FOnError write FOnError;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
uses
|
||||||
|
SysUtils;
|
||||||
|
|
||||||
|
const
|
||||||
|
EMPTY_REC: TLSMTPStatusRec = (Status: ssNone; Args: ('', ''));
|
||||||
|
SLE = #13#10;
|
||||||
|
|
||||||
|
{$i lcontainers.inc}
|
||||||
|
|
||||||
|
function StatusToStr(const aStatus: TLSMTPStatus): string;
|
||||||
|
const
|
||||||
|
STATAR: array[ssNone..ssQuit] of string = ('ssNone', 'ssCon', 'ssHelo', 'ssEhlo', 'ssMail',
|
||||||
|
'ssRcpt', 'ssData', 'ssRset', 'ssQuit');
|
||||||
|
begin
|
||||||
|
Result := STATAR[aStatus];
|
||||||
|
end;
|
||||||
|
|
||||||
|
function MakeStatusRec(const aStatus: TLSMTPStatus; const Arg1, Arg2: string): TLSMTPStatusRec;
|
||||||
|
begin
|
||||||
|
Result.Status := aStatus;
|
||||||
|
Result.Args[1] := Arg1;
|
||||||
|
Result.Args[2] := Arg2;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TLSMTP }
|
||||||
|
|
||||||
|
function TLSMTP.GetTimeout: DWord;
|
||||||
|
begin
|
||||||
|
Result := FConnection.Timeout;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTP.SetTimeout(const AValue: DWord);
|
||||||
|
begin
|
||||||
|
FConnection.Timeout := aValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLSMTP.GetConnected: Boolean;
|
||||||
|
begin
|
||||||
|
Result := FConnection.Connected;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLSMTP.GetSocketClass: TLSocketClass;
|
||||||
|
begin
|
||||||
|
Result := FConnection.SocketClass;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTP.SetSocketClass(const AValue: TLSocketClass);
|
||||||
|
begin
|
||||||
|
FConnection.SocketClass := AValue;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLSMTP.GetEventer: TLEventer;
|
||||||
|
begin
|
||||||
|
Result := FConnection.Eventer;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTP.SetEventer(Value: TLEventer);
|
||||||
|
begin
|
||||||
|
FConnection.Eventer := Value;
|
||||||
|
end;
|
||||||
|
|
||||||
|
constructor TLSMTP.Create(aOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited Create(aOwner);
|
||||||
|
|
||||||
|
FConnection := TLTcp.Create(nil);
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TLSMTP.Destroy;
|
||||||
|
begin
|
||||||
|
FConnection.Free;
|
||||||
|
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
{ TLSMTPClient }
|
||||||
|
|
||||||
|
constructor TLSMTPClient.Create(aOwner: TComponent);
|
||||||
|
begin
|
||||||
|
inherited Create(aOwner);
|
||||||
|
FPort := 25;
|
||||||
|
FStatusSet := []; // empty set for "ok/not-ok" Event
|
||||||
|
FSL := TStringList.Create;
|
||||||
|
FHost := '';
|
||||||
|
FMessage := '';
|
||||||
|
// {$warning TODO: fix pipelining support when server does it}
|
||||||
|
FPipeLine := False;
|
||||||
|
|
||||||
|
FConnection.OnError := @OnEr;
|
||||||
|
FConnection.OnReceive := @OnRe;
|
||||||
|
FConnection.OnConnect := @OnCo;
|
||||||
|
|
||||||
|
FStatus := TLSMTPStatusFront.Create(EMPTY_REC);
|
||||||
|
FCommandFront := TLSMTPStatusFront.Create(EMPTY_REC);
|
||||||
|
end;
|
||||||
|
|
||||||
|
destructor TLSMTPClient.Destroy;
|
||||||
|
begin
|
||||||
|
Quit;
|
||||||
|
FSL.Free;
|
||||||
|
FStatus.Free;
|
||||||
|
FCommandFront.Free;
|
||||||
|
|
||||||
|
inherited Destroy;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.OnEr(const msg: string; aSocket: TLSocket);
|
||||||
|
begin
|
||||||
|
if Assigned(FOnError) then
|
||||||
|
FOnError(msg, aSocket);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.OnRe(aSocket: TLSocket);
|
||||||
|
begin
|
||||||
|
if Assigned(FOnReceive) then
|
||||||
|
FOnReceive(aSocket);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.OnCo(aSocket: TLSocket);
|
||||||
|
begin
|
||||||
|
if Assigned(FOnConnect) then
|
||||||
|
FOnConnect(aSocket);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.OnDs(aSocket: TLSocket);
|
||||||
|
begin
|
||||||
|
if Assigned(FOnDisconnect) then
|
||||||
|
FOnDisconnect(aSocket);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLSMTPClient.CanContinue(const aStatus: TLSMTPStatus; const Arg1, Arg2: string): Boolean;
|
||||||
|
begin
|
||||||
|
Result := FPipeLine or FStatus.Empty;
|
||||||
|
if not Result then
|
||||||
|
FCommandFront.Insert(MakeStatusRec(aStatus, Arg1, Arg2));
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLSMTPClient.CleanInput(var s: string): Integer;
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
begin
|
||||||
|
FSL.Text := s;
|
||||||
|
if FSL.Count > 0 then
|
||||||
|
for i := 0 to FSL.Count-1 do
|
||||||
|
if Length(FSL[i]) > 0 then EvaluateAnswer(FSL[i]);
|
||||||
|
s := StringReplace(s, SLE, LineEnding, [rfReplaceAll]);
|
||||||
|
i := Pos('PASS', s);
|
||||||
|
if i > 0 then
|
||||||
|
s := Copy(s, 1, i-1) + 'PASS';
|
||||||
|
Result := Length(s);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.EvaluateAnswer(const Ans: string);
|
||||||
|
|
||||||
|
function GetNum: Integer;
|
||||||
|
begin
|
||||||
|
try
|
||||||
|
Result := StrToInt(Copy(Ans, 1, 3));
|
||||||
|
except
|
||||||
|
Result := -1;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function ValidResponse(const Answer: string): Boolean; inline;
|
||||||
|
begin
|
||||||
|
Result := (Length(Ans) >= 3) and
|
||||||
|
(Ans[1] in ['1'..'5']) and
|
||||||
|
(Ans[2] in ['0'..'9']) and
|
||||||
|
(Ans[3] in ['0'..'9']);
|
||||||
|
|
||||||
|
if Result then
|
||||||
|
Result := (Length(Ans) = 3) or ((Length(Ans) > 3) and (Ans[4] = ' '));
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure Eventize(const aStatus: TLSMTPStatus; const Res: Boolean);
|
||||||
|
begin
|
||||||
|
if Res then begin
|
||||||
|
if Assigned(FOnSuccess) and (aStatus in FStatusSet) then
|
||||||
|
FOnSuccess(FConnection.Iterator, aStatus);
|
||||||
|
end else begin
|
||||||
|
if Assigned(FOnFailure) and (aStatus in FStatusSet) then
|
||||||
|
FOnFailure(FConnection.Iterator, aStatus);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
var
|
||||||
|
x: Integer;
|
||||||
|
begin
|
||||||
|
x := GetNum;
|
||||||
|
if ValidResponse(Ans) and not FStatus.Empty then
|
||||||
|
case FStatus.First.Status of
|
||||||
|
ssCon,
|
||||||
|
ssHelo,
|
||||||
|
ssEhlo: case x of
|
||||||
|
200..299: begin
|
||||||
|
Eventize(FStatus.First.Status, True);
|
||||||
|
FStatus.Remove;
|
||||||
|
end;
|
||||||
|
else begin
|
||||||
|
Eventize(FStatus.First.Status, False);
|
||||||
|
Disconnect;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
ssMail,
|
||||||
|
ssRcpt: begin
|
||||||
|
Eventize(FStatus.First.Status, (x >= 200) and (x < 299));
|
||||||
|
FStatus.Remove;
|
||||||
|
end;
|
||||||
|
|
||||||
|
ssData: case x of
|
||||||
|
200..299: begin
|
||||||
|
Eventize(FStatus.First.Status, True);
|
||||||
|
FStatus.Remove;
|
||||||
|
end;
|
||||||
|
300..399: if Length(FMessage) > 0 then begin
|
||||||
|
FConnection.SendMessage(FMessage);
|
||||||
|
FMessage := '';
|
||||||
|
end;
|
||||||
|
else begin
|
||||||
|
Eventize(FStatus.First.Status, False);
|
||||||
|
FStatus.Remove;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
ssRset: begin
|
||||||
|
Eventize(FStatus.First.Status, (x >= 200) and (x < 299));
|
||||||
|
FStatus.Remove;
|
||||||
|
end;
|
||||||
|
|
||||||
|
ssQuit: begin
|
||||||
|
Eventize(FStatus.First.Status, (x >= 200) and (x < 299));
|
||||||
|
FStatus.Remove;
|
||||||
|
if Assigned(FOnDisconnect) then
|
||||||
|
FOnDisconnect(FConnection.Iterator);
|
||||||
|
Disconnect;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
if FStatus.Empty and not FCommandFront.Empty then
|
||||||
|
ExecuteFrontCommand;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.ExecuteFrontCommand;
|
||||||
|
begin
|
||||||
|
with FCommandFront.First do
|
||||||
|
case Status of
|
||||||
|
ssHelo: Helo(Args[1]);
|
||||||
|
ssEhlo: Ehlo(Args[1]);
|
||||||
|
ssMail: Mail(Args[1]);
|
||||||
|
ssRcpt: Rcpt(Args[1]);
|
||||||
|
ssData: Data(Args[1]);
|
||||||
|
ssRset: Rset;
|
||||||
|
ssQuit: Quit;
|
||||||
|
end;
|
||||||
|
FCommandFront.Remove;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLSMTPClient.Connect(const aHost: string; const aPort: Word = 25): Boolean;
|
||||||
|
begin
|
||||||
|
Result := False;
|
||||||
|
Disconnect;
|
||||||
|
if FConnection.Connect(aHost, aPort) then begin
|
||||||
|
FHost := aHost;
|
||||||
|
FPort := aPort;
|
||||||
|
FStatus.Insert(MakeStatusRec(ssCon, '', ''));
|
||||||
|
Result := True;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLSMTPClient.Connect: Boolean;
|
||||||
|
begin
|
||||||
|
Result := Connect(FHost, FPort);
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLSMTPClient.Get(var aData; const aSize: Integer; aSocket: TLSocket): Integer;
|
||||||
|
var
|
||||||
|
s: string;
|
||||||
|
begin
|
||||||
|
Result := FConnection.Get(aData, aSize, aSocket);
|
||||||
|
if Result > 0 then begin
|
||||||
|
SetLength(s, Result);
|
||||||
|
Move(aData, PChar(s)^, Result);
|
||||||
|
CleanInput(s);
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
function TLSMTPClient.GetMessage(out msg: string; aSocket: TLSocket): Integer;
|
||||||
|
begin
|
||||||
|
Result := FConnection.GetMessage(msg, aSocket);
|
||||||
|
if Result > 0 then
|
||||||
|
Result := CleanInput(msg);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.SendMail(const From, Recipients, Subject, Msg: string);
|
||||||
|
var
|
||||||
|
i: Integer;
|
||||||
|
begin
|
||||||
|
if (Length(Recipients) > 0) and (Length(From) > 0) then begin
|
||||||
|
Mail(From);
|
||||||
|
FSL.CommaText := StringReplace(Recipients, ' ', ',', [rfReplaceAll]);
|
||||||
|
for i := 0 to FSL.Count-1 do
|
||||||
|
Rcpt(FSL[i]);
|
||||||
|
Data('From: ' + From + SLE + 'Subject: ' + Subject + SLE + 'To: ' + FSL.CommaText + SLE + Msg);
|
||||||
|
Rset;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.Helo(aHost: string = '');
|
||||||
|
begin
|
||||||
|
if Length(Host) = 0 then
|
||||||
|
aHost := FHost;
|
||||||
|
if CanContinue(ssHelo, aHost, '') then begin
|
||||||
|
FConnection.SendMessage('HELO ' + aHost + SLE);
|
||||||
|
FStatus.Insert(MakeStatusRec(ssHelo, '', ''));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.Ehlo(aHost: string = '');
|
||||||
|
begin
|
||||||
|
if Length(aHost) = 0 then
|
||||||
|
aHost := FHost;
|
||||||
|
if CanContinue(ssEhlo, aHost, '') then begin
|
||||||
|
FConnection.SendMessage('EHLO ' + aHost + SLE);
|
||||||
|
FStatus.Insert(MakeStatusRec(ssEhlo, '', ''));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.Mail(const From: string);
|
||||||
|
begin
|
||||||
|
if CanContinue(ssMail, From, '') then begin
|
||||||
|
FConnection.SendMessage('MAIL FROM:' + '<' + From + '>' + SLE);
|
||||||
|
FStatus.Insert(MakeStatusRec(ssMail, '', ''));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.Rcpt(const RcptTo: string);
|
||||||
|
begin
|
||||||
|
if CanContinue(ssRcpt, RcptTo, '') then begin
|
||||||
|
FConnection.SendMessage('RCPT TO:' + '<' + RcptTo + '>' + SLE);
|
||||||
|
FStatus.Insert(MakeStatusRec(ssRcpt, '', ''));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.Data(const Msg: string);
|
||||||
|
begin
|
||||||
|
if CanContinue(ssData, Msg, '') then begin
|
||||||
|
// TODO: clean SLEs and '.' on line starts
|
||||||
|
FMessage := Msg + SLE + '.' + SLE;
|
||||||
|
FConnection.SendMessage('DATA' + SLE);
|
||||||
|
FStatus.Insert(MakeStatusRec(ssData, '', ''));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.Rset;
|
||||||
|
begin
|
||||||
|
if CanContinue(ssRset, '', '') then begin
|
||||||
|
FConnection.SendMessage('RSET' + SLE);
|
||||||
|
FStatus.Insert(MakeStatusRec(ssRset, '', ''));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.Quit;
|
||||||
|
begin
|
||||||
|
if CanContinue(ssQuit, '', '') then begin
|
||||||
|
FConnection.SendMessage('QUIT' + SLE);
|
||||||
|
FStatus.Insert(MakeStatusRec(ssQuit, '', ''));
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.Disconnect;
|
||||||
|
begin
|
||||||
|
FConnection.Disconnect;
|
||||||
|
FStatus.Clear;
|
||||||
|
FCommandFront.Clear;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLSMTPClient.CallAction;
|
||||||
|
begin
|
||||||
|
FConnection.CallAction;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
21
utils/fppkg/lnet/lspawnfcgi.pp
Normal file
21
utils/fppkg/lnet/lspawnfcgi.pp
Normal file
@ -0,0 +1,21 @@
|
|||||||
|
unit lSpawnFCGI;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Sockets, lNet, lCommon;
|
||||||
|
|
||||||
|
function SpawnFCGIProcess(App, Enviro: string; const aPort: Word): Integer;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{$ifdef UNIX}
|
||||||
|
{$i lspawnfcgiunix.inc}
|
||||||
|
{$else}
|
||||||
|
{$i lspawnfcgiwin.inc}
|
||||||
|
{$endif}
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
61
utils/fppkg/lnet/ltimer.pp
Normal file
61
utils/fppkg/lnet/ltimer.pp
Normal file
@ -0,0 +1,61 @@
|
|||||||
|
unit ltimer;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
interface
|
||||||
|
|
||||||
|
uses
|
||||||
|
Classes, SysUtils;
|
||||||
|
|
||||||
|
type
|
||||||
|
|
||||||
|
{ TLTimer }
|
||||||
|
|
||||||
|
TLTimer = class(TObject)
|
||||||
|
protected
|
||||||
|
FOnTimer: TNotifyEvent;
|
||||||
|
FInterval: TDateTime;
|
||||||
|
FStarted: TDateTime;
|
||||||
|
FOneShot: Boolean;
|
||||||
|
FEnabled: Boolean;
|
||||||
|
|
||||||
|
function GetInterval: Integer;
|
||||||
|
procedure SetInterval(const aValue: Integer);
|
||||||
|
public
|
||||||
|
procedure CallAction;
|
||||||
|
property Enabled: Boolean read FEnabled write FEnabled;
|
||||||
|
property Interval: Integer read GetInterval write SetInterval;
|
||||||
|
property OneShot: Boolean read FOneShot write FOneShot;
|
||||||
|
property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
|
||||||
|
end;
|
||||||
|
|
||||||
|
implementation
|
||||||
|
|
||||||
|
{ TLTimer }
|
||||||
|
|
||||||
|
function TLTimer.GetInterval: Integer;
|
||||||
|
begin
|
||||||
|
Result := Round(FInterval * MSecsPerDay);
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLTimer.SetInterval(const aValue: Integer);
|
||||||
|
begin
|
||||||
|
FInterval := AValue / MSecsPerDay;
|
||||||
|
FStarted := Now;
|
||||||
|
FEnabled := true;
|
||||||
|
end;
|
||||||
|
|
||||||
|
procedure TLTimer.CallAction;
|
||||||
|
begin
|
||||||
|
if FEnabled and Assigned(FOnTimer) and (Now - FStarted >= FInterval) then
|
||||||
|
begin
|
||||||
|
FOnTimer(Self);
|
||||||
|
if not FOneShot then
|
||||||
|
FStarted := Now
|
||||||
|
else
|
||||||
|
FEnabled := false;
|
||||||
|
end;
|
||||||
|
end;
|
||||||
|
|
||||||
|
end.
|
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user