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

* re-add some somehow missed units, update to latest

Browse Source 
git-svn-id: trunk@5857 -
This commit is contained in:
Almindor 2007-01-08 22:16:06 +00:00
parent b6b9582d8e
commit 2ddc5fed76
14 changed files with 4391 additions and 1465 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
.gitattributes vendored
View File

@ -8136,18 +8136,26 @@ utils/fppkg/fppkg.pp svneol=native#text/plain
utils/fppkg/fprepos.pp svneol=native#text/plain
utils/fppkg/fpxmlrep.pp svneol=native#text/plain
utils/fppkg/lnet/LICENSE -text
utils/fppkg/lnet/LICENSE.ADDON -text
utils/fppkg/lnet/fastcgi.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/lcontainersh.inc 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/lfastcgi.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/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/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/openssl.pp -text svneol=unset#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/lkqueueeventer.inc svneol=native#text/plain

19
utils/fppkg/lnet/LICENSE.ADDON Normal file
View 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

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

@ -317,7 +317,7 @@ function TLEventer.Bail(const msg: string; const Ernum: Integer): Boolean;
begin
Result := False; // always false, substitute for caller's result
if Assigned(FOnError) then
FOnError(msg + ': ' + LStrError(Ernum), Self);
FOnError(msg + '[' + IntToStr(Ernum) + ']: ' + LStrError(Ernum), Self);
end;
procedure TLEventer.AddForFree(aHandle: TLHandle);

910
utils/fppkg/lnet/lfastcgi.pp Normal file
View 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.

60
utils/fppkg/lnet/lftp.pp
View File

@ -35,9 +35,9 @@ type
TLFTP = class;
TLFTPClient = class;
TLFTPStatus = (fsNone, fsCon, fsAuth, fsPasv, fsPort, fsList, fsRetr, fsStor,
fsType, fsCWD, fsMKD, fsRMD, fsDEL, fsRNFR, fsRNTO, fsSYS,
fsFeat, fsPWD, fsHelp, fsLast);
TLFTPStatus = (fsNone, fsCon, fsAuth, fsPass, fsPasv, fsPort, fsList, fsRetr,
fsStor, fsType, fsCWD, fsMKD, fsRMD, fsDEL, fsRNFR, fsRNTO,
fsSYS, fsFeat, fsPWD, fsHelp, fsLast);
TLFTPStatusSet = set of TLFTPStatus;
@ -131,6 +131,7 @@ type
procedure OnControlEr(const msg: string; aSocket: TLSocket);
procedure OnControlRe(aSocket: TLSocket);
procedure OnControlCo(aSocket: TLSocket);
procedure OnControlDs(aSocket: TLSocket);
function GetTransfer: Boolean;
@ -170,6 +171,8 @@ type
function Authenticate(const aUsername, aPassword: string): Boolean;
function SendPassword(const aPassword: string): Boolean;
function GetData(var aData; const aSize: Integer): Integer;
function GetDataMessage: string;
@ -211,6 +214,8 @@ type
property OnFailure: TLFTPClientStatusEvent read FOnFailure write FOnFailure;
end;
function FTPStatusToStr(const aStatus: TLFTPStatus): string;
implementation
uses
@ -222,7 +227,7 @@ const
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',
'Store', 'Type', 'CWD', 'MKDIR',
'RMDIR', 'Delete', 'RenameFrom',
@ -258,13 +263,18 @@ begin
Result.Args[2] := Arg2;
end;
function FTPStatusToStr(const aStatus: TLFTPStatus): string;
begin
Result := FTPStatusStr[aStatus];
end;
{$i lcontainers.inc}
{ TLFTP }
function TLFTP.GetConnected: Boolean;
begin
Result := FControl.Connected;
Result := FControl.Connected;
end;
function TLFTP.GetTimeout: DWord;
@ -331,6 +341,7 @@ begin
FControl.OnReceive := @OnControlRe;
FControl.OnConnect := @OnControlCo;
FControl.OnError := @OnControlEr;
FControl.OnDisconnect := @OnControlDs;
FData.OnReceive := @OnRe;
FData.OnDisconnect := @OnDs;
@ -372,7 +383,6 @@ end;
procedure TLFTPClient.OnDs(aSocket: TLSocket);
begin
// TODO: figure it out brainiac
FSending := False;
Writedbg(['Disconnected']);
end;
@ -409,6 +419,12 @@ begin
FOnConnect(aSocket);
end;
procedure TLFTPClient.OnControlDs(aSocket: TLSocket);
begin
if Assigned(FOnError) then
FOnError('Connection lost', aSocket);
end;
function TLFTPClient.GetTransfer: Boolean;
begin
Result := FData.Connected;
@ -586,10 +602,22 @@ begin
FStatus.Remove;
end;
331,
332: begin
FStatusFlags[FStatus.First.Status] := False;
FControl.SendMessage('PASS ' + FPassword + FLE);
end;
332: SendPassword(FPassword);
else
begin
FStatusFlags[FStatus.First.Status] := False;
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;
else
begin
FStatusFlags[FStatus.First.Status] := False;
@ -819,6 +847,7 @@ begin
case Status of
fsNone : Exit;
fsAuth : Authenticate(Args[1], Args[2]);
fsPass : SendPassword(Args[1]);
fsList : List(Args[1]);
fsRetr : Retrieve(Args[1]);
fsStor : Put(Args[1]);
@ -909,6 +938,17 @@ begin
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;
begin
Result := not FPipeLine;

2264
utils/fppkg/lnet/lhttp.pp Normal file
View File

File diff suppressed because it is too large Load Diff

232
utils/fppkg/lnet/lhttputil.pp Normal file
View 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
View 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.

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

@ -440,7 +440,7 @@ procedure TLSocket.LogError(const msg: string; const ernum: Integer);
begin
if Assigned(FOnError) then
if ernum > 0 then
FOnError(Self, msg + ': ' + LStrError(ernum))
FOnError(Self, msg + '[' + IntToStr(ernum) + ']: ' + LStrError(ernum))
else
FOnError(Self, msg);
end;

185
utils/fppkg/lnet/lprocess.pp Normal file
View 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
View 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
View 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
View 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.

1452
utils/fppkg/lnet/openssl.pp
View File

File diff suppressed because it is too large Load Diff