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

* update lNet to 0.6.4

Browse Source 
git-svn-id: trunk@15275 -
This commit is contained in:
Almindor 2010-05-13 21:19:47 +00:00
parent 34cf323f7a
commit ee598d6f67
24 changed files with 1690 additions and 578 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -11455,7 +11455,7 @@ 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/fastcgi_base.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
@ -11476,6 +11476,7 @@ 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/lws2tcpip.pp svneol=native#text/pascal
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

2
utils/fppkg/lnet/fastcgi.pp → utils/fppkg/lnet/fastcgi_base.pp
View File

@ -1,4 +1,4 @@
unit fastcgi;
unit fastcgi_base;
interface

190
utils/fppkg/lnet/lcommon.pp
View File

@ -1,6 +1,6 @@
{ lCommon
CopyRight (C) 2004-2007 Ales Katona
CopyRight (C) 2004-2008 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
@ -36,6 +36,8 @@ const
SOL_SOCKET = $ffff;
LMSG = 0;
SOCKET_ERROR = WinSock2.SOCKET_ERROR;
SHUT_RDWR = SD_BOTH;
SHUT_WR = SD_SEND;
{$ENDIF}
{$IFDEF OS2}
@ -69,7 +71,41 @@ const
{$ENDIF}
{ Default Values }
LDEFAULT_BACKLOG = 5;
BUFFER_SIZE = 65536;
BUFFER_SIZE = 262144;
{ Net types }
LAF_INET = AF_INET;
LAF_INET6 = AF_INET6;
{ Address constants }
LADDR_ANY = '0.0.0.0';
LADDR_BR = '255.255.255.255';
LADDR_LO = '127.0.0.1';
LADDR6_ANY = '::0';
LADDR6_LO = '::1';
{ ICMP }
LICMP_ECHOREPLY = 0;
LICMP_UNREACH = 3;
LICMP_ECHO = 8;
LICMP_TIME_EXCEEDED = 11;
{ Protocols }
LPROTO_IP = 0;
LPROTO_ICMP = 1;
LPROTO_IGMP = 2;
LPROTO_TCP = 6;
LPROTO_UDP = 17;
LPROTO_IPV6 = 41;
LPROTO_ICMPV6 = 58;
LPROTO_RAW = 255;
LPROTO_MAX = 256;
type
{ TLSocketAddress }
TLSocketAddress = record
case Integer of
LAF_INET : (IPv4: TInetSockAddr);
LAF_INET6 : (IPv6: TInetSockAddr6);
end;
{ Base functions }
{$IFNDEF UNIX}
@ -82,13 +118,18 @@ const
{ DNS }
function GetHostName(const Address: string): string;
function GetHostIP(const Name: string): string;
function GetHostName6(const Address: string): string;
function GetHostIP6(const Name: string): string;
function LStrError(const Ernum: Longint; const UseUTF8: Boolean = False): string;
function LSocketError: Longint;
function SetBlocking(const aHandle: Integer; const aValue: Boolean): Boolean;
// function SetNoDelay(const aHandle: Integer; const aValue: Boolean): Boolean;
function IsBlockError(const anError: Integer): Boolean; inline;
function IsNonFatalError(const anError: Integer): Boolean; inline;
function IsPipeError(const anError: Integer): Boolean; inline;
function TZSeconds: Integer; inline;
@ -97,18 +138,18 @@ const
function StrToNetAddr(const IP: string): Cardinal; inline;
function NetAddrToStr(const Entry: Cardinal): string; inline;
procedure FillAddressInfo(var aAddrInfo: TInetSockAddr; const aFamily: sa_family_t;
const Address: string; const aPort: Word); inline;
procedure FillAddressInfo(var aAddrInfo: TLSocketAddress; const aFamily: sa_family_t;
const Address: string; const aPort: Word);
implementation
uses
StrUtils, lNet
StrUtils
{$IFNDEF UNIX}
{$IFDEF WINDOWS}
, Windows;
, Windows, lws2tcpip;
{$IFDEF WINCE}
@ -248,6 +289,45 @@ begin
end;
end;
function GetHostName6(const Address: string): string;
var
H: TAddrInfo;
R: PAddrInfo;
n: Integer;
begin
Result := '';
ZeroMemory(@H, SizeOf(H));
H.ai_flags := AI_NUMERICHOST;
H.ai_family := AF_INET6;
H.ai_protocol := PF_INET6;
H.ai_socktype := SOCK_STREAM;
n := getaddrinfo(pChar(Address), nil, @H, R);
if n <> 0 then
Exit;
Result := R^.ai_canonname;
freeaddrinfo(R);
end;
function GetHostIP6(const Name: string): string;
var
H: TAddrInfo;
R: PAddrInfo;
n: Integer;
begin
Result := '';
ZeroMemory(@H, SizeOf(H));
H.ai_family := AF_INET6;
H.ai_protocol := PF_INET6;
H.ai_socktype := SOCK_STREAM;
n := getaddrinfo(pChar(Name), nil, @H, R);
if n <> 0 then
Exit;
Result := NetAddrToStr6(sockets.in6_addr(R^.ai_addr^));
freeaddrinfo(R);
end;
function SetBlocking(const aHandle: Integer; const aValue: Boolean): Boolean;
const
BlockAr: array[Boolean] of DWord = (1, 0);
@ -265,6 +345,20 @@ begin
Result := anError = WSAEWOULDBLOCK;
end;
function IsNonFatalError(const anError: Integer): Boolean; inline;
begin
Result := (anError = WSAEINVAL) or (anError = WSAEFAULT)
or (anError = WSAEOPNOTSUPP) or (anError = WSAEMSGSIZE)
or (anError = WSAEADDRNOTAVAIL) or (anError = WSAEAFNOSUPPORT)
or (anError = WSAEDESTADDRREQ);
end;
function IsPipeError(const anError: Integer): Boolean; inline;
begin
{$WARNING check these ambiguous errors}
Result := anError = WSAECONNRESET;
end;
{$ELSE}
// unix
@ -308,6 +402,28 @@ begin
Result := NetAddrToStr(Cardinal(HE.Addr));
end;
function GetHostName6(const Address: string): string;
var
HE: THostEntry6;
begin
Result := '';
{ if GetHostByAddr(StrToHostAddr6(Address), HE) then
Result := HE.Name
else} if ResolveHostbyAddr6(StrToHostAddr6(Address), HE) then
Result := HE.Name;
end;
function GetHostIP6(const Name: string): string;
var
HE: THostEntry6;
begin
Result := '';
{ if GetHostByName(Name, HE) then
Result := HostAddrToStr6(HE.Addr) // for localhost
else} if ResolveHostByName6(Name, HE) then
Result := NetAddrToStr6(HE.Addr);
end;
function SetBlocking(const aHandle: Integer; const aValue: Boolean): Boolean;
var
opt: cInt;
@ -331,6 +447,18 @@ begin
Result := (anError = ESysEWOULDBLOCK) or (anError = ESysENOBUFS);
end;
function IsNonFatalError(const anError: Integer): Boolean; inline;
begin
Result := (anError = ESysEINTR) or (anError = ESysEMSGSIZE)
or (anError = ESysEFAULT) or (anError = ESysEINVAL)
or (anError = ESysEOPNOTSUPP);
end;
function IsPipeError(const anError: Integer): Boolean; inline;
begin
Result := anError = ESysEPIPE;
end;
function TZSeconds: Integer; inline;
begin
Result := unixutil.TZSeconds;
@ -338,6 +466,19 @@ end;
{$ENDIF}
{function SetNoDelay(const aHandle: Integer; const aValue: Boolean): Boolean;
var
opt: cInt = 0;
begin
if aValue then
opt := 1;
if fpsetsockopt(aHandle, IPPROTO_TCP, TCP_NODELAY, opt, SizeOf(opt)) < 0 then
Exit(False);
Result := True;
end;}
function StrToHostAddr(const IP: string): Cardinal; inline;
begin
Result := Cardinal(Sockets.StrToHostAddr(IP));
@ -358,15 +499,36 @@ begin
Result := Sockets.NetAddrToStr(in_addr(Entry));
end;
procedure FillAddressInfo(var aAddrInfo: TInetSockAddr; const aFamily: sa_family_t;
const Address: string; const aPort: Word); inline;
function IsIP6Empty(const aIP6: TInetSockAddr6): Boolean; inline;
var
i: Integer;
begin
aAddrInfo.family := AF_INET;
aAddrInfo.Port := htons(aPort);
aAddrInfo.Addr := StrToNetAddr(Address);
if (Address <> LADDR_ANY) and (aAddrInfo.Addr = 0) then
aAddrInfo.Addr := StrToNetAddr(GetHostIP(Address));
Result := True;
for i := 0 to High(aIP6.sin6_addr.u6_addr32) do
if aIP6.sin6_addr.u6_addr32[i] <> 0 then
Exit(False);
end;
procedure FillAddressInfo(var aAddrInfo: TLSocketAddress; const aFamily: sa_family_t;
const Address: string; const aPort: Word);
begin
aAddrInfo.IPv4.family := aFamily;
aAddrInfo.IPv4.Port := htons(aPort);
case aFamily of
LAF_INET :
begin
aAddrInfo.IPv4.Addr := StrToNetAddr(Address);
if (Address <> LADDR_ANY) and (aAddrInfo.IPv4.Addr = 0) then
aAddrInfo.IPv4.Addr := StrToNetAddr(GetHostIP(Address));
end;
LAF_INET6 :
begin
aAddrInfo.IPv6.sin6_addr := StrToNetAddr6(Address);
if (Address <> LADDR6_ANY) and (IsIP6Empty(aAddrInfo.IPv6)) then
aAddrInfo.IPv6.sin6_addr := StrToNetAddr6(GetHostIP6(Address));
end;
end;
end;

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

@ -1,6 +1,6 @@
{ Control stack
CopyRight (C) 2004-2007 Ales Katona
CopyRight (C) 2004-2008 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

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

@ -1,6 +1,6 @@
{ lNet Events abstration
CopyRight (C) 2006-2007 Ales Katona
CopyRight (C) 2006-2008 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
@ -32,11 +32,11 @@ interface
uses
{$ifdef Linux}
{$undef nochoice} // undefine for all "Optimized" targets
Linux, Contnrs,
Linux, Contnrs, Errors,
{$endif}
{$ifdef BSD}
{$undef nochoice}
BSD,
BSD, Errors,
{$endif}
{$i sys/osunits.inc}
@ -66,6 +66,7 @@ type
FNext: TLHandle;
FFreeNext: TLHandle;
FInternalData: Pointer;
procedure SetIgnoreError(const aValue: Boolean);
procedure SetIgnoreWrite(const aValue: Boolean);
procedure SetIgnoreRead(const aValue: Boolean);
@ -140,6 +141,7 @@ type
FFreeRoot: TLHandle; // the root of "free" list if any
FFreeIter: TLHandle; // the last of "free" list if any
FInLoop: Boolean;
function GetCount: Integer; virtual;
function GetTimeout: Integer; virtual;
procedure SetTimeout(const Value: Integer); virtual;
function Bail(const msg: string; const Ernum: Integer): Boolean;
@ -151,13 +153,14 @@ type
function GetInternalData(aHandle: TLHandle): Pointer;
procedure SetInternalData(aHandle: TLHandle; const aData: Pointer);
procedure SetHandleEventer(aHandle: TLHandle);
procedure InternalUnplugHandle(aHandle: TLHandle); virtual;
public
constructor Create; virtual;
destructor Destroy; override;
function AddHandle(aHandle: TLHandle): Boolean; virtual;
function CallAction: Boolean; virtual;
procedure RemoveHandle(aHandle: TLHandle); virtual;
procedure UnplugHandle(aHandle: TLHandle); virtual;
procedure UnplugHandle(aHandle: TLHandle);
procedure UnregisterHandle(aHandle: TLHandle); virtual;
procedure LoadFromEventer(aEventer: TLEventer); virtual;
procedure Clear;
@ -165,7 +168,7 @@ type
procedure DeleteRef;
property Timeout: Integer read GetTimeout write SetTimeout;
property OnError: TLEventerErrorEvent read FOnError write FOnError;
property Count: Integer read FCount;
property Count: Integer read GetCount;
end;
TLEventerClass = class of TLEventer;
@ -189,12 +192,16 @@ type
{$i sys/lepolleventerh.inc}
function BestEventerClass: TLEventerClass;
implementation
uses
syncobjs,
lCommon;
var
CS: TCriticalSection;
{ TLHandle }
procedure TLHandle.SetIgnoreError(const aValue: Boolean);
@ -244,15 +251,19 @@ end;
destructor TLHandle.Destroy;
begin
if Assigned(FEventer) then
FEventer.UnplugHandle(Self);
FEventer.InternalUnplugHandle(Self);
end;
procedure TLHandle.Free;
begin
CS.Enter;
if Assigned(FEventer) and FEventer.FInLoop then
FEventer.AddForFree(Self)
else
inherited Free;
CS.Leave;
end;
{ TLTimer }
@ -302,6 +313,11 @@ begin
Clear;
end;
function TLEventer.GetCount: Integer;
begin
Result := FCount;
end;
function TLEventer.GetTimeout: Integer;
begin
Result := 0;
@ -376,6 +392,29 @@ begin
aHandle.FEventer := Self;
end;
procedure TLEventer.InternalUnplugHandle(aHandle: TLHandle);
begin
if aHandle.FEventer = Self then begin
if aHandle.FEventer.FInLoop then begin
aHandle.FEventer.AddForFree(aHandle);
Exit;
end;
aHandle.FEventer := nil; // avoid recursive AV
if Assigned(aHandle.FPrev) then begin
aHandle.FPrev.FNext := aHandle.FNext;
if Assigned(aHandle.FNext) then
aHandle.FNext.FPrev := aHandle.FPrev;
end else if Assigned(aHandle.FNext) then begin
aHandle.FNext.FPrev := aHandle.FPrev;
if aHandle = FRoot then
FRoot := aHandle.FNext;
end else FRoot := nil;
if FCount > 0 then
Dec(FCount);
end;
end;
function TLEventer.AddHandle(aHandle: TLHandle): Boolean;
begin
Result := False;
@ -409,20 +448,11 @@ end;
procedure TLEventer.UnplugHandle(aHandle: TLHandle);
begin
if aHandle.FEventer = Self then begin
aHandle.FEventer := nil; // avoid recursive AV
if Assigned(aHandle.FPrev) then begin
aHandle.FPrev.FNext := aHandle.FNext;
if Assigned(aHandle.FNext) then
aHandle.FNext.FPrev := aHandle.FPrev;
end else if Assigned(aHandle.FNext) then begin
aHandle.FNext.FPrev := aHandle.FPrev;
if aHandle = FRoot then
FRoot := aHandle.FNext;
end else FRoot := nil;
if FCount > 0 then
Dec(FCount);
end;
CS.Enter;
InternalUnplugHandle(aHandle);
CS.Leave;
end;
procedure TLEventer.UnregisterHandle(aHandle: TLHandle);
@ -502,7 +532,8 @@ end;
function TLSelectEventer.CallAction: Boolean;
var
Temp, Temp2: TLHandle;
MaxHandle, n: Integer;
n: Integer;
MaxHandle: THandle;
TempTime: TTimeVal;
begin
if FInLoop then
@ -583,4 +614,10 @@ end;
{$endif}
initialization
CS := TCriticalSection.Create;
finalization
CS.Free;
end.

8
utils/fppkg/lnet/lfastcgi.pp
View File

@ -1,6 +1,6 @@
{ FastCGI requester support for lNet
Copyright (C) 2006-2007 Micha Nelissen
Copyright (C) 2006-2008 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
@ -28,7 +28,7 @@ unit lfastcgi;
interface
uses
classes, sysutils, fastcgi, lnet, levents, lstrbuffer, ltimer;
classes, sysutils, fastcgi_base, lnet, levents, lstrbuffer, ltimer;
type
TLFastCGIClient = class;
@ -123,7 +123,7 @@ type
function Connect: Boolean; override;
procedure ConnectEvent(ASocket: TLHandle); override;
procedure DisconnectEvent(ASocket: TLHandle); override;
procedure ErrorEvent(const Msg: string; ASocket: TLHandle); override;
procedure ErrorEvent(ASocket: TLHandle; const msg: string); override;
function CreateRequester: TLFastCGIRequest;
procedure HandleGetValuesResult;
procedure HandleReceive(ASocket: TLSocket);
@ -572,7 +572,7 @@ begin
Connect;
end;
procedure TLFastCGIClient.ErrorEvent(const Msg: string; ASocket: TLHandle);
procedure TLFastCGIClient.ErrorEvent(ASocket: TLHandle; const msg: string);
begin
if (FState = fsConnectingAgain)
or ((FState = fsConnecting) and (FPool.FSpawnState = ssSpawned)) then

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

@ -1,4 +1,4 @@
{ lFTP CopyRight (C) 2005-2007 Ales Katona
{ lFTP CopyRight (C) 2005-2008 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
@ -67,19 +67,25 @@ type
FData: TLTcp;//TLTcpList;
FSending: Boolean;
FTransferMethod: TLFTPTransferMethod;
FFeatureList: TStringList;
FFeatureString: string;
function GetConnected: Boolean; virtual;
function GetTimeout: Integer;
procedure SetTimeout(const Value: Integer);
function GetSession: TLSession;
procedure SetSession(const AValue: TLSession);
procedure SetCreator(AValue: TLComponent); override;
function GetSocketClass: TLSocketClass;
procedure SetSocketClass(Value: TLSocketClass);
public
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
function Get(var aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; virtual; abstract;
function Get(out aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; virtual; abstract;
function GetMessage(out msg: string; aSocket: TLSocket = nil): Integer; virtual; abstract;
function Send(const aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; virtual; abstract;
@ -92,6 +98,8 @@ type
property ControlConnection: TLTelnetClient read FControl;
property DataConnection: TLTCP read FData;
property TransferMethod: TLFTPTransferMethod read FTransferMethod write FTransferMethod default ftPassive;
property Session: TLSession read GetSession write SetSession;
property FeatureList: TStringList read FFeatureList;
end;
{ TLFTPTelnetClient }
@ -111,6 +119,7 @@ type
FExpectedBinary: Boolean;
FPipeLine: Boolean;
FPassword: string;
FPWD: string;
FStatusFlags: array[TLFTPStatus] of Boolean;
FOnError: TLSocketErrorEvent;
@ -135,12 +144,17 @@ type
procedure OnControlRe(aSocket: TLSocket);
procedure OnControlCo(aSocket: TLSocket);
procedure OnControlDs(aSocket: TLSocket);
procedure ClearStatusFlags;
function GetCurrentStatus: TLFTPStatus;
function GetTransfer: Boolean;
function GetEcho: Boolean;
procedure SetEcho(const Value: Boolean);
procedure ParsePWD(const s: string);
function GetConnected: Boolean; override;
function GetBinary: Boolean;
@ -152,6 +166,7 @@ type
procedure SetStartPor(const Value: Word);
procedure EvaluateFeatures;
procedure EvaluateAnswer(const Ans: string);
procedure PasvPort;
@ -166,7 +181,7 @@ type
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
function Get(var aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; override;
function Get(out aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; override;
function GetMessage(out msg: string; aSocket: TLSocket = nil): Integer; override;
function Send(const aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; override;
@ -177,7 +192,7 @@ type
function Authenticate(const aUsername, aPassword: string): Boolean;
function GetData(var aData; const aSize: Integer): Integer;
function GetData(out aData; const aSize: Integer): Integer;
function GetDataMessage: string;
function Retrieve(const FileName: string): Boolean;
@ -193,11 +208,11 @@ type
procedure List(const FileName: string = '');
procedure Nlst(const FileName: string = '');
procedure SystemInfo;
procedure FeatureList;
procedure ListFeatures;
procedure PresentWorkingDirectory;
procedure Help(const Arg: string);
procedure Disconnect; override;
procedure Disconnect(const Forced: Boolean = True); override;
procedure CallAction; override;
public
@ -208,6 +223,8 @@ type
property Echo: Boolean read GetEcho write SetEcho;
property StartPort: Word read FStartPort write FStartPort default DEFAULT_FTP_PORT;
property Transfer: Boolean read GetTransfer;
property CurrentStatus: TLFTPStatus read GetCurrentStatus;
property PresentWorkingDirectoryString: string read FPWD;
property OnError: TLSocketErrorEvent read FOnError write FOnError;
property OnConnect: TLSocketEvent read FOnConnect write FOnConnect;
@ -223,7 +240,7 @@ type
implementation
uses
SysUtils;
SysUtils, Math;
const
FLE = #13#10;
@ -275,6 +292,25 @@ end;
{ TLFTP }
function TLFTP.GetSession: TLSession;
begin
Result := FControl.Session;
end;
procedure TLFTP.SetSession(const AValue: TLSession);
begin
FControl.Session := aValue;
FData.Session := aValue;
end;
procedure TLFTP.SetCreator(AValue: TLComponent);
begin
inherited SetCreator(AValue);
FControl.Creator := AValue;
FData.Creator := AValue;
end;
function TLFTP.GetConnected: Boolean;
begin
Result := FControl.Connected;
@ -310,16 +346,22 @@ begin
FPort := 21;
FControl := TLFTPTelnetClient.Create(nil);
FControl.Creator := Self;
FData := TLTcp.Create(nil);
FData.Creator := Self;
FData.SocketClass := TLSocket;
FTransferMethod := ftPassive; // let's be modern
FFeatureList := TStringList.Create;
end;
destructor TLFTP.Destroy;
begin
FControl.Free;
FData.Free;
FFeatureList.Free;
inherited Destroy;
end;
@ -336,8 +378,6 @@ end;
constructor TLFTPClient.Create(aOwner: TComponent);
const
DEFAULT_CHUNK = 8192;
var
s: TLFTPStatus;
begin
inherited Create(aOwner);
@ -351,16 +391,15 @@ begin
FData.OnCanSend := @OnSe;
FData.OnError := @OnEr;
FStatusSet := []; // empty Event set
FStatusSet := [fsNone..fsLast]; // full Event set
FPassWord := '';
FChunkSize := DEFAULT_CHUNK;
FStartPort := DEFAULT_FTP_PORT;
FSL := TStringList.Create;
FLastPort := FStartPort;
for s := fsNone to fsDEL do
FStatusFlags[s] := False;
ClearStatusFlags;
FStatus := TLFTPStatusFront.Create(EMPTY_REC);
FCommandFront := TLFTPStatusFront.Create(EMPTY_REC);
@ -369,7 +408,7 @@ end;
destructor TLFTPClient.Destroy;
begin
Disconnect;
Disconnect(True);
FSL.Free;
FStatus.Free;
FCommandFront.Free;
@ -406,6 +445,15 @@ end;
procedure TLFTPClient.OnControlEr(const msg: string; aSocket: TLSocket);
begin
FSending := False;
if Assigned(FOnFailure) then begin
while not FStatus.Empty do
FOnFailure(aSocket, FStatus.Remove.Status);
end else
FStatus.Clear;
ClearStatusFlags;
if Assigned(FOnError) then
FOnError(msg, aSocket);
end;
@ -428,6 +476,19 @@ begin
FOnError('Connection lost', aSocket);
end;
procedure TLFTPClient.ClearStatusFlags;
var
s: TLFTPStatus;
begin
for s := fsNone to fsLast do
FStatusFlags[s] := False;
end;
function TLFTPClient.GetCurrentStatus: TLFTPStatus;
begin
Result := FStatus.First.Status;
end;
function TLFTPClient.GetTransfer: Boolean;
begin
Result := FData.Connected;
@ -440,7 +501,7 @@ end;
function TLFTPClient.GetConnected: Boolean;
begin
Result := FStatusFlags[fsCon] and inherited;
Result := FStatusFlags[fsCon] and inherited;
end;
function TLFTPClient.GetBinary: Boolean;
@ -461,9 +522,10 @@ 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]);
for i := 0 to FSL.Count - 1 do
if Length(FSL[i]) > 0 then
EvaluateAnswer(FSL[i]);
s := StringReplace(s, FLE, LineEnding, [rfReplaceAll]);
i := Pos('PASS', s);
if i > 0 then
@ -478,6 +540,32 @@ begin
FLastPort := Value;
end;
procedure TLFTPClient.EvaluateFeatures;
var
i: Integer;
begin
FFeatureList.Clear;
if Length(FFeatureString) = 0 then
Exit;
FFeatureList.Text := FFeatureString;
FFeatureString := '';
FFeatureList.Delete(0);
i := 0;
while i < FFeatureList.Count do begin
if (Length(Trim(FFeatureList[i])) = 0)
or (FFeatureList[i][1] <> ' ') then begin
FFeatureList.Delete(i);
Continue;
end;
FFeatureList[i] := Trim(FFeatureList[i]);
Inc(i);
end;
end;
procedure TLFTPClient.SetEcho(const Value: Boolean);
begin
if Value then
@ -486,14 +574,30 @@ begin
FControl.UnSetOption(TS_ECHO);
end;
procedure TLFTPClient.ParsePWD(const s: string);
var
i: Integer;
IsIn: Boolean = False;
begin
FPWD := '';
for i := 1 to Length(s) do begin
if s[i] = '"' then begin
IsIn := not IsIn;
Continue;
end;
if IsIn then
FPWD := FPWD + s[i];
end;
end;
procedure TLFTPClient.SetBinary(const Value: Boolean);
const
TypeBool: array[Boolean] of string = ('A', 'I');
begin
if CanContinue(fsType, BoolToStr(Value), '') then begin
FExpectedBinary := Value;
FControl.SendMessage('TYPE ' + TypeBool[Value] + FLE);
FStatus.Insert(MakeStatusRec(fsType, '', ''));
FControl.SendMessage('TYPE ' + TypeBool[Value] + FLE);
end;
end;
@ -501,11 +605,12 @@ procedure TLFTPClient.EvaluateAnswer(const Ans: string);
function GetNum: Integer;
begin
try
Result := -1;
if (Length(Ans) >= 3)
and (Ans[1] in ['0'..'9'])
and (Ans[2] in ['0'..'9'])
and (Ans[3] in ['0'..'9']) then
Result := StrToInt(Copy(Ans, 1, 3));
except
Result := -1;
end;
end;
procedure ParsePortIP(s: string);
@ -563,6 +668,7 @@ procedure TLFTPClient.EvaluateAnswer(const Ans: string);
procedure Eventize(const aStatus: TLFTPStatus; const Res: Boolean);
begin
FStatus.Remove;
if Res then begin
if Assigned(FOnSuccess) and (aStatus in FStatusSet) then
FOnSuccess(FData.Iterator, aStatus);
@ -578,6 +684,9 @@ begin
x := GetNum;
Writedbg(['WOULD EVAL: ', FTPStatusStr[FStatus.First.Status], ' with value: ',
x, ' from "', Ans, '"']);
if FStatus.First.Status = fsFeat then
FFeatureString := FFeatureString + Ans + FLE; // we need to parse this later
if ValidResponse(Ans) then
if not FStatus.Empty then begin
Writedbg(['EVAL: ', FTPStatusStr[FStatus.First.Status], ' with value: ', x]);
@ -587,13 +696,11 @@ begin
begin
FStatusFlags[FStatus.First.Status] := True;
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else
begin
FStatusFlags[FStatus.First.Status] := False;
Eventize(FStatus.First.Status, False);
FStatus.Remove;
end;
end;
@ -602,7 +709,6 @@ begin
begin
FStatusFlags[FStatus.First.Status] := True;
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
331,
332:
@ -614,7 +720,6 @@ begin
begin
FStatusFlags[FStatus.First.Status] := False;
Eventize(FStatus.First.Status, False);
FStatus.Remove;
end;
end;
@ -623,13 +728,11 @@ begin
begin
FStatusFlags[FStatus.First.Status] := True;
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else
begin
FStatusFlags[FStatus.First.Status] := False;
Eventize(FStatus.First.Status, False);
FStatus.Remove;
end;
end;
@ -642,12 +745,10 @@ begin
200:
begin
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else
begin
Eventize(FStatus.First.Status, False);
FStatus.Remove;
end;
end;
@ -657,12 +758,10 @@ begin
FStatusFlags[FStatus.First.Status] := FExpectedBinary;
Writedbg(['Binary mode: ', FExpectedBinary]);
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else
begin
Eventize(FStatus.First.Status, False);
FStatus.Remove;
end;
end;
@ -671,14 +770,12 @@ begin
226:
begin
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else
begin
FData.Disconnect;
FData.Disconnect(True); // break on purpose, otherwise we get invalidated ugly
Writedbg(['Disconnecting data connection']);
Eventize(FStatus.First.Status, False);
FStatus.Remove; // error after connection established
end;
end;
@ -688,12 +785,10 @@ begin
226:
begin
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else
begin
Eventize(FStatus.First.Status, True);
FStatus.Remove;
Eventize(FStatus.First.Status, False);
end;
end;
@ -702,27 +797,50 @@ begin
begin
FStatusFlags[FStatus.First.Status] := True;
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else
begin
FStatusFlags[FStatus.First.Status] := False;
Eventize(FStatus.First.Status, False);
FStatus.Remove;
end;
end;
fsPWD : case x of
257:
begin
ParsePWD(Ans);
FStatusFlags[FStatus.First.Status] := True;
Eventize(FStatus.First.Status, True);
end;
else
begin
FStatusFlags[FStatus.First.Status] := False;
Eventize(FStatus.First.Status, False);
end;
end;
fsHelp : case x of
211, 214:
begin
FStatusFlags[FStatus.First.Status] := True;
Eventize(FStatus.First.Status, True);
end;
else
begin
FStatusFlags[FStatus.First.Status] := False;
Eventize(FStatus.First.Status, False);
end;
end;
fsList : case x of
125, 150: begin { do nothing } end;
226:
begin
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else
begin
Eventize(FStatus.First.Status, False);
FStatus.Remove;
end;
end;
@ -731,13 +849,11 @@ begin
begin
FStatusFlags[FStatus.First.Status] := True;
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else
begin
FStatusFlags[FStatus.First.Status] := False;
Eventize(FStatus.First.Status, False);
FStatus.Remove;
end;
end;
@ -747,13 +863,11 @@ begin
begin
FStatusFlags[FStatus.First.Status] := True;
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else
begin
FStatusFlags[FStatus.First.Status] := False;
Eventize(FStatus.First.Status, False);
FStatus.Remove;
end;
end;
@ -762,12 +876,10 @@ begin
begin
FStatusFlags[FStatus.First.Status] := True;
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else
begin
Eventize(FStatus.First.Status, False);
FStatus.Remove;
end;
end;
@ -776,12 +888,23 @@ begin
begin
FStatusFlags[FStatus.First.Status] := True;
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else
begin
Eventize(FStatus.First.Status, False);
FStatus.Remove;
end;
end;
fsFeat : case x of
200..299:
begin
FStatusFlags[FStatus.First.Status] := True;
EvaluateFeatures;
Eventize(FStatus.First.Status, True);
end;
else
begin
FFeatureString := '';
Eventize(FStatus.First.Status, False);
end;
end;
end;
@ -807,10 +930,10 @@ procedure TLFTPClient.PasvPort;
begin
if FTransferMethod = ftActive then begin
Writedbg(['Sent PORT']);
FData.Disconnect;
FData.Disconnect(True);
FData.Listen(FLastPort);
FControl.SendMessage('PORT ' + StringIP + StringPair(FLastPort) + FLE);
FStatus.Insert(MakeStatusRec(fsPort, '', ''));
FControl.SendMessage('PORT ' + StringIP + StringPair(FLastPort) + FLE);
if FLastPort < 65535 then
Inc(FLastPort)
@ -818,8 +941,8 @@ begin
FLastPort := FStartPort;
end else begin
Writedbg(['Sent PASV']);
FControl.SendMessage('PASV' + FLE);
FStatus.Insert(MakeStatusRec(fsPasv, '', ''));
FControl.SendMessage('PASV' + FLE);
end;
end;
@ -827,8 +950,8 @@ function TLFTPClient.User(const aUserName: string): Boolean;
begin
Result := not FPipeLine;
if CanContinue(fsUser, aUserName, '') then begin
FControl.SendMessage('USER ' + aUserName + FLE);
FStatus.Insert(MakeStatusRec(fsUser, '', ''));
FControl.SendMessage('USER ' + aUserName + FLE);
Result := True;
end;
end;
@ -837,8 +960,8 @@ function TLFTPClient.Password(const aPassword: string): Boolean;
begin
Result := not FPipeLine;
if CanContinue(fsPass, aPassword, '') then begin
FControl.SendMessage('PASS ' + aPassword + FLE);
FStatus.Insert(MakeStatusRec(fsPass, '', ''));
FControl.SendMessage('PASS ' + aPassword + FLE);
Result := True;
end;
end;
@ -863,7 +986,7 @@ begin
FreeAndNil(FStoreFile);
FSending := False;
{$hint this one calls freeinstance which doesn't pass}
FData.Disconnect;
FData.Disconnect(False);
end;
until (n = 0) or (Sent = 0);
end;
@ -887,20 +1010,22 @@ begin
fsPWD : PresentWorkingDirectory;
fsHelp : Help(Args[1]);
fsType : SetBinary(StrToBool(Args[1]));
fsFeat : FeatureList;
fsFeat : ListFeatures;
end;
FCommandFront.Remove;
end;
function TLFTPClient.Get(var aData; const aSize: Integer; aSocket: TLSocket): Integer;
function TLFTPClient.Get(out aData; const aSize: Integer; aSocket: TLSocket): Integer;
var
s: string;
begin
Result := FControl.Get(aData, aSize, aSocket);
if Result > 0 then begin
Result := 0;
if FControl.Get(aData, aSize, aSocket) > 0 then begin
SetLength(s, Result);
Move(aData, PChar(s)^, Result);
CleanInput(s);
Result := CleanInput(s);
Move(s[1], aData, Min(Length(s), aSize));
end;
end;
@ -923,7 +1048,7 @@ begin
Result := FControl.SendMessage(msg);
end;
function TLFTPClient.GetData(var aData; const aSize: Integer): Integer;
function TLFTPClient.GetData(out aData; const aSize: Integer): Integer;
begin
Result := FData.Iterator.Get(aData, aSize);
end;
@ -938,7 +1063,7 @@ end;
function TLFTPClient.Connect(const aHost: string; const aPort: Word): Boolean;
begin
Result := False;
Disconnect;
Disconnect(True);
if FControl.Connect(aHost, aPort) then begin
FHost := aHost;
FPort := aPort;
@ -965,8 +1090,8 @@ begin
Result := not FPipeLine;
if CanContinue(fsRetr, FileName, '') then begin
PasvPort;
FControl.SendMessage('RETR ' + FileName + FLE);
FStatus.Insert(MakeStatusRec(fsRetr, '', ''));
FControl.SendMessage('RETR ' + FileName + FLE);
Result := True;
end;
end;
@ -977,8 +1102,8 @@ begin
if FileExists(FileName) and CanContinue(fsStor, FileName, '') then begin
FStoreFile := TFileStream.Create(FileName, fmOpenRead);
PasvPort;
FControl.SendMessage('STOR ' + ExtractFileName(FileName) + FLE);
FStatus.Insert(MakeStatusRec(fsStor, '', ''));
FControl.SendMessage('STOR ' + ExtractFileName(FileName) + FLE);
Result := True;
end;
end;
@ -987,9 +1112,9 @@ function TLFTPClient.ChangeDirectory(const DestPath: string): Boolean;
begin
Result := not FPipeLine;
if CanContinue(fsCWD, DestPath, '') then begin
FControl.SendMessage('CWD ' + DestPath + FLE);
FStatus.Insert(MakeStatusRec(fsCWD, '', ''));
FStatusFlags[fsCWD] := False;
FControl.SendMessage('CWD ' + DestPath + FLE);
Result := True;
end;
end;
@ -998,9 +1123,9 @@ function TLFTPClient.MakeDirectory(const DirName: string): Boolean;
begin
Result := not FPipeLine;
if CanContinue(fsMKD, DirName, '') then begin
FControl.SendMessage('MKD ' + DirName + FLE);
FStatus.Insert(MakeStatusRec(fsMKD, '', ''));
FStatusFlags[fsMKD] := False;
FControl.SendMessage('MKD ' + DirName + FLE);
Result := True;
end;
end;
@ -1009,9 +1134,9 @@ function TLFTPClient.RemoveDirectory(const DirName: string): Boolean;
begin
Result := not FPipeLine;
if CanContinue(fsRMD, DirName, '') then begin
FControl.SendMessage('RMD ' + DirName + FLE);
FStatus.Insert(MakeStatusRec(fsRMD, '', ''));
FStatusFlags[fsRMD] := False;
FControl.SendMessage('RMD ' + DirName + FLE);
Result := True;
end;
end;
@ -1020,9 +1145,9 @@ function TLFTPClient.DeleteFile(const FileName: string): Boolean;
begin
Result := not FPipeLine;
if CanContinue(fsDEL, FileName, '') then begin
FControl.SendMessage('DELE ' + FileName + FLE);
FStatus.Insert(MakeStatusRec(fsDEL, '', ''));
FStatusFlags[fsDEL] := False;
FControl.SendMessage('DELE ' + FileName + FLE);
Result := True;
end;
end;
@ -1031,13 +1156,13 @@ function TLFTPClient.Rename(const FromName, ToName: string): Boolean;
begin
Result := not FPipeLine;
if CanContinue(fsRNFR, FromName, ToName) then begin
FControl.SendMessage('RNFR ' + FromName + FLE);
FStatus.Insert(MakeStatusRec(fsRNFR, '', ''));
FStatusFlags[fsRNFR] := False;
FControl.SendMessage('RNFR ' + FromName + FLE);
FControl.SendMessage('RNTO ' + ToName + FLE);
FStatus.Insert(MakeStatusRec(fsRNTO, '', ''));
FStatusFlags[fsRNTO] := False;
FControl.SendMessage('RNTO ' + ToName + FLE);
Result := True;
end;
@ -1073,34 +1198,37 @@ begin
FControl.SendMessage('SYST' + FLE);
end;
procedure TLFTPClient.FeatureList;
procedure TLFTPClient.ListFeatures;
begin
if CanContinue(fsFeat, '', '') then
if CanContinue(fsFeat, '', '') then begin
FStatus.Insert(MakeStatusRec(fsFeat, '', ''));
FControl.SendMessage('FEAT' + FLE);
end;
end;
procedure TLFTPClient.PresentWorkingDirectory;
begin
if CanContinue(fsPWD, '', '') then
if CanContinue(fsPWD, '', '') then begin
FStatus.Insert(MakeStatusRec(fsPWD, '', ''));
FControl.SendMessage('PWD' + FLE);
end;
end;
procedure TLFTPClient.Help(const Arg: string);
begin
if CanContinue(fsHelp, Arg, '') then
if CanContinue(fsHelp, Arg, '') then begin
FStatus.Insert(MakeStatusRec(fsHelp, Arg, ''));
FControl.SendMessage('HELP ' + Arg + FLE);
end;
end;
procedure TLFTPClient.Disconnect;
var
s: TLFTPStatus;
procedure TLFTPClient.Disconnect(const Forced: Boolean = True);
begin
FControl.Disconnect;
FControl.Disconnect(Forced);
FStatus.Clear;
FData.Disconnect;
FData.Disconnect(Forced);
FLastPort := FStartPort;
for s := fsNone to fsLast do
FStatusFlags[s] := False;
ClearStatusFlags;
FCommandFront.Clear;
end;

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

@ -1,6 +1,6 @@
{ HTTP server and client components
Copyright (C) 2006-2007 Micha Nelissen
Copyright (C) 2006-2008 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
@ -298,7 +298,6 @@ type
procedure AddContentLength(ALength: integer); virtual; abstract;
function CalcAvailableBufferSpace: integer;
procedure DelayFree(AOutputItem: TOutputItem);
procedure Disconnect; override;
procedure DoneBuffer(AOutput: TBufferOutput); virtual;
procedure FreeDelayFreeItems;
procedure LogAccess(const AMessage: string); virtual;
@ -323,6 +322,7 @@ type
destructor Destroy; override;
procedure AddToOutput(AOutputItem: TOutputItem);
procedure Disconnect(const Forced: Boolean = True); override;
procedure PrependOutput(ANewItem, AItem: TOutputItem);
procedure RemoveOutput(AOutputItem: TOutputItem);
procedure HandleReceive;
@ -459,6 +459,8 @@ type
destructor Destroy; override;
procedure AddExtraHeader(const AHeader: string);
procedure AddCookie(const AName, AValue: string; const APath: string = '';
const ADomain: string = ''; const AVersion: string = '0');
procedure ResetRange;
procedure SendRequest;
@ -559,6 +561,11 @@ begin
AValue := Val;
end;
function EscapeCookie(const AInput: string): string;
begin
Result := StringReplace(AInput, ';', '%3B', [rfReplaceAll]);
end;
{ TURIHandler }
constructor TURIHandler.Create;
@ -969,11 +976,12 @@ begin
FreeMem(FBuffer);
end;
procedure TLHTTPSocket.Disconnect;
procedure TLHTTPSocket.Disconnect(const Forced: Boolean = True);
var
lOutput: TOutputItem;
begin
inherited Disconnect;
inherited Disconnect(Forced);
while FCurrentOutput <> nil do
begin
lOutput := FCurrentOutput;
@ -999,6 +1007,9 @@ end;
procedure TLHTTPSocket.DelayFree(AOutputItem: TOutputItem);
begin
if AOutputItem = nil then exit;
{ check whether already in delayed free list }
if AOutputItem = FDelayFreeItems then exit;
if AOutputItem.FPrevDelayFree <> nil then exit;
if FDelayFreeItems <> nil then
FDelayFreeItems.FPrevDelayFree := AOutputItem;
AOutputItem.FNextDelayFree := FDelayFreeItems;
@ -1318,29 +1329,39 @@ end;
function TLHTTPSocket.ProcessEncoding: boolean;
var
lCode: integer;
lParam: pchar;
begin
Result := true;
if FParameters[hpContentLength] <> nil then
lParam := FParameters[hpContentLength];
if lParam <> nil then
begin
FParseBuffer := @ParseEntityPlain;
Val(FParameters[hpContentLength], FInputRemaining, lCode);
Val(lParam, FInputRemaining, lCode);
if lCode <> 0 then
begin
WriteError(hsBadRequest);
exit;
end;
end else
if FParameters[hpTransferEncoding] <> nil then
exit;
end;
lParam := FParameters[hpTransferEncoding];
if lParam <> nil then
begin
if (StrIComp(FParameters[hpTransferEncoding], 'chunked') = 0) then
if StrIComp(lParam, 'chunked') = 0 then
begin
FParseBuffer := @ParseEntityChunked;
FChunkState := csInitial;
end else begin
end else
Result := false;
end;
end else begin
FRequestInputDone := true;
exit;
end;
{ only if keep-alive, then user must specify either of above headers to
indicate next header's start }
lParam := FParameters[hpConnection];
FRequestInputDone := (lParam <> nil) and (StrIComp(lParam, 'keep-alive') = 0);
if not FRequestInputDone then
begin
FParseBuffer := @ParseEntityPlain;
FInputRemaining := high(FInputRemaining);
end;
end;
@ -1404,7 +1425,7 @@ begin
end;
{ if we cannot send, then the send buffer is full }
if not FCanSend or not FConnected then
if (FConnectionStatus <> scConnected) or not (ssCanSend in FSocketState) then
break;
case FCurrentOutput.WriteBlock of
@ -1638,7 +1659,7 @@ end;
procedure TLHTTPServerSocket.ProcessHeaders;
{ process request }
var
lPos: pchar;
lPos, lConnParam: pchar;
begin
{ do HTTP/1.1 Host-field present check }
if (FRequestInfo.Version > 10) and (FParameters[hpHost] = nil) then
@ -1655,12 +1676,13 @@ begin
end;
FKeepAlive := FRequestInfo.Version > 10;
if FParameters[hpConnection] <> nil then
lConnParam := FParameters[hpConnection];
if lConnParam <> nil then
begin
if StrIComp(FParameters[hpConnection], 'keep-alive') = 0 then
if StrIComp(lConnParam, 'keep-alive') = 0 then
FKeepAlive := true
else
if StrIComp(FParameters[hpConnection], 'close') = 0 then
if StrIComp(lConnParam, 'close') = 0 then
FKeepAlive := false;
end;
@ -2067,6 +2089,12 @@ begin
AppendString(lMessage, lTemp);
end;
AppendString(lMessage, #13#10);
if FHeaderOut^.ContentLength > 0 then
begin
AppendString(lMessage, 'Content-Length: ');
Str(FHeaderOut^.ContentLength, lTemp);
AppendString(lMessage, lTemp+#13#10);
end;
hasRangeStart := TLHTTPClient(FCreator).RangeStart <> high(qword);
hasRangeEnd := TLHTTPClient(FCreator).RangeEnd <> high(qword);
if hasRangeStart or hasRangeEnd then
@ -2083,6 +2111,7 @@ begin
Str(TLHTTPClient(FCreator).RangeEnd, lTemp);
AppendString(lMessage, lTemp);
end;
AppendString(lMessage, #13#10);
end;
with FHeaderOut^.ExtraHeaders do
AppendString(lMessage, Memory, Pos-Memory);
@ -2195,6 +2224,19 @@ begin
AppendString(FHeaderOut.ExtraHeaders, #13#10);
end;
procedure TLHTTPClient.AddCookie(const AName, AValue: string; const APath: string = '';
const ADomain: string = ''; const AVersion: string = '0');
var
lHeader: string;
begin
lHeader := 'Cookie: $Version='+AVersion+'; '+AName+'='+EscapeCookie(AValue);
if Length(APath) > 0 then
lHeader := lHeader+';$Path='+APath;
if Length(ADomain) > 0 then
lHeader := lHeader+';$Domain='+ADomain;
AddExtraHeader(lHeader);
end;
procedure TLHTTPClient.ConnectEvent(aSocket: TLHandle);
begin
inherited;
@ -2237,10 +2279,10 @@ end;
function TLHTTPClient.InitSocket(aSocket: TLSocket): TLSocket;
begin
Result := inherited;
TLHTTPClientSocket(aSocket).FHeaderOut := @FHeaderOut;
TLHTTPClientSocket(aSocket).FRequest := @FRequest;
TLHTTPClientSocket(aSocket).FResponse := @FResponse;
Result := inherited;
end;
procedure TLHTTPClient.InternalSendRequest;

52
utils/fppkg/lnet/lhttputil.pp
View File

@ -1,6 +1,6 @@
{ Utility routines for HTTP server component
Copyright (C) 2006-2007 Micha Nelissen
Copyright (C) 2006-2008 by 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
@ -51,7 +51,7 @@ type
function HTTPEncode(const AStr: string): string;
function HexToNum(AChar: char): byte;
procedure DecomposeURL(const URL: string; out Host, URI: string; out Port: Word);
function DecomposeURL(const URL: string; out Host, URI: string; out Port: Word): Boolean;
function ComposeURL(Host, URI: string; const Port: Word): string;
implementation
@ -232,27 +232,53 @@ begin
until false;
end;
procedure DecomposeURL(const URL: string; out Host, URI: string; out Port: Word);
function DecomposeURL(const URL: string; out Host, URI: string; out Port: Word): Boolean;
var
index: Integer;
n: Integer;
tmp: string;
begin
index := PosEx('/', URL, 8);
Host := Copy(URL, 8, index-8);
URI := Copy(URL, index, Length(URL)+1-index);
Result := False;
index := Pos(':', Host);
if index > 0 then begin
Port := StrToIntDef(Copy(Host, index+1, Length(Host)-index), -1);
try
tmp := Trim(URL);
if Length(tmp) < 1 then // don't do empty
Exit;
SetLength(Host, index-1);
end else
Port := 80;
if tmp[Length(tmp)] = '/' then // remove trailing /
Delete(tmp, Length(tmp), 1);
if Pos('https://', tmp) = 1 then begin // check for HTTPS
Result := True;
Port := 443;
Delete(tmp, 1, 8); // delete the https part for parsing reasons
end else if Pos('http://', tmp) = 1 then begin
Delete(tmp, 1, 7); // delete the http part for parsing reasons
end;
n := Pos(':', tmp); // find if we have a port at the end
if n > 0 then begin
Port := StrToInt(Copy(tmp, n + 1, Length(tmp)));
Delete(tmp, n, Length(tmp));
end;
n := Pos('/', tmp); // find if we have a uri section
if n > 0 then begin
URI := Copy(tmp, n, Length(tmp));
Delete(tmp, n, Length(tmp));
end;
Host := tmp;
except
Host := 'error';
URI := '';
Port := 0;
end;
end;
function ComposeURL(Host, URI: string; const Port: Word): string;
begin
Host := Trim(Host);
URI := Trim(URI);
URI := StringReplace(Trim(URI), '%20', ' ', [rfReplaceAll]);
if (Pos('http://', Host) <> 1)
and (Pos('https://', Host) <> 1) then

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

@ -1,6 +1,6 @@
{ MIME Streams
CopyRight (C) 2006-2007 Micha Nelissen
CopyRight (C) 2006-2008 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

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

@ -1,6 +1,6 @@
{ Mime types helper
Copyright (C) 2006-2007 Micha Nelissen
Copyright (C) 2006-2008 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

4
utils/fppkg/lnet/lmimewrapper.pp
View File

@ -1,6 +1,6 @@
{ lNet MIME Wrapper
CopyRight (C) 2007 Ales Katona
CopyRight (C) 2007-2008 by 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
@ -612,8 +612,6 @@ begin
end;
procedure TMimeStream.DoRead(const aSize: Integer);
var
n: Integer;
begin
ActivateFirstSection;

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

File diff suppressed because it is too large Load Diff

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

@ -1,6 +1,6 @@
{ Asynchronous process support
Copyright (C) 2006-2007 Micha Nelissen
Copyright (C) 2006-2008 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

338
utils/fppkg/lnet/lsmtp.pp
View File

@ -1,6 +1,6 @@
{ lNet SMTP unit
CopyRight (C) 2005-2007 Ales Katona
CopyRight (C) 2005-2008 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
@ -29,14 +29,15 @@ unit lsmtp;
interface
uses
Classes, SysUtils, Contnrs, lNet, lEvents, lCommon, lMimeWrapper, lMimeStreams;
Classes, SysUtils, Contnrs, Base64,
lNet, lEvents, lCommon, lMimeWrapper, lMimeStreams;
type
TLSMTP = class;
TLSMTPClient = class;
TLSMTPStatus = (ssNone, ssCon, ssHelo, ssEhlo, ssMail,
ssRcpt, ssData, ssRset, ssQuit);
TLSMTPStatus = (ssNone, ssCon, ssHelo, ssEhlo, ssAuthLogin, ssAuthPlain,
ssStartTLS, ssMail, ssRcpt, ssData, ssRset, ssQuit, ssLast);
TLSMTPStatusSet = set of TLSMTPStatus;
@ -73,6 +74,7 @@ type
procedure AddStreamSection(aStream: TStream; const FreeStream: Boolean = False);
procedure DeleteSection(const i: Integer);
procedure RemoveSection(aSection: TMimeSection);
procedure Reset;
public
property MailText: string read FMailText write FMailText; deprecated; // use sections!
property Sender: string read FSender write FSender;
@ -85,10 +87,15 @@ type
TLSMTP = class(TLComponent)
protected
FConnection: TLTcp;
FFeatureList: TStringList;
protected
function GetTimeout: Integer;
procedure SetTimeout(const AValue: Integer);
function GetSession: TLSession;
procedure SetSession(const AValue: TLSession);
procedure SetCreator(AValue: TLComponent); override;
function GetConnected: Boolean;
function GetSocketClass: TLSocketClass;
@ -99,6 +106,8 @@ type
public
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
function HasFeature(aFeature: string): Boolean;
public
property Connected: Boolean read GetConnected;
property Connection: TLTcp read FConnection;
@ -106,6 +115,8 @@ type
property SocketClass: TLSocketClass read GetSocketClass write SetSocketClass;
property Eventer: TLEventer read GetEventer write SetEventer;
property Timeout: Integer read GetTimeout write SetTimeout;
property Session: TLSession read GetSession write SetSession;
property FeatureList: TStringList read FFeatureList;
end;
{ TLSMTPClient }
@ -115,6 +126,7 @@ type
FStatus: TLSMTPStatusFront;
FCommandFront: TLSMTPStatusFront;
FPipeLine: Boolean;
FAuthStep: Integer;
FOnConnect: TLSocketEvent;
FOnReceive: TLSocketEvent;
@ -128,6 +140,7 @@ type
FStatusSet: TLSMTPStatusSet;
FBuffer: string;
FDataBuffer: string; // intermediate wait buffer on DATA command
FTempBuffer: string; // used independently from FBuffer for feature list
FCharCount: Integer; // count of chars from last CRLF
FStream: TStream;
protected
@ -141,12 +154,14 @@ type
function CleanInput(var s: string): Integer;
procedure EvaluateServer;
procedure EvaluateFeatures;
procedure EvaluateAnswer(const Ans: string);
procedure ExecuteFrontCommand;
procedure ClearCR_LF;
procedure AddToBuffer(s: string);
procedure SendData(const FromStream: Boolean = False);
function EncodeBase64(const s: string): string;
public
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
@ -163,13 +178,16 @@ type
procedure Helo(aHost: string = '');
procedure Ehlo(aHost: string = '');
procedure StartTLS;
procedure AuthLogin(aName, aPass: string);
procedure AuthPlain(aName, aPass: string);
procedure Mail(const From: string);
procedure Rcpt(const RcptTo: string);
procedure Data(const Msg: string);
procedure Rset;
procedure Quit;
procedure Disconnect; override;
procedure Disconnect(const Forced: Boolean = True); override;
procedure CallAction; override;
public
@ -193,8 +211,9 @@ const
function StatusToStr(const aStatus: TLSMTPStatus): string;
const
STATAR: array[ssNone..ssQuit] of string = ('ssNone', 'ssCon', 'ssHelo', 'ssEhlo', 'ssMail',
'ssRcpt', 'ssData', 'ssRset', 'ssQuit');
STATAR: array[ssNone..ssLast] of string = ('ssNone', 'ssCon', 'ssHelo', 'ssEhlo',
'ssStartTLS', 'ssAuthLogin', 'ssAuthPlain',
'ssMail', 'ssRcpt', 'ssData', 'ssRset', 'ssQuit', 'ssLast');
begin
Result := STATAR[aStatus];
end;
@ -208,6 +227,23 @@ end;
{ TLSMTP }
function TLSMTP.GetSession: TLSession;
begin
Result := FConnection.Session;
end;
procedure TLSMTP.SetSession(const AValue: TLSession);
begin
FConnection.Session := aValue;
end;
procedure TLSMTP.SetCreator(AValue: TLComponent);
begin
inherited SetCreator(AValue);
FConnection.Creator := AValue;
end;
function TLSMTP.GetTimeout: Integer;
begin
Result := FConnection.Timeout;
@ -247,23 +283,62 @@ constructor TLSMTP.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
FFeatureList := TStringList.Create;
FConnection := TLTcp.Create(nil);
FConnection.Creator := Self;
// TODO: rework to use the new TLSocketTCP
FConnection.SocketClass := TLSocket;
end;
destructor TLSMTP.Destroy;
begin
FFeatureList.Free;
FConnection.Free;
inherited Destroy;
end;
function TLSMTP.HasFeature(aFeature: string): Boolean;
var
tmp: TStringList;
i, j: Integer;
AllArgs: Boolean;
begin
Result := False;
try
tmp := TStringList.Create;
aFeature := UpperCase(aFeature);
aFeature := StringReplace(aFeature, ' ', ',', [rfReplaceAll]);
tmp.CommaText := aFeature;
for i := 0 to FFeatureList.Count - 1 do begin
if Pos(tmp[0], FFeatureList[i]) = 1 then begin
if tmp.Count = 1 then // no arguments, feature found, just exit true
Exit(True)
else begin // check arguments
AllArgs := True;
for j := 1 to tmp.Count - 1 do
if Pos(tmp[j], FFeatureList[i]) <= 0 then begin // some argument not found
AllArgs := False;
Break;
end;
if AllArgs then
Exit(True);
end;
end;
end;
finally
tmp.Free;
end;
end;
{ TLSMTPClient }
constructor TLSMTPClient.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
FPort := 25;
FStatusSet := []; // empty set for "ok/not-ok" Event
FStatusSet := [ssNone..ssLast]; // full set
FSL := TStringList.Create;
// {$warning TODO: fix pipelining support when server does it}
FPipeLine := False;
@ -280,7 +355,8 @@ end;
destructor TLSMTPClient.Destroy;
begin
Quit;
if FConnection.Connected then
Quit;
FSL.Free;
FStatus.Free;
FCommandFront.Free;
@ -290,6 +366,12 @@ end;
procedure TLSMTPClient.OnEr(const msg: string; aSocket: TLSocket);
begin
if Assigned(FOnFailure) then begin
while not FStatus.Empty do
FOnFailure(aSocket, FStatus.Remove.Status);
end else
FStatus.Clear;
if Assigned(FOnError) then
FOnError(msg, aSocket);
end;
@ -329,8 +411,14 @@ var
i: Integer;
begin
FSL.Text := s;
case FStatus.First.Status of // TODO: clear this to a proper place, the whole thing needs an overhaul
ssCon,
ssEhlo: FTempBuffer := FTempBuffer + UpperCase(s);
end;
if FSL.Count > 0 then
for i := 0 to FSL.Count-1 do
for i := 0 to FSL.Count - 1 do
if Length(FSL[i]) > 0 then EvaluateAnswer(FSL[i]);
s := StringReplace(s, CRLF, LineEnding, [rfReplaceAll]);
i := Pos('PASS', s);
@ -339,6 +427,41 @@ begin
Result := Length(s);
end;
procedure TLSMTPClient.EvaluateServer;
begin
FFeatureList.Clear;
if Length(FTempBuffer) = 0 then
Exit;
if Pos('ESMTP', FTempBuffer) > 0 then
FFeatureList.Append('EHLO');
FTempBuffer := '';
end;
procedure TLSMTPClient.EvaluateFeatures;
var
i: Integer;
begin
FFeatureList.Clear;
if Length(FTempBuffer) = 0 then
Exit;
FFeatureList.Text := FTempBuffer;
FTempBuffer := '';
FFeatureList.Delete(0);
i := 0;
while i < FFeatureList.Count do begin;
FFeatureList[i] := Copy(FFeatureList[i], 5, Length(FFeatureList[i])); // delete the response code crap
FFeatureList[i] := StringReplace(FFeatureList[i], '=', ' ', [rfReplaceAll]);
if FFeatureList.IndexOf(FFeatureList[i]) <> i then begin
FFeatureList.Delete(i);
Continue;
end;
Inc(i);
end;
end;
procedure TLSMTPClient.EvaluateAnswer(const Ans: string);
function GetNum: Integer;
@ -363,6 +486,7 @@ procedure TLSMTPClient.EvaluateAnswer(const Ans: string);
procedure Eventize(const aStatus: TLSMTPStatus; const Res: Boolean);
begin
FStatus.Remove;
if Res then begin
if Assigned(FOnSuccess) and (aStatus in FStatusSet) then
FOnSuccess(FConnection.Iterator, aStatus);
@ -376,55 +500,102 @@ 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
case FStatus.First.Status of
ssCon : EvaluateServer;
ssEhlo : EvaluateFeatures;
end;
Eventize(FStatus.First.Status, True);
FStatus.Remove;
end;
else begin
Eventize(FStatus.First.Status, False);
Disconnect;
Disconnect(False);
FFeatureList.Clear;
FTempBuffer := '';
end;
end;
ssStartTLS:
case x of
200..299: begin
Eventize(FStatus.First.Status, True);
FConnection.Iterator.SetState(ssSSLActive);
end;
else begin
Eventize(FStatus.First.Status, False);
end;
end;
ssAuthLogin:
case x of
200..299: begin
Eventize(FStatus.First.Status, True);
end;
300..399: if FAuthStep = 0 then begin
AddToBuffer(FStatus.First.Args[1] + CRLF);
Inc(FAuthStep);
SendData;
end else if FAuthStep = 1 then begin
AddToBuffer(FStatus.First.Args[2] + CRLF);
Inc(FAuthStep);
SendData;
end else begin
Eventize(FStatus.First.Status, False);
end;
else begin
Eventize(FStatus.First.Status, False);
end;
end;
ssAuthPlain:
case x of
200..299: begin
Eventize(FStatus.First.Status, True);
end;
300..399: begin
AddToBuffer(FStatus.First.Args[1] + FStatus.First.Args[2] + CRLF);
SendData;
end;
else begin
Eventize(FStatus.First.Status, False);
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: begin
FBuffer := FDataBuffer;
AddToBuffer(FDataBuffer);
FDataBuffer := '';
SendData(True);
end;
else begin
FDataBuffer := '';
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;
{ if Assigned(FOnDisconnect) then
FOnDisconnect(FConnection.Iterator);}
Disconnect(False);
end;
end;
@ -447,40 +618,42 @@ begin
FCommandFront.Remove;
end;
procedure TLSMTPClient.ClearCR_LF;
procedure TLSMTPClient.AddToBuffer(s: string);
var
i: Integer;
Skip: Boolean = False;
begin
for i := 1 to Length(FBuffer) do begin
for i := 1 to Length(s) do begin
if Skip then begin
Skip := False;
Continue;
end;
if (FBuffer[i] = #13) or (FBuffer[i] = #10) then begin
if FBuffer[i] = #13 then
if (i < Length(FBuffer)) and (FBuffer[i + 1] = #10) then begin
if (s[i] = #13) or (s[i] = #10) then begin
if s[i] = #13 then
if (i < Length(s)) and (s[i + 1] = #10) then begin
FCharCount := 0;
Skip := True; // skip the crlf
end else begin // insert LF to a standalone CR
System.Insert(#10, FBuffer, i + 1);
System.Insert(#10, s, i + 1);
FCharCount := 0;
Skip := True; // skip the new crlf
end;
if FBuffer[i] = #10 then begin
System.Insert(#13, FBuffer, i);
if s[i] = #10 then begin
System.Insert(#13, s, i);
FCharCount := 0;
Skip := True; // skip the new crlf
end;
end else if FCharCount >= 1000 then begin // line too long
System.Insert(CRLF, FBuffer, i);
System.Insert(CRLF, s, i);
FCharCount := 0;
Skip := True;
end else
Inc(FCharCount);
end;
FBuffer := FBuffer + s;
end;
procedure TLSMTPClient.SendData(const FromStream: Boolean = False);
@ -494,10 +667,10 @@ const
SetLength(s, SBUF_SIZE - Length(FBuffer));
SetLength(s, FStream.Read(s[1], Length(s)));
FBuffer := FBuffer + s;
AddToBuffer(s);
if FStream.Position = FStream.Size then begin // we finished the stream
FBuffer := FBuffer + CRLF + '.' + CRLF;
AddToBuffer(CRLF + '.' + CRLF);
FStream := nil;
end;
end;
@ -512,8 +685,6 @@ begin
n := 1;
Sent := 0;
while (Length(FBuffer) > 0) and (n > 0) do begin
ClearCR_LF;
n := FConnection.SendMessage(FBuffer);
Sent := Sent + n;
if n > 0 then
@ -527,11 +698,32 @@ begin
FOnSent(FConnection.Iterator, Sent);
end;
function TLSMTPClient.EncodeBase64(const s: string): string;
var
Dummy: TBogusStream;
Enc: TBase64EncodingStream;
begin
Result := '';
if Length(s) = 0 then
Exit;
Dummy := TBogusStream.Create;
Enc := TBase64EncodingStream.Create(Dummy);
Enc.Write(s[1], Length(s));
Enc.Free;
SetLength(Result, Dummy.Size);
Dummy.Read(Result[1], Dummy.Size);
Dummy.Free;
end;
function TLSMTPClient.Connect(const aHost: string; const aPort: Word = 25): Boolean;
begin
Result := False;
Disconnect;
Disconnect(True);
if FConnection.Connect(aHost, aPort) then begin
FTempBuffer := '';
FHost := aHost;
FPort := aPort;
FStatus.Insert(MakeStatusRec(ssCon, '', ''));
@ -577,8 +769,7 @@ begin
FSL.CommaText := StringReplace(Recipients, ' ', ',', [rfReplaceAll]);
for i := 0 to FSL.Count-1 do
Rcpt(FSL[i]);
Data('From: ' + From + CRLF + 'Subject: ' + Subject + CRLF + 'To: ' + FSL.CommaText + CRLF + Msg);
Rset;
Data('From: ' + From + CRLF + 'Subject: ' + Subject + CRLF + 'To: ' + FSL.CommaText + CRLF + CRLF + Msg);
end;
end;
@ -598,7 +789,6 @@ begin
for i := 0 to FSL.Count-1 do
Rcpt(FSL[i]);
Data('From: ' + From + CRLF + 'Subject: ' + Subject + CRLF + 'To: ' + FSL.CommaText + CRLF);
Rset;
end;
end;
@ -612,10 +802,11 @@ end;
procedure TLSMTPClient.Helo(aHost: string = '');
begin
if Length(Host) = 0 then
if Length(aHost) = 0 then
aHost := FHost;
if CanContinue(ssHelo, aHost, '') then begin
FBuffer := FBuffer + 'HELO ' + aHost + CRLF;
AddToBuffer('HELO ' + aHost + CRLF);
FStatus.Insert(MakeStatusRec(ssHelo, '', ''));
SendData;
end;
@ -626,16 +817,52 @@ begin
if Length(aHost) = 0 then
aHost := FHost;
if CanContinue(ssEhlo, aHost, '') then begin
FBuffer := FBuffer + 'EHLO ' + aHost + CRLF;
FTempBuffer := ''; // for ehlo response
AddToBuffer('EHLO ' + aHost + CRLF);
FStatus.Insert(MakeStatusRec(ssEhlo, '', ''));
SendData;
end;
end;
procedure TLSMTPClient.StartTLS;
begin
if CanContinue(ssStartTLS, '', '') then begin
AddToBuffer('STARTTLS' + CRLF);
FStatus.Insert(MakeStatusRec(ssStartTLS, '', ''));
SendData;
end;
end;
procedure TLSMTPClient.AuthLogin(aName, aPass: string);
begin
aName := EncodeBase64(aName);
aPass := EncodeBase64(aPass);
FAuthStep := 0; // first, send username
if CanContinue(ssAuthLogin, aName, aPass) then begin
AddToBuffer('AUTH LOGIN' + CRLF);
FStatus.Insert(MakeStatusRec(ssAuthLogin, aName, aPass));
SendData;
end;
end;
procedure TLSMTPClient.AuthPlain(aName, aPass: string);
begin
aName := EncodeBase64(#0 + aName);
aPass := EncodeBase64(#0 + aPass);
FAuthStep := 0;
if CanContinue(ssAuthPlain, aName, aPass) then begin
AddToBuffer('AUTH PLAIN' + CRLF);
FStatus.Insert(MakeStatusRec(ssAuthPlain, aName, aPass));
SendData;
end;
end;
procedure TLSMTPClient.Mail(const From: string);
begin
if CanContinue(ssMail, From, '') then begin
FBuffer := FBuffer + 'MAIL FROM:' + '<' + From + '>' + CRLF;
AddToBuffer('MAIL FROM:' + '<' + From + '>' + CRLF);
FStatus.Insert(MakeStatusRec(ssMail, '', ''));
SendData;
end;
@ -644,7 +871,7 @@ end;
procedure TLSMTPClient.Rcpt(const RcptTo: string);
begin
if CanContinue(ssRcpt, RcptTo, '') then begin
FBuffer := FBuffer + 'RCPT TO:' + '<' + RcptTo + '>' + CRLF;
AddToBuffer('RCPT TO:' + '<' + RcptTo + '>' + CRLF);
FStatus.Insert(MakeStatusRec(ssRcpt, '', ''));
SendData;
end;
@ -653,7 +880,7 @@ end;
procedure TLSMTPClient.Data(const Msg: string);
begin
if CanContinue(ssData, Msg, '') then begin
FBuffer := 'DATA ' + CRLF;
AddToBuffer('DATA ' + CRLF);
FDataBuffer := '';
if Assigned(FStream) then begin
@ -670,7 +897,7 @@ end;
procedure TLSMTPClient.Rset;
begin
if CanContinue(ssRset, '', '') then begin
FBuffer := FBuffer + 'RSET' + CRLF;
AddToBuffer('RSET' + CRLF);
FStatus.Insert(MakeStatusRec(ssRset, '', ''));
SendData;
end;
@ -679,15 +906,15 @@ end;
procedure TLSMTPClient.Quit;
begin
if CanContinue(ssQuit, '', '') then begin
FBuffer := FBuffer + 'QUIT' + CRLF;
AddToBuffer('QUIT' + CRLF);
FStatus.Insert(MakeStatusRec(ssQuit, '', ''));
SendData;
end;
end;
procedure TLSMTPClient.Disconnect;
procedure TLSMTPClient.Disconnect(const Forced: Boolean = True);
begin
FConnection.Disconnect;
FConnection.Disconnect(Forced);
FStatus.Clear;
FCommandFront.Clear;
end;
@ -749,6 +976,11 @@ begin
FMailStream.Remove(aSection);
end;
procedure TMail.Reset;
begin
FMailStream.Reset;
end;
end.

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

@ -1,6 +1,6 @@
{ lNet FastCGI Spawner
CopyRight (C) 2006-2007 Ales Katona
CopyRight (C) 2006-2008 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

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

@ -1,6 +1,6 @@
{ Efficient string buffer helper
Copyright (C) 2006-2007 Micha Nelissen
Copyright (C) 2006-2008 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

143
utils/fppkg/lnet/ltelnet.pp
View File

@ -1,4 +1,4 @@
{ lTelnet CopyRight (C) 2004-2007 Ales Katona
{ lTelnet CopyRight (C) 2004-2008 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
@ -76,7 +76,7 @@ type
FStack: TLControlStack;
FConnection: TLTcp;
FPossible: TLTelnetControlChars;
FActive: TLTelnetControlChars;
FActiveOpts: TLTelnetControlChars;
FOutput: TMemoryStream;
FOperation: Char;
FCommandCharIndex: Byte;
@ -86,25 +86,30 @@ type
FOnError: TLSocketErrorEvent;
FCommandArgs: string[3];
FOrders: TLTelnetControlChars;
FConnected: Boolean;
FBuffer: string;
FBuffer: array of Char;
FBufferIndex: Integer;
FBufferEnd: Integer;
procedure InflateBuffer;
function AddToBuffer(const aStr: string): Boolean; inline;
function Question(const Command: Char; const Value: Boolean): Char;
function GetConnected: Boolean;
function GetTimeout: Integer;
procedure SetTimeout(const Value: Integer);
function GetSocketClass: TLSocketClass;
procedure SetSocketClass(Value: TLSocketClass);
function GetSession: TLSession;
procedure SetSesssion(const AValue: TLSession);
procedure SetCreator(AValue: TLComponent); override;
procedure StackFull;
procedure DoubleIAC(var s: string);
procedure TelnetParse(const msg: string);
function TelnetParse(const msg: string): Integer;
procedure React(const Operation, Command: Char); virtual; abstract;
procedure SendCommand(const Command: Char; const Value: Boolean); virtual; abstract;
procedure OnCs(aSocket: TLSocket);
@ -112,7 +117,7 @@ type
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
function Get(var aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; virtual; abstract;
function Get(out aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; virtual; abstract;
function GetMessage(out msg: string; aSocket: TLSocket = nil): Integer; virtual; abstract;
function Send(const aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; virtual; abstract;
@ -123,12 +128,12 @@ type
procedure SetOption(const Option: Char);
procedure UnSetOption(const Option: Char);
procedure Disconnect; override;
procedure Disconnect(const Forced: Boolean = True); override;
procedure SendCommand(const aCommand: Char; const How: TLHowEnum); virtual;
public
property Output: TMemoryStream read FOutput;
property Connected: Boolean read FConnected;
property Connected: Boolean read GetConnected;
property Timeout: Integer read GetTimeout write SetTimeout;
property OnReceive: TLSocketEvent read FOnReceive write FOnReceive;
property OnDisconnect: TLSocketEvent read FOnDisconnect write FOnDisconnect;
@ -136,6 +141,7 @@ type
property OnError: TLSocketErrorEvent read FOnError write FOnError;
property Connection: TLTCP read FConnection;
property SocketClass: TLSocketClass read GetSocketClass write SetSocketClass;
property Session: TLSession read GetSession write SetSesssion;
end;
{ TLTelnetClient }
@ -157,7 +163,7 @@ type
function Connect(const anAddress: string; const aPort: Word): Boolean;
function Connect: Boolean;
function Get(var aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; override;
function Get(out aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; override;
function GetMessage(out msg: string; aSocket: TLSocket = nil): Integer; override;
function Send(const aData; const aSize: Integer; aSocket: TLSocket = nil): Integer; override;
@ -171,7 +177,7 @@ type
implementation
uses
SysUtils;
SysUtils, Math;
var
zz: Char;
@ -183,7 +189,8 @@ constructor TLTelnet.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
FConnection := TLTCP.Create(aOwner);
FConnection := TLTCP.Create(nil);
FConnection.Creator := Self;
FConnection.OnCanSend := @OnCs;
FOutput := TMemoryStream.Create;
@ -194,13 +201,53 @@ end;
destructor TLTelnet.Destroy;
begin
Disconnect;
Disconnect(True);
FOutput.Free;
FConnection.Free;
FStack.Free;
inherited Destroy;
end;
function TLTelnet.GetConnected: Boolean;
begin
Result := FConnection.Connected;
end;
function TLTelnet.GetSession: TLSession;
begin
Result := FConnection.Session;
end;
procedure TLTelnet.SetSesssion(const AValue: TLSession);
begin
FConnection.Session := aValue;
end;
procedure TLTelnet.SetCreator(AValue: TLComponent);
begin
inherited SetCreator(AValue);
FConnection.Creator := aValue;
end;
procedure TLTelnet.InflateBuffer;
var
n: Integer;
begin
n := Max(Length(FBuffer), 25);
SetLength(FBuffer, n * 10);
end;
function TLTelnet.AddToBuffer(const aStr: string): Boolean; inline;
begin
Result := False;
while Length(aStr) + FBufferEnd > Length(FBuffer) do
InflateBuffer;
Move(aStr[1], FBuffer[FBufferEnd], Length(aStr));
Inc(FBufferEnd, Length(aStr));
end;
function TLTelnet.Question(const Command: Char; const Value: Boolean): Char;
begin
Result := TS_NOP;
@ -265,18 +312,21 @@ begin
end;
end;
procedure TLTelnet.TelnetParse(const msg: string);
function TLTelnet.TelnetParse(const msg: string): Integer;
var
i: Longint;
begin
Result := 0;
for i := 1 to Length(msg) do
if (FStack.ItemIndex > 0) or (msg[i] = TS_IAC) then begin
if msg[i] = TS_GA then
FStack.Clear
else
FStack.Push(msg[i])
end else
end else begin
FOutput.WriteByte(Byte(msg[i]));
Inc(Result);
end;
end;
procedure TLTelnet.OnCs(aSocket: TLSocket);
@ -285,18 +335,24 @@ var
begin
n := 1;
while n > 0 do begin
n := FConnection.SendMessage(FBuffer);
while (n > 0) and (FBufferIndex < FBufferEnd) do begin
n := FConnection.Send(FBuffer[FBufferIndex], FBufferEnd - FBufferIndex);
if n > 0 then
System.Delete(FBuffer, 1, n);
Inc(FBufferIndex, n);
end;
if FBufferEnd - FBufferIndex < FBufferIndex then begin // if we can move the "right" side of the buffer back to the left
Move(FBuffer[FBufferIndex], FBuffer[0], FBufferEnd - FBufferIndex);
FBufferEnd := FBufferEnd - FBufferIndex;
FBufferIndex := 0;
end;
end;
function TLTelnet.OptionIsSet(const Option: Char): Boolean;
begin
Result := False;
Result := Option in FActive;
Result := Option in FActiveOpts;
end;
function TLTelnet.RegisterOption(const aOption: Char;
@ -323,10 +379,9 @@ begin
SendCommand(Option, False);
end;
procedure TLTelnet.Disconnect;
procedure TLTelnet.Disconnect(const Forced: Boolean = True);
begin
FConnection.Disconnect;
FConnected := False;
FConnection.Disconnect(Forced);
end;
procedure TLTelnet.SendCommand(const aCommand: Char; const How: TLHowEnum);
@ -334,7 +389,7 @@ begin
{$ifdef debug}
Writeln('**SENT** ', TNames[Char(How)], ' ', TNames[aCommand]);
{$endif}
FBuffer := FBuffer + TS_IAC + Char(How) + aCommand;
AddToBuffer(TS_IAC + Char(How) + aCommand);
OnCs(nil);
end;
@ -348,9 +403,8 @@ begin
FConnection.OnReceive := @OnRe;
FConnection.OnConnect := @OnCo;
FConnected := False;
FPossible := [TS_ECHO, TS_HYI, TS_SGA];
FActive := [];
FActiveOpts := [];
FOrders := [];
end;
@ -372,16 +426,13 @@ procedure TLTelnetClient.OnRe(aSocket: TLSocket);
var
s: string;
begin
if aSocket.GetMessage(s) > 0 then begin
TelnetParse(s);
if Assigned(FOnReceive) then
if aSocket.GetMessage(s) > 0 then
if (TelnetParse(s) > 0) and Assigned(FOnReceive) then
FOnReceive(aSocket);
end;
end;
procedure TLTelnetClient.OnCo(aSocket: TLSocket);
begin
FConnected := True;
if Assigned(FOnConnect) then
FOnConnect(aSocket);
end;
@ -390,21 +441,21 @@ procedure TLTelnetClient.React(const Operation, Command: Char);
procedure Accept(const Operation, Command: Char);
begin
FActive := FActive + [Command];
FActiveOpts := FActiveOpts + [Command];
{$ifdef debug}
Writeln('**SENT** ', TNames[Operation], ' ', TNames[Command]);
{$endif}
FBuffer := FBuffer + TS_IAC + Operation + Command;
AddToBuffer(TS_IAC + Operation + Command);
OnCs(nil);
end;
procedure Refuse(const Operation, Command: Char);
begin
FActive := FActive - [Command];
FActiveOpts := FActiveOpts - [Command];
{$ifdef debug}
Writeln('**SENT** ', TNames[Operation], ' ', TNames[Command]);
{$endif}
FBuffer := FBuffer + TS_IAC + Operation + Command;
AddToBuffer(TS_IAC + Operation + Command);
OnCs(nil);
end;
@ -418,23 +469,23 @@ begin
TS_DONT : if Command in FPossible then Refuse(TS_WONT, Command);
TS_WILL : if Command in FPossible then FActive := FActive + [Command]
TS_WILL : if Command in FPossible then FActiveOpts := FActiveOpts + [Command]
else Refuse(TS_DONT, Command);
TS_WONT : if Command in FPossible then FActive := FActive - [Command];
TS_WONT : if Command in FPossible then FActiveOpts := FActiveOpts - [Command];
end;
end;
procedure TLTelnetClient.SendCommand(const Command: Char; const Value: Boolean);
begin
if FConnected then begin
if Connected then begin
{$ifdef debug}
Writeln('**SENT** ', TNames[Question(Command, Value)], ' ', TNames[Command]);
{$endif}
case Question(Command, Value) of
TS_WILL : FActive := FActive + [Command];
TS_WILL : FActiveOpts := FActiveOpts + [Command];
end;
FBuffer := FBuffer + TS_IAC + Question(Command, Value) + Command;
AddToBuffer(TS_IAC + Question(Command, Value) + Command);
OnCs(nil);
end;
end;
@ -449,7 +500,7 @@ begin
Result := FConnection.Connect(FHost, FPort);
end;
function TLTelnetClient.Get(var aData; const aSize: Integer; aSocket: TLSocket): Integer;
function TLTelnetClient.Get(out aData; const aSize: Integer; aSocket: TLSocket): Integer;
begin
Result := FOutput.Read(aData, aSize);
if FOutput.Position = FOutput.Size then
@ -484,7 +535,7 @@ begin
if LocalEcho and (not OptionIsSet(TS_ECHO)) and (not OptionIsSet(TS_HYI)) then
FOutput.Write(PChar(Tmp)^, Length(Tmp));
FBuffer := FBuffer + Tmp;
AddToBuffer(Tmp);
OnCs(nil);
Result := aSize;

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

@ -1,6 +1,6 @@
{ lNet Timer
CopyRight (C) 2006-2007 Micha Nelissen
CopyRight (C) 2006-2008 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

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

@ -1,6 +1,6 @@
{ Web server component, built on the HTTP server component
Copyright (C) 2006-2007 Micha Nelissen
Copyright (C) 2006-2008 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
@ -30,7 +30,7 @@ interface
uses
sysutils, classes, lhttp, lhttputil, lmimetypes, levents,
lprocess, process, lfastcgi, fastcgi;
lprocess, process, lfastcgi, fastcgi_base;
type
TLMultipartParameter = (mpContentType, mpContentDisposition, mpContentTransferEncoding,
@ -642,15 +642,17 @@ end;
procedure TCGIOutput.StartRequest;
var
lServerSocket: TLHTTPServerSocket absolute FSocket;
lServerSocket: TLHTTPServerSocket;
tempStr: string;
begin
lServerSocket := TLHTTPServerSocket(FSocket);
{
FProcess.Environment.Add('SERVER_ADDR=');
FProcess.Environment.Add('SERVER_ADMIN=');
FProcess.Environment.Add('SERVER_NAME=');
FProcess.Environment.Add('SERVER_PORT=');
}
Self := nil;
tempStr := TLHTTPServer(lServerSocket.Creator).ServerSoftware;
if Length(tempStr) > 0 then
AddEnvironment('SERVER_SOFTWARE', tempStr);
@ -702,7 +704,7 @@ var
iEnd, lCode: integer;
lStatus, lLength: dword;
pLineEnd, pNextLine, pValue: pchar;
lServerSocket: TLHTTPServerSocket absolute FSocket;
lServerSocket: TLHTTPServerSocket;
procedure AddExtraHeader;
begin
@ -711,6 +713,7 @@ var
end;
begin
lServerSocket := TLHTTPServerSocket(FSocket);
repeat
iEnd := IndexByte(FParsePos^, @FBuffer[FReadPos]-FParsePos, 10);
if iEnd = -1 then exit(false);
@ -874,8 +877,9 @@ end;
procedure TSimpleCGIOutput.CGIOutputError;
var
ServerSocket: TLHTTPServerSocket absolute FSocket;
ServerSocket: TLHTTPServerSocket;
begin
ServerSocket := TLHTTPServerSocket(FSocket);
if FProcess.ExitStatus = 127 then
ServerSocket.FResponseInfo.Status := hsNotFound
else

70
utils/fppkg/lnet/lws2tcpip.pp Normal file
View File

@ -0,0 +1,70 @@
unit lws2tcpip;
{$mode delphi}
interface
uses
WinSock2;
const
ws2tcpip = 'ws2_32.dll';
AI_PASSIVE = $1;
AI_CANONNAME = $2;
AI_NUMERICHOST = $4;
type
LPADDRINFO = ^addrinfo;
addrinfo = record
ai_flags: Integer;
ai_family: Integer;
ai_socktype: Integer;
ai_protocol: Integer;
ai_addrlen: size_t;
ai_canonname: PChar;
ai_addr: PSockAddr;
ai_next: LPADDRINFO;
end;
TAddrInfo = addrinfo;
PAddrInfo = LPADDRINFO;
function getaddrinfo(nodename, servname: PChar; hints: PAddrInfo; var res: PAddrInfo): Integer; stdcall;
procedure freeaddrinfo(ai: PAddrInfo); stdcall;
implementation
uses
dynlibs;
type
TGetAddrInfoFunc = function (nodename, servname: PChar; hints: PAddrInfo; var res: PAddrInfo): Integer; stdcall;
TFreeAddrInfoProc = procedure (ai: PAddrInfo); stdcall;
var
_lib: TLibHandle;
_getaddrinfo: TGetAddrInfoFunc;
_freeaddrinfo: TFreeAddrInfoProc;
function getaddrinfo(nodename, servname: PChar; hints: PAddrInfo;
var res: PAddrInfo): Integer; stdcall;
begin
_getaddrinfo(nodename, servname, hints, res);
end;
procedure freeaddrinfo(ai: PAddrInfo); stdcall;
begin
end;
initialization
_lib := LoadLibrary(ws2tcpip);
_getaddrinfo := GetProcedureAddress(_lib, 'getaddrinfo');
_freeaddrinfo := GetProcedureAddress(_lib, 'freeaddrinfo');
finalization
UnloadLibrary(_lib);
end.

6
utils/fppkg/lnet/sys/lepolleventer.inc
View File

@ -32,14 +32,14 @@ begin
FEpollReadFD := epoll_create(BASE_SIZE);
FEpollMasterFD := epoll_create(2);
if (FEPollFD < 0) or (FEpollReadFD < 0) or (FEpollMasterFD < 0) then
raise Exception.Create('Unable to create epoll');
raise Exception.Create('Unable to create epoll: ' + StrError(fpgeterrno));
lEvent.events := EPOLLIN or EPOLLOUT or EPOLLPRI or EPOLLERR or EPOLLHUP or EPOLLET;
lEvent.data.fd := FEpollFD;
if epoll_ctl(FEpollMasterFD, EPOLL_CTL_ADD, FEpollFD, @lEvent) < 0 then
raise Exception.Create('Unable to add FDs to master epoll FD');
raise Exception.Create('Unable to add FDs to master epoll FD: ' + StrError(fpGetErrno));
lEvent.data.fd := FEpollReadFD;
if epoll_ctl(FEpollMasterFD, EPOLL_CTL_ADD, FEpollReadFD, @lEvent) < 0 then
raise Exception.Create('Unable to add FDs to master epoll FD');
raise Exception.Create('Unable to add FDs to master epoll FD: ' + StrError(fpGetErrno));
end;
destructor TLEpollEventer.Destroy;

2
utils/fppkg/lnet/sys/lkqueueeventer.inc
View File

@ -13,7 +13,7 @@ begin
FTimeout.tv_nsec := 0;
FQueue := KQueue;
if FQueue < 0 then
raise Exception.Create('Unable to create kqueue');
raise Exception.Create('Unable to create kqueue: ' + StrError(fpGetErrno));
end;
destructor TLKQueueEventer.Destroy;

2
utils/fppkg/lnet/sys/lspawnfcgiunix.inc
View File

@ -21,7 +21,7 @@ begin
Exit(LSocketError);
TheSocket:=TLSocket.Create;
TheSocket.Blocking:=True;
TheSocket.SetState(ssBlocking);
if not TheSocket.Listen(aPort) then
Exit(LSocketError);