paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2026-01-04 11:00:33 +01:00
Code Issues Packages Projects Releases Wiki Activity

renamed lang to languages

Browse Source 
removed lnet, FPC trunk now natively supports downloading via http

git-svn-id: trunk@30907 -
This commit is contained in:
darius 2011-05-25 22:26:26 +00:00
parent a9917f268b
commit f83fc69376
26 changed files with 11 additions and 8492 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
.gitattributes vendored
View File

@ -880,26 +880,6 @@ components/fppkg/images/install.png -text
components/fppkg/images/lazarus_pkg.png -text
components/fppkg/images/package_manager.png -text
components/fppkg/images/update.png -text
components/fppkg/lang/lazarusfppkg.po svneol=native#text/plain
components/fppkg/lnet/lcontainers.inc svneol=native#text/plain
components/fppkg/lnet/lcontainersh.inc svneol=native#text/plain
components/fppkg/lnet/llcommon.pp svneol=native#text/plain
components/fppkg/lnet/llcontrolstack.pp svneol=native#text/plain
components/fppkg/lnet/llevents.pp svneol=native#text/plain
components/fppkg/lnet/llftp.pp svneol=native#text/plain
components/fppkg/lnet/llhttp.pp svneol=native#text/plain
components/fppkg/lnet/llhttputil.pp svneol=native#text/plain
components/fppkg/lnet/llnet.pp svneol=native#text/plain
components/fppkg/lnet/llstrbuffer.pp svneol=native#text/plain
components/fppkg/lnet/lltelnet.pp svneol=native#text/plain
components/fppkg/lnet/lws2tcpip.pp svneol=native#text/plain
components/fppkg/lnet/sys/lepolleventer.inc svneol=native#text/plain
components/fppkg/lnet/sys/lepolleventerh.inc svneol=native#text/plain
components/fppkg/lnet/sys/lkqueueeventer.inc svneol=native#text/plain
components/fppkg/lnet/sys/lkqueueeventerh.inc svneol=native#text/plain
components/fppkg/lnet/sys/lspawnfcgiunix.inc svneol=native#text/plain
components/fppkg/lnet/sys/lspawnfcgiwin.inc svneol=native#text/plain
components/fppkg/lnet/sys/osunits.inc svneol=native#text/plain
components/fppkg/readme.txt svneol=native#text/plain
components/fppkg/src/fppkg_aboutfrm.lfm svneol=native#text/plain
components/fppkg/src/fppkg_aboutfrm.pas svneol=native#text/plain
@ -917,7 +897,6 @@ components/fppkg/src/laz_pkgrepos.pas svneol=native#text/plain
components/fppkg/src/lazaruspackagemanager.lpk svneol=native#text/plain
components/fppkg/src/lazaruspackagemanager.pas svneol=native#text/plain
components/fppkg/src/lazpackagemanagerintf.pas svneol=native#text/plain
components/fppkg/src/pkglnet.pp svneol=native#text/plain
components/fppkg/standalone/lazarusfppkg.ico -text
components/fppkg/standalone/lazarusfppkg.lpi svneol=native#text/plain
components/fppkg/standalone/lazarusfppkg.pas svneol=native#text/plain

161
components/fppkg/lang/lazarusfppkg.po
View File

@ -1,161 +0,0 @@
msgid ""
msgstr "Content-Type: text/plain; charset=UTF-8"
#: TFPPKGFORM.ARCHIVEBUTTON.CAPTION
msgid "Archive"
msgstr ""
#: TFPPKGFORM.ARCHIVEBUTTON.HINT
msgid "Create archive of package"
msgstr ""
#: TFPPKGFORM.BUILDBUTTON.CAPTION
msgid "Build"
msgstr ""
#: TFPPKGFORM.BUILDBUTTON.HINT
msgid "Build package"
msgstr ""
#: TFPPKGFORM.CAPTION
msgid "FppkgForm"
msgstr ""
#: TFPPKGFORM.CATEGORIESLABEL.CAPTION
msgid "Categories:"
msgstr ""
#: TFPPKGFORM.CLEANBUTTON.CAPTION
msgid "Clean"
msgstr ""
#: TFPPKGFORM.CLEANBUTTON.HINT
msgid "Clean package"
msgstr ""
#: TFPPKGFORM.COMPILEBUTTON.CAPTION
msgid "Compile"
msgstr ""
#: TFPPKGFORM.COMPILEBUTTON.HINT
msgid "Compile package"
msgstr ""
#: TFPPKGFORM.DOWNLOADBUTTON.CAPTION
msgid "Download"
msgstr ""
#: TFPPKGFORM.DOWNLOADBUTTON.HINT
msgid "Download package"
msgstr ""
#: TFPPKGFORM.FIXBROKENBUTTON.CAPTION
msgid "Fix broken"
msgstr ""
#: TFPPKGFORM.INSTALLBUTTON.CAPTION
msgid "Install"
msgstr ""
#: TFPPKGFORM.INSTALLBUTTON.HINT
msgid "Install package"
msgstr ""
#: TFPPKGFORM.MENUITEM1.CAPTION
msgid "&Tools"
msgstr ""
#: TFPPKGFORM.MENUITEM2.CAPTION
msgid "&Options..."
msgstr ""
#: TFPPKGFORM.MENUITEM3.CAPTION
msgid "&Help"
msgstr ""
#: TFPPKGFORM.MENUITEM4.CAPTION
msgid "&About"
msgstr ""
#: TFPPKGFORM.MENUITEM5.CAPTION
msgctxt "TFPPKGFORM.MENUITEM5.CAPTION"
msgid "-"
msgstr ""
#: TFPPKGFORM.MICLEANMESSAGES.CAPTION
msgid "Clean messages"
msgstr ""
#: TFPPKGFORM.MIEXIT.CAPTION
msgid "&Exit"
msgstr ""
#: TFPPKGFORM.MIFILE.CAPTION
msgid "&File"
msgstr ""
#: TFPPKGFORM.MISELECT.CAPTION
msgid "Select"
msgstr ""
#: TFPPKGFORM.MISEPARATOR.CAPTION
msgctxt "TFPPKGFORM.MISEPARATOR.CAPTION"
msgid "-"
msgstr ""
#: TFPPKGFORM.MISHOWDETAILS.CAPTION
msgid "Show details"
msgstr ""
#: TFPPKGFORM.MIUNSELECT.CAPTION
msgid "Unselect"
msgstr ""
#: TFPPKGFORM.PACKAGELISTVIEW.COLUMNS[0].CAPTION
msgid "Name"
msgstr ""
#: TFPPKGFORM.PACKAGELISTVIEW.COLUMNS[1].CAPTION
msgid "State"
msgstr ""
#: TFPPKGFORM.PACKAGELISTVIEW.COLUMNS[2].CAPTION
msgid "Installed"
msgstr ""
#: TFPPKGFORM.PACKAGELISTVIEW.COLUMNS[3].CAPTION
msgid "Available"
msgstr ""
#: TFPPKGFORM.PACKAGELISTVIEW.COLUMNS[4].CAPTION
msgid "Description"
msgstr ""
#: TFPPKGFORM.SEARCHBUTTON.HINT
msgid "Search for keywords"
msgstr ""
#: TFPPKGFORM.SEARCHLABEL.CAPTION
msgid "Search"
msgstr ""
#: TFPPKGFORM.SUPPORTCHECKGROUP.CAPTION
msgid "Support"
msgstr ""
#: TFPPKGFORM.SUPPORTCHECKGROUP.HINT
msgid "Filter packages on support level"
msgstr ""
#: TFPPKGFORM.TOOLBAR.CAPTION
msgid "ToolBar"
msgstr ""
#: TFPPKGFORM.UPDATEBUTTON.CAPTION
msgid "Update"
msgstr ""
#: TFPPKGFORM.UPDATEBUTTON.HINT
msgid "Update packages list"
msgstr ""

50
components/fppkg/lnet/lcontainers.inc
View File

@ -1,50 +0,0 @@
constructor TLFront.Create(const DefaultItem: __front_type__);
begin
FEmptyItem:=DefaultItem;
Clear;
end;
function TLFront.GetEmpty: Boolean;
begin
Result:=FCount = 0;
end;
function TLFront.First: __front_type__;
begin
Result:=FEmptyItem;
if FCount > 0 then
Result:=FItems[FBottom];
end;
function TLFront.Remove: __front_type__;
begin
Result:=FEmptyItem;
if FCount > 0 then begin
Result:=FItems[FBottom];
Dec(FCount);
Inc(FBottom);
if FBottom >= MAX_FRONT_ITEMS then
FBottom:=0;
end;
end;
function TLFront.Insert(const Value: __front_type__): Boolean;
begin
Result:=False;
if FCount < MAX_FRONT_ITEMS then begin
if FTop >= MAX_FRONT_ITEMS then
FTop:=0;
FItems[FTop]:=Value;
Inc(FCount);
Inc(FTop);
Result:=True;
end;
end;
procedure TLFront.Clear;
begin
FCount:=0;
FBottom:=0;
FTop:=0;
end;

32
components/fppkg/lnet/lcontainersh.inc
View File

@ -1,32 +0,0 @@
{ This include is a little a-la-templates hack
here are all the "default" type defines which you need to
redefine yourself after including this file. You only redefine those
which are used ofcourse }
{$ifndef __front_type__}
{$ERROR Undefined type for quasi-template!}
{$endif}
const
MAX_FRONT_ITEMS = 10;
type
TLFront = class // it's a queue ladies and gents
protected
FEmptyItem: __front_type__;
FItems: array[0..MAX_FRONT_ITEMS-1] of __front_type__;
FTop, FBottom: Integer;
FCount: Integer;
function GetEmpty: Boolean;
public
constructor Create(const DefaultItem: __front_type__);
function First: __front_type__;
function Remove: __front_type__;
function Insert(const Value: __front_type__): Boolean;
procedure Clear;
property Count: Integer read FCount;
property Empty: Boolean read GetEmpty;
end;

536
components/fppkg/lnet/llcommon.pp
View File

@ -1,536 +0,0 @@
{ lCommon
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
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 llCommon;
{$mode objfpc}{$H+}
{$inline on}
interface
uses
{$i sys/osunits.inc}
const
{$IFDEF WINDOWS}
SOL_SOCKET = $ffff;
LMSG = 0;
SOCKET_ERROR = WinSock2.SOCKET_ERROR;
SHUT_RDWR = SD_BOTH;
SHUT_WR = SD_SEND;
{$ENDIF}
{$IFDEF OS2}
SOL_SOCKET = WinSock.SOL_SOCKET;
LMSG = 0;
SOCKET_ERROR = WinSock.SOCKET_ERROR;
{$ENDIF}
{$IFDEF NETWARE}
SOL_SOCKET = WinSock.SOL_SOCKET;
LMSG = 0;
SOCKET_ERROR = WinSock.SOCKET_ERROR;
{$ENDIF}
{$IFDEF UNIX}
INVALID_SOCKET = -1;
SOCKET_ERROR = -1;
{$IFDEF LINUX} // TODO: fix this crap, some don't even have MSG_NOSIGNAL
LMSG = MSG_NOSIGNAL;
{$ELSE}
{$IFDEF FREEBSD}
LMSG = $20000; // FPC BUG in 2.0.4-, freeBSD value
{$ELSE}
LMSG = 0;
{$ENDIF}
{$ENDIF}
{$IFDEF DARWIN}
SO_NOSIGPIPE = $1022; // for fpc 2.0.4
{$ENDIF}
{$ENDIF}
{ Default Values }
LDEFAULT_BACKLOG = 5;
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}
function fpSelect(const nfds: Integer; const readfds, writefds, exceptfds: PFDSet;
const timeout: PTimeVal): Integer; inline;
function fpFD_ISSET(const Socket: Integer; var FDSet: TFDSet): Integer; inline;
procedure fpFD_SET(const Socket: Integer; var FDSet: TFDSet); inline;
procedure fpFD_ZERO(var FDSet: TFDSet); inline;
{$ENDIF}
{ 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;
function StrToHostAddr(const IP: string): Cardinal; inline;
function HostAddrToStr(const Entry: Cardinal): string; inline;
function StrToNetAddr(const IP: string): Cardinal; inline;
function NetAddrToStr(const Entry: Cardinal): string; inline;
procedure FillAddressInfo(var aAddrInfo: TLSocketAddress; const aFamily: sa_family_t;
const Address: string; const aPort: Word);
implementation
uses
StrUtils
{$IFNDEF UNIX}
{$IFDEF WINDOWS}
, Windows, lws2tcpip;
{$IFDEF WINCE}
function LStrError(const Ernum: Longint; const UseUTF8: Boolean = False): string;
const
MAX_ERROR = 1024;
var
Tmp: string;
TmpW: widestring;
begin
Result := '[' + IntToStr(Ernum) + '] ';
SetLength(TmpW, MAX_ERROR);
SetLength(TmpW, FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM or
FORMAT_MESSAGE_IGNORE_INSERTS or
FORMAT_MESSAGE_ARGUMENT_ARRAY,
nil, Ernum, 0, @TmpW[1], MAX_ERROR, nil));
Tmp := UTF8Encode(TmpW);
if Length(Tmp) > 2 then
Delete(Tmp, Length(Tmp)-1, 2);
Result := Tmp;
end;
{$ELSE} // any other windows
function LStrError(const Ernum: Longint; const UseUTF8: Boolean = False): string;
const
MAX_ERROR = 1024;
var
Tmp: string;
TmpW: widestring;
begin
Result := ' [' + IntToStr(Ernum) + ']: ';
if USEUtf8 then begin
SetLength(TmpW, MAX_ERROR);
SetLength(TmpW, FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM or
FORMAT_MESSAGE_IGNORE_INSERTS or
FORMAT_MESSAGE_ARGUMENT_ARRAY,
nil, Ernum, 0, @TmpW[1], MAX_ERROR, nil));
Tmp := UTF8Encode(TmpW);
end else begin
SetLength(Tmp, MAX_ERROR);
SetLength(Tmp, FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or
FORMAT_MESSAGE_IGNORE_INSERTS or
FORMAT_MESSAGE_ARGUMENT_ARRAY,
nil, Ernum, 0, @Tmp[1], MAX_ERROR, nil));
end;
if Length(Tmp) > 2 then
Delete(Tmp, Length(Tmp)-1, 2);
Result := Result + Tmp;
end;
{$ENDIF}
function TZSeconds: integer; inline;
var
lInfo: Windows.TIME_ZONE_INFORMATION;
begin
{ lInfo.Bias is in minutes }
if Windows.GetTimeZoneInformation(@lInfo) <> $FFFFFFFF then
Result := lInfo.Bias * 60
else
Result := 0;
end;
{$ELSE}
; // uses
function LStrError(const Ernum: Longint; const UseUTF8: Boolean = False): string;
begin
Result := IntToStr(Ernum); // TODO: fix for non-windows winsock users
end;
function TZSeconds: integer; inline;
begin
Result := 0; // todo: fix for non-windows non unix
end;
{$ENDIF}
function LSocketError: Longint;
begin
Result := WSAGetLastError;
end;
function CleanError(const Ernum: Longint): Byte;
begin
Result := Byte(Ernum - 10000);
end;
function fpSelect(const nfds: Integer; const readfds, writefds, exceptfds: PFDSet;
const timeout: PTimeVal): Longint; inline;
begin
Result := Select(nfds, readfds, writefds, exceptfds, timeout);
end;
function fpFD_ISSET(const Socket: Longint; var FDSet: TFDSet): Integer; inline;
begin
Result := 0;
if FD_ISSET(Socket, FDSet) then
Result := 1;
end;
procedure fpFD_SET(const Socket: Longint; var FDSet: TFDSet); inline;
begin
FD_SET(Socket, FDSet);
end;
procedure fpFD_ZERO(var FDSet: TFDSet); inline;
begin
FD_ZERO(FDSet);
end;
function GetHostName(const Address: string): string;
var
HE: PHostEnt;
Addr: DWord;
begin
Result := '';
HE := nil;
Addr := inet_addr(PChar(Address));
HE := gethostbyaddr(@Addr, SizeOf(Addr), AF_INET);
if Assigned(HE) then
Result := HE^.h_name;
end;
function GetHostIP(const Name: string): string;
var
HE: PHostEnt;
P: PDWord;
begin
Result := '';
HE := nil;
HE := gethostbyname(PChar(Name));
if Assigned(HE) then begin
P := Pointer(HE^.h_addr_list[0]);
Result := NetAddrToStr(P^);
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);
var
opt: DWord;
begin
opt := BlockAr[aValue];
if ioctlsocket(aHandle, Longint(FIONBIO), opt) = SOCKET_ERROR then
Exit(False);
Result := True;
end;
function IsBlockError(const anError: Integer): Boolean; inline;
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
,Errors, UnixUtil;
function LStrError(const Ernum: Longint; const UseUTF8: Boolean = False): string;
begin
Result := ' [' + IntToStr(Ernum) + ']: ' + Errors.StrError(Ernum);
end;
function LSocketError: Longint;
begin
Result := fpgeterrno;
end;
function CleanError(const Ernum: Longint): Longint; inline;
begin
Result := Byte(Ernum);
end;
function GetHostName(const Address: string): string;
var
HE: THostEntry;
begin
Result := '';
if GetHostbyAddr(in_addr(StrToHostAddr(Address)), HE) then
Result := HE.Name
else if ResolveHostbyAddr(in_addr(StrToHostAddr(Address)), HE) then
Result := HE.Name;
end;
function GetHostIP(const Name: string): string;
var
HE: THostEntry;
begin
Result := '';
if GetHostByName(Name, HE) then
Result := HostAddrToStr(Cardinal(HE.Addr)) // for localhost
else if ResolveHostByName(Name, HE) then
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;
begin
opt := fpfcntl(aHandle, F_GETFL);
if opt = SOCKET_ERROR then
Exit(False);
if aValue then
opt := opt and not O_NONBLOCK
else
opt := opt or O_NONBLOCK;
if fpfcntl(aHandle, F_SETFL, opt) = SOCKET_ERROR then
Exit(False);
Result := True;
end;
function IsBlockError(const anError: Integer): Boolean; inline;
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;
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));
end;
function HostAddrToStr(const Entry: Cardinal): string; inline;
begin
Result := Sockets.HostAddrToStr(in_addr(Entry));
end;
function StrToNetAddr(const IP: string): Cardinal; inline;
begin
Result := Cardinal(Sockets.StrToNetAddr(IP));
end;
function NetAddrToStr(const Entry: Cardinal): string; inline;
begin
Result := Sockets.NetAddrToStr(in_addr(Entry));
end;
function IsIP6Empty(const aIP6: TInetSockAddr6): Boolean; inline;
var
i: Integer;
begin
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;
end.

102
components/fppkg/lnet/llcontrolstack.pp
View File

@ -1,102 +0,0 @@
{ Control stack
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
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 for more inFormation.
Should you find these sources withOut a LICENSE File, please contact
me at ales@chello.sk
}
unit llControlStack;
{$mode objfpc}
interface
const
TL_CSLENGTH = 3;
type
TLOnFull = procedure of object;
TLControlStack = class
private
FItems: array of Char;
FIndex: Byte;
FOnFull: TLOnFull;
function GetFull: Boolean;
function GetItem(const i: Byte): Char;
procedure SetItem(const i: Byte; const Value: Char);
public
constructor Create;
procedure Clear;
procedure Push(const Value: Char);
property ItemIndex: Byte read FIndex;
property Items[i: Byte]: Char read GetItem write SetItem; default;
property Full: Boolean read GetFull;
property OnFull: TLOnFull read FOnFull write FOnFull;
end;
implementation
uses
llTelnet;
constructor TLControlStack.Create;
begin
FOnFull:=nil;
FIndex:=0;
SetLength(FItems, TL_CSLENGTH);
end;
function TLControlStack.GetFull: Boolean;
begin
Result:=False;
if FIndex >= TL_CSLENGTH then
Result:=True;
end;
function TLControlStack.GetItem(const i: Byte): Char;
begin
Result:=TS_NOP;
if i < TL_CSLENGTH then
Result:=FItems[i];
end;
procedure TLControlStack.SetItem(const i: Byte; const Value: Char);
begin
if i < TL_CSLENGTH then
FItems[i]:=Value;
end;
procedure TLControlStack.Clear;
begin
FIndex:=0;
end;
procedure TLControlStack.Push(const Value: Char);
begin
if FIndex < TL_CSLENGTH then begin
FItems[FIndex]:=Value;
Inc(FIndex);
if Full and Assigned(FOnFull) then
FOnFull;
end;
end;
end.

623
components/fppkg/lnet/llevents.pp
View File

@ -1,623 +0,0 @@
{ lNet Events abstration
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
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 llEvents;
{$mode objfpc}{$H+}
{$inline on}
{$define nochoice} // let's presume we don't have "optimized" eventer
interface
uses
{$ifdef Linux}
{$undef nochoice} // undefine for all "Optimized" targets
Linux, Contnrs, Errors,
{$endif}
{$ifdef BSD}
{$undef nochoice}
BSD, Errors,
{$endif}
{$i sys/osunits.inc}
type
TLHandle = class;
TLEventer = class;
TLHandleEvent = procedure (aHandle: TLHandle) of object;
TLHandleErrorEvent = procedure (aHandle: TLHandle; const msg: string) of object;
TLEventerErrorEvent = procedure (const msg: string; Sender: TLEventer) of object;
{ TLHandle }
TLHandle = class(TObject)
protected
FHandle: THandle;
FEventer: TLEventer; // "queue holder"
FOnRead: TLHandleEvent;
FOnWrite: TLHandleEvent;
FOnError: TLHandleErrorEvent;
FIgnoreWrite: Boolean; // so we can do edge-triggered
FIgnoreRead: Boolean; // so we can do edge-triggered
FIgnoreError: Boolean; // so we can do edge-triggered
FDispose: Boolean; // will free in the after-cycle
FFreeing: Boolean; // used to see if it's in the "to be freed" list
FPrev: TLHandle;
FNext: TLHandle;
FFreeNext: TLHandle;
FInternalData: Pointer;
procedure SetIgnoreError(const aValue: Boolean);
procedure SetIgnoreWrite(const aValue: Boolean);
procedure SetIgnoreRead(const aValue: Boolean);
public
UserData: Pointer;
constructor Create; virtual;
destructor Destroy; override;
procedure Free; virtual; // this is a trick
property Prev: TLHandle read FPrev write FPrev;
property Next: TLHandle read FNext write FNext;
property FreeNext: TLHandle read FFreeNext write FFreeNext;
property IgnoreWrite: Boolean read FIgnoreWrite write SetIgnoreWrite;
property IgnoreRead: Boolean read FIgnoreRead write SetIgnoreRead;
property IgnoreError: Boolean read FIgnoreError write SetIgnoreError;
property OnRead: TLHandleEvent read FOnRead write FOnRead;
property OnWrite: TLHandleEvent read FOnWrite write FOnWrite;
property OnError: TLHandleErrorEvent read FOnError write FOnError;
property Dispose: Boolean read FDispose write FDispose;
property Handle: THandle read FHandle write FHandle;
property Eventer: TLEventer read FEventer;
end;
{ TLTimer }
{
TLTimer = class(TObject)
protected
FOnTimer: TNotifyEvent;
FInterval: TDateTime;
FTimeout: TDateTime;
FPeriodic: Boolean;
FEnabled: Boolean;
FNext: TLTimer;
function GetInterval: Integer;
procedure SetEnabled(NewEnabled: Boolean);
procedure SetInterval(NewInterval: Integer);
public
procedure CallAction;
property Enabled: Boolean read FEnabled write SetEnabled;
property Interval: Integer read GetInterval write SetInterval;
property Periodic: Boolean read FPeriodic write FPeriodic;
property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
end;
}
{ TLTimeoutManager }
{
TLSetTimeout = procedure(NewTimeout: DWord) of object;
TLTimeoutManager = class
protected
FFirst: TLTimer;
FLast: TLTimer;
FTimeout: DWord;
FSetTimeout: TLSetTimeout;
public
destructor Destroy; override;
procedure AddTimer(ATimer: TLTimer);
procedure RemoveTimer(ATimer: TLTimer);
procedure CallAction;
end;
}
{ TLEventer }
TLEventer = class
protected
FRoot: TLHandle;
FCount: Integer;
FOnError: TLEventerErrorEvent;
FReferences: Integer;
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;
procedure AddForFree(aHandle: TLHandle);
procedure FreeHandles;
procedure HandleIgnoreError(aHandle: TLHandle); virtual;
procedure HandleIgnoreWrite(aHandle: TLHandle); virtual;
procedure HandleIgnoreRead(aHandle: TLHandle); virtual;
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);
procedure UnregisterHandle(aHandle: TLHandle); virtual;
procedure LoadFromEventer(aEventer: TLEventer); virtual;
procedure Clear;
procedure AddRef;
procedure DeleteRef;
property Timeout: Integer read GetTimeout write SetTimeout;
property OnError: TLEventerErrorEvent read FOnError write FOnError;
property Count: Integer read GetCount;
end;
TLEventerClass = class of TLEventer;
{ TLSelectEventer }
TLSelectEventer = class(TLEventer)
protected
FTimeout: TTimeVal;
FReadFDSet: TFDSet;
FWriteFDSet: TFDSet;
FErrorFDSet: TFDSet;
function GetTimeout: Integer; override;
procedure SetTimeout(const Value: Integer); override;
procedure ClearSets;
public
constructor Create; override;
function CallAction: Boolean; override;
end;
{$i sys/lkqueueeventerh.inc}
{$i sys/lepolleventerh.inc}
function BestEventerClass: TLEventerClass;
implementation
uses
syncobjs,
llCommon;
var
CS: TCriticalSection;
{ TLHandle }
procedure TLHandle.SetIgnoreError(const aValue: Boolean);
begin
if FIgnoreError <> aValue then begin
FIgnoreError := aValue;
if Assigned(FEventer) then
FEventer.HandleIgnoreError(Self);
end;
end;
procedure TLHandle.SetIgnoreWrite(const aValue: Boolean);
begin
if FIgnoreWrite <> aValue then begin
FIgnoreWrite := aValue;
if Assigned(FEventer) then
FEventer.HandleIgnoreWrite(Self);
end;
end;
procedure TLHandle.SetIgnoreRead(const aValue: Boolean);
begin
if FIgnoreRead <> aValue then begin
FIgnoreRead := aValue;
if Assigned(FEventer) then
FEventer.HandleIgnoreRead(Self);
end;
end;
constructor TLHandle.Create;
begin
FOnRead := nil;
FOnWrite := nil;
FOnError := nil;
UserData := nil;
FEventer := nil;
FPrev := nil;
FNext := nil;
FFreeNext := nil;
FFreeing := False;
FDispose := False;
FIgnoreWrite := False;
FIgnoreRead := False;
FIgnoreError := False;
end;
destructor TLHandle.Destroy;
begin
if Assigned(FEventer) then
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 }
{
function TLTimer.GetInterval: Integer;
begin
Result := Round(FInterval * MSecsPerDay);
end;
procedure TLTimer.SetEnabled(NewEnabled: integer);
begin
FTimeout := Now + Interval;
FEnabled := true;
end;
procedure TLTimer.SetInterval(const aValue: Integer);
begin
FInterval := AValue / MSecsPerDay;
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;
}
{ TLEventer }
constructor TLEventer.Create;
begin
FRoot := nil;
FFreeRoot := nil;
FFreeIter := nil;
FInLoop := False;
FCount := 0;
FReferences := 1;
end;
destructor TLEventer.Destroy;
begin
Clear;
end;
function TLEventer.GetCount: Integer;
begin
Result := FCount;
end;
function TLEventer.GetTimeout: Integer;
begin
Result := 0;
end;
procedure TLEventer.SetTimeout(const Value: Integer);
begin
end;
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);
end;
procedure TLEventer.AddForFree(aHandle: TLHandle);
begin
if not aHandle.FFreeing then begin
aHandle.FFreeing := True;
if not Assigned(FFreeIter) then begin
FFreeIter := aHandle;
FFreeRoot := aHandle;
end else begin
FFreeIter.FreeNext := aHandle;
FFreeIter := aHandle;
end;
end;
end;
procedure TLEventer.FreeHandles;
var
Temp, Temp2: TLHandle;
begin
Temp := FFreeRoot;
while Assigned(Temp) do begin
Temp2 := Temp.FreeNext;
Temp.Free;
Temp := Temp2;
end;
FFreeRoot := nil;
FFreeIter := nil;
end;
procedure TLEventer.HandleIgnoreError(aHandle: TLHandle);
begin
end;
procedure TLEventer.HandleIgnoreWrite(aHandle: TLHandle);
begin
end;
procedure TLEventer.HandleIgnoreRead(aHandle: TLHandle);
begin
end;
function TLEventer.GetInternalData(aHandle: TLHandle): Pointer;
begin
Result := aHandle.FInternalData;
end;
procedure TLEventer.SetInternalData(aHandle: TLHandle; const aData: Pointer);
begin
aHandle.FInternalData := aData;
end;
procedure TLEventer.SetHandleEventer(aHandle: TLHandle);
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;
if not Assigned(aHandle.FEventer) then begin
if not Assigned(FRoot) then begin
FRoot := aHandle;
end else begin
if Assigned(FRoot.FNext) then begin
FRoot.FNext.FPrev := aHandle;
aHandle.FNext := FRoot.FNext;
end;
FRoot.FNext := aHandle;
aHandle.FPrev := FRoot;
end;
aHandle.FEventer := Self;
Inc(FCount);
Result := True;
end;
end;
function TLEventer.CallAction: Boolean;
begin
Result := True;
// override in ancestor
end;
procedure TLEventer.RemoveHandle(aHandle: TLHandle);
begin
aHandle.Free;
end;
procedure TLEventer.UnplugHandle(aHandle: TLHandle);
begin
CS.Enter;
InternalUnplugHandle(aHandle);
CS.Leave;
end;
procedure TLEventer.UnregisterHandle(aHandle: TLHandle);
begin
// do nothing, specific to win32 LCLEventer crap (windows is shit)
end;
procedure TLEventer.LoadFromEventer(aEventer: TLEventer);
begin
Clear;
FRoot := aEventer.FRoot;
FOnError := aEventer.FOnError;
end;
procedure TLEventer.Clear;
var
Temp1, Temp2: TLHandle;
begin
Temp1 := FRoot;
Temp2 := FRoot;
while Assigned(Temp2) do begin
Temp1 := Temp2;
Temp2 := Temp1.FNext;
Temp1.Free;
end;
FRoot := nil;
end;
procedure TLEventer.AddRef;
begin
Inc(FReferences);
end;
procedure TLEventer.DeleteRef;
begin
if FReferences > 0 then
Dec(FReferences);
if FReferences = 0 then
Free;
end;
{ TLSelectEventer }
constructor TLSelectEventer.Create;
begin
inherited Create;
FTimeout.tv_sec := 0;
FTimeout.tv_usec := 0;
end;
function TLSelectEventer.GetTimeout: Integer;
begin
if FTimeout.tv_sec < 0 then
Result := -1
else
Result := (FTimeout.tv_sec * 1000) + FTimeout.tv_usec;
end;
procedure TLSelectEventer.SetTimeout(const Value: Integer);
begin
if Value >= 0 then begin
FTimeout.tv_sec := Value div 1000;
FTimeout.tv_usec := Value mod 1000;
end else begin
FTimeout.tv_sec := -1;
FTimeout.tv_usec := 0;
end;
end;
procedure TLSelectEventer.ClearSets;
begin
fpFD_ZERO(FReadFDSet);
fpFD_ZERO(FWriteFDSet);
fpFD_ZERO(FErrorFDSet);
end;
function TLSelectEventer.CallAction: Boolean;
var
Temp, Temp2: TLHandle;
n: Integer;
MaxHandle: THandle;
TempTime: TTimeVal;
begin
if FInLoop then
Exit;
if not Assigned(FRoot) then begin
Sleep(FTimeout.tv_sec * 1000 + FTimeout.tv_usec div 1000);
Exit;
end;
FInLoop := True;
Temp := FRoot;
MaxHandle := 0;
ClearSets;
while Assigned(Temp) do begin
if (not Temp.FDispose ) // handle still valid
and ( (not Temp.IgnoreWrite) // check write or
or (not Temp.IgnoreRead ) // check read or
or (not Temp.IgnoreError)) // check for errors
then begin
if not Temp.IgnoreWrite then
fpFD_SET(Temp.FHandle, FWriteFDSet);
if not Temp.IgnoreRead then
fpFD_SET(Temp.FHandle, FReadFDSet);
if not Temp.IgnoreError then
fpFD_SET(Temp.FHandle, FErrorFDSet);
if Temp.FHandle > MaxHandle then
MaxHandle := Temp.FHandle;
end;
Temp2 := Temp;
Temp := Temp.FNext;
if Temp2.FDispose then
Temp2.Free;
end;
TempTime := FTimeout;
if FTimeout.tv_sec >= 0 then
n := fpSelect(MaxHandle + 1, @FReadFDSet, @FWriteFDSet, @FErrorFDSet, @TempTime)
else
n := fpSelect(MaxHandle + 1, @FReadFDSet, @FWriteFDSet, @FErrorFDSet, nil);
if n < 0 then
Bail('Error on select', LSocketError);
Result := n > 0;
if Result then begin
Temp := FRoot;
while Assigned(Temp) do begin
if not Temp.FDispose and (fpFD_ISSET(Temp.FHandle, FWriteFDSet) <> 0) then
if Assigned(Temp.FOnWrite) and not Temp.IgnoreWrite then
Temp.FOnWrite(Temp);
if not Temp.FDispose and (fpFD_ISSET(Temp.FHandle, FReadFDSet) <> 0) then
if Assigned(Temp.FOnRead) and not Temp.IgnoreRead then
Temp.FOnRead(Temp);
if not Temp.FDispose and (fpFD_ISSET(Temp.FHandle, FErrorFDSet) <> 0) then
if Assigned(Temp.FOnError) and not Temp.IgnoreError then
Temp.FOnError(Temp, 'Handle error' + LStrError(LSocketError));
Temp2 := Temp;
Temp := Temp.FNext;
if Temp2.FDispose then
AddForFree(Temp2);
end;
end;
FInLoop := False;
if Assigned(FFreeRoot) then
FreeHandles;
end;
{$i sys/lkqueueeventer.inc}
{$i sys/lepolleventer.inc}
{$ifdef nochoice}
function BestEventerClass: TLEventerClass;
begin
Result := TLSelectEventer;
end;
{$endif}
initialization
CS := TCriticalSection.Create;
finalization
CS.Free;
end.

1244
components/fppkg/lnet/llftp.pp
View File

File diff suppressed because it is too large Load Diff

2312
components/fppkg/lnet/llhttp.pp
View File

File diff suppressed because it is too large Load Diff

301
components/fppkg/lnet/llhttputil.pp
View File

@ -1,301 +0,0 @@
{ Utility routines for HTTP server component
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
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 llHTTPUtil;
{$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;
function DecomposeURL(const URL: string; out Host, URI: string; out Port: Word): Boolean;
function ComposeURL(Host, URI: string; const Port: Word): string;
implementation
uses
llCommon;
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;
function DecomposeURL(const URL: string; out Host, URI: string; out Port: Word): Boolean;
var
n: Integer;
tmp: string;
begin
Result := False;
try
tmp := Trim(URL);
if Length(tmp) < 1 then // don't do empty
Exit;
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 := StringReplace(Trim(URI), '%20', ' ', [rfReplaceAll]);
if (Pos('http://', Host) <> 1)
and (Pos('https://', Host) <> 1) then
Host := 'http://' + Host;
if URI[Length(URI)] = '/' then
Delete(URI, Length(URI), 1);
if (Host[Length(Host)] = '/')
and (URI[1] = '/') then
Delete(Host, Length(Host), 1)
else if (URI[1] <> '/')
and (Host[Length(Host)] <> '/') then
Host := Host + '/';
Result := Host + URI + ':' + IntToStr(Port);
end;
end.

1694
components/fppkg/lnet/llnet.pp
View File

File diff suppressed because it is too large Load Diff

91
components/fppkg/lnet/llstrbuffer.pp
View File

@ -1,91 +0,0 @@
{ Efficient string buffer helper
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
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 llStrBuffer;
{$mode objfpc}{$h+}
interface
type
PStringBuffer = ^TStringBuffer;
TStringBuffer = record
Memory: pchar;
Pos: pchar;
end;
function InitStringBuffer(InitialSize: integer): TStringBuffer;
procedure AppendString(var ABuffer: TStringBuffer; const ASource: string); overload;
procedure AppendString(var ABuffer: TStringBuffer; const ASource: shortstring); overload;
procedure AppendString(var ABuffer: TStringBuffer; ASource: pointer; ALength: PtrUInt); overload;
procedure AppendString(var ABuffer: TStringBuffer; ASource: pchar); overload;
procedure AppendChar(var ABuffer: TStringBuffer; AChar: char);
implementation
function InitStringBuffer(InitialSize: integer): TStringBuffer;
begin
Result.Memory := GetMem(InitialSize);
Result.Pos := Result.Memory;
end;
procedure AppendString(var ABuffer: TStringBuffer; ASource: pointer; ALength: PtrUInt);
var
lPos, lSize: PtrUInt;
begin
if ALength = 0 then exit;
lPos := PtrUInt(ABuffer.Pos - ABuffer.Memory);
lSize := PtrUInt(MemSize(ABuffer.Memory));
{ reserve 2 extra spaces }
if lPos + ALength + 2 >= lSize then
begin
ReallocMem(ABuffer.Memory, lPos + ALength + lSize);
ABuffer.Pos := ABuffer.Memory + lPos;
end;
Move(ASource^, ABuffer.Pos^, ALength);
Inc(ABuffer.Pos, ALength);
end;
procedure AppendString(var ABuffer: TStringBuffer; ASource: pchar);
begin
if ASource = nil then exit;
AppendString(ABuffer, ASource, StrLen(ASource));
end;
procedure AppendString(var ABuffer: TStringBuffer; const ASource: shortstring);
begin
AppendString(ABuffer, @ASource[1], Length(ASource));
end;
procedure AppendString(var ABuffer: TStringBuffer; const ASource: string);
begin
AppendString(ABuffer, PChar(ASource), Length(ASource));
end;
procedure AppendChar(var ABuffer: TStringBuffer; AChar: char);
begin
ABuffer.Pos^ := AChar;
Inc(ABuffer.Pos);
end;
end.

570
components/fppkg/lnet/lltelnet.pp
View File

@ -1,570 +0,0 @@
{ 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
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 for more inFormation.
Should you find these sources withOut a LICENSE File, please contact
me at ales@chello.sk
}
unit llTelnet;
{$mode objfpc}{$H+}
//{$define debug}
interface
uses
Classes, llNet, llControlStack;
const
// Telnet printer signals
TS_NUL = #0;
TS_ECHO = #1;
TS_SGA = #3; // Surpass go-ahead
TS_BEL = #7;
TS_BS = #8;
TS_HT = #9;
TS_LF = #10;
TS_VT = #11;
TS_FF = #12;
TS_CR = #13;
// Telnet control signals
TS_NAWS = #31;
TS_DATA_MARK = #128;
TS_BREAK = #129;
TS_HYI = #133; // Hide Your Input
// Data types codes
TS_STDTELNET = #160;
TS_TRANSPARENT = #161;
TS_EBCDIC = #162;
// Control bytes
TS_SE = #240;
TS_NOP = #241;
TS_GA = #249; // go ahead currently ignored(full duplex)
TS_SB = #250;
TS_WILL = #251;
TS_WONT = #252;
TS_DO = #253;
TS_DONT = #254;
// Mother of all power
TS_IAC = #255;
type
TLTelnetClient = class;
TLTelnetControlChars = set of Char;
TLHowEnum = (TE_WILL = 251, TE_WONT, TE_DO, TE_DONW);
{ TLTelnet }
TLTelnet = class(TLComponent, ILDirect)
protected
FStack: TLControlStack;
FConnection: TLTcp;
FPossible: TLTelnetControlChars;
FActiveOpts: TLTelnetControlChars;
FOutput: TMemoryStream;
FOperation: Char;
FCommandCharIndex: Byte;
FOnReceive: TLSocketEvent;
FOnConnect: TLSocketEvent;
FOnDisconnect: TLSocketEvent;
FOnError: TLSocketErrorEvent;
FCommandArgs: string[3];
FOrders: TLTelnetControlChars;
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);
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);
public
constructor Create(aOwner: TComponent); override;
destructor Destroy; override;
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;
function SendMessage(const msg: string; aSocket: TLSocket = nil): Integer; virtual; abstract;
function OptionIsSet(const Option: Char): Boolean;
function RegisterOption(const aOption: Char; const aCommand: Boolean): Boolean;
procedure SetOption(const Option: Char);
procedure UnSetOption(const Option: Char);
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 GetConnected;
property Timeout: Integer read GetTimeout write SetTimeout;
property OnReceive: TLSocketEvent read FOnReceive write FOnReceive;
property OnDisconnect: TLSocketEvent read FOnDisconnect write FOnDisconnect;
property OnConnect: TLSocketEvent read FOnConnect write FOnConnect;
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 }
TLTelnetClient = class(TLTelnet, ILClient)
protected
FLocalEcho: Boolean;
procedure OnEr(const msg: string; aSocket: TLSocket);
procedure OnDs(aSocket: TLSocket);
procedure OnRe(aSocket: TLSocket);
procedure OnCo(aSocket: TLSocket);
procedure React(const Operation, Command: Char); override;
procedure SendCommand(const Command: Char; const Value: Boolean); override;
public
constructor Create(aOwner: TComponent); override;
function Connect(const anAddress: string; const aPort: Word): Boolean;
function Connect: Boolean;
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;
function SendMessage(const msg: string; aSocket: TLSocket = nil): Integer; override;
procedure CallAction; override;
public
property LocalEcho: Boolean read FLocalEcho write FLocalEcho;
end;
implementation
uses
SysUtils, Math;
var
zz: Char;
TNames: array[Char] of string;
//*******************************TLTelnetClient********************************
constructor TLTelnet.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
FConnection := TLTCP.Create(nil);
FConnection.Creator := Self;
FConnection.OnCanSend := @OnCs;
FOutput := TMemoryStream.Create;
FCommandCharIndex := 0;
FStack := TLControlStack.Create;
FStack.OnFull := @StackFull;
end;
destructor TLTelnet.Destroy;
begin
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;
if Value then begin
if Command in FOrders then
Result := TS_DO
else
Result := TS_WILL;
end else begin
if Command in FOrders then
Result := TS_DONT
else
Result := TS_WONT;
end;
end;
function TLTelnet.GetSocketClass: TLSocketClass;
begin
Result := FConnection.SocketClass;
end;
function TLTelnet.GetTimeout: Integer;
begin
Result := FConnection.Timeout;
end;
procedure TLTelnet.SetSocketClass(Value: TLSocketClass);
begin
FConnection.SocketClass := Value;
end;
procedure TLTelnet.SetTimeout(const Value: Integer);
begin
FConnection.Timeout := Value;
end;
procedure TLTelnet.StackFull;
begin
{$ifdef debug}
Writeln('**STACKFULL**');
{$endif}
if FStack[1] = TS_IAC then
begin
FOutput.WriteByte(Byte(FStack[1]));
FOutput.WriteByte(Byte(FStack[2]));
end else React(FStack[1], FStack[2]);
FStack.Clear;
end;
procedure TLTelnet.DoubleIAC(var s: string);
var
i: Longint;
begin
i := 0;
if Length(s) > 0 then
while i < Length(s) do begin
Inc(i);
if s[i] = TS_IAC then begin
Insert(TS_IAC, s, i);
Inc(i, 2);
end;
end;
end;
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 begin
FOutput.WriteByte(Byte(msg[i]));
Inc(Result);
end;
end;
procedure TLTelnet.OnCs(aSocket: TLSocket);
var
n: Integer;
begin
n := 1;
while (n > 0) and (FBufferIndex < FBufferEnd) do begin
n := FConnection.Send(FBuffer[FBufferIndex], FBufferEnd - FBufferIndex);
if n > 0 then
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 FActiveOpts;
end;
function TLTelnet.RegisterOption(const aOption: Char;
const aCommand: Boolean): Boolean;
begin
Result := False;
if not (aOption in FPossible) then begin
FPossible := FPossible + [aOption];
if aCommand then
FOrders := FOrders + [aOption];
Result := True;
end;
end;
procedure TLTelnet.SetOption(const Option: Char);
begin
if Option in FPossible then
SendCommand(Option, True);
end;
procedure TLTelnet.UnSetOption(const Option: Char);
begin
if Option in FPossible then
SendCommand(Option, False);
end;
procedure TLTelnet.Disconnect(const Forced: Boolean = True);
begin
FConnection.Disconnect(Forced);
end;
procedure TLTelnet.SendCommand(const aCommand: Char; const How: TLHowEnum);
begin
{$ifdef debug}
Writeln('**SENT** ', TNames[Char(How)], ' ', TNames[aCommand]);
{$endif}
AddToBuffer(TS_IAC + Char(How) + aCommand);
OnCs(nil);
end;
//****************************TLTelnetClient*****************************
constructor TLTelnetClient.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
FConnection.OnError := @OnEr;
FConnection.OnDisconnect := @OnDs;
FConnection.OnReceive := @OnRe;
FConnection.OnConnect := @OnCo;
FPossible := [TS_ECHO, TS_HYI, TS_SGA];
FActiveOpts := [];
FOrders := [];
end;
procedure TLTelnetClient.OnEr(const msg: string; aSocket: TLSocket);
begin
if Assigned(FOnError) then
FOnError(msg, aSocket)
else
FOutput.Write(Pointer(msg)^, Length(msg));
end;
procedure TLTelnetClient.OnDs(aSocket: TLSocket);
begin
if Assigned(FOnDisconnect) then
FOnDisconnect(aSocket);
end;
procedure TLTelnetClient.OnRe(aSocket: TLSocket);
var
s: string;
begin
if aSocket.GetMessage(s) > 0 then
if (TelnetParse(s) > 0) and Assigned(FOnReceive) then
FOnReceive(aSocket);
end;
procedure TLTelnetClient.OnCo(aSocket: TLSocket);
begin
if Assigned(FOnConnect) then
FOnConnect(aSocket);
end;
procedure TLTelnetClient.React(const Operation, Command: Char);
procedure Accept(const Operation, Command: Char);
begin
FActiveOpts := FActiveOpts + [Command];
{$ifdef debug}
Writeln('**SENT** ', TNames[Operation], ' ', TNames[Command]);
{$endif}
AddToBuffer(TS_IAC + Operation + Command);
OnCs(nil);
end;
procedure Refuse(const Operation, Command: Char);
begin
FActiveOpts := FActiveOpts - [Command];
{$ifdef debug}
Writeln('**SENT** ', TNames[Operation], ' ', TNames[Command]);
{$endif}
AddToBuffer(TS_IAC + Operation + Command);
OnCs(nil);
end;
begin
{$ifdef debug}
Writeln('**GOT** ', TNames[Operation], ' ', TNames[Command]);
{$endif}
case Operation of
TS_DO : if Command in FPossible then Accept(TS_WILL, Command)
else Refuse(TS_WONT, Command);
TS_DONT : if Command in FPossible then Refuse(TS_WONT, Command);
TS_WILL : if Command in FPossible then FActiveOpts := FActiveOpts + [Command]
else Refuse(TS_DONT, Command);
TS_WONT : if Command in FPossible then FActiveOpts := FActiveOpts - [Command];
end;
end;
procedure TLTelnetClient.SendCommand(const Command: Char; const Value: Boolean);
begin
if Connected then begin
{$ifdef debug}
Writeln('**SENT** ', TNames[Question(Command, Value)], ' ', TNames[Command]);
{$endif}
case Question(Command, Value) of
TS_WILL : FActiveOpts := FActiveOpts + [Command];
end;
AddToBuffer(TS_IAC + Question(Command, Value) + Command);
OnCs(nil);
end;
end;
function TLTelnetClient.Connect(const anAddress: string; const aPort: Word): Boolean;
begin
Result := FConnection.Connect(anAddress, aPort);
end;
function TLTelnetClient.Connect: Boolean;
begin
Result := FConnection.Connect(FHost, FPort);
end;
function TLTelnetClient.Get(out aData; const aSize: Integer; aSocket: TLSocket): Integer;
begin
Result := FOutput.Read(aData, aSize);
if FOutput.Position = FOutput.Size then
FOutput.Clear;
end;
function TLTelnetClient.GetMessage(out msg: string; aSocket: TLSocket): Integer;
begin
Result := 0;
msg := '';
if FOutput.Size > 0 then begin
FOutput.Position := 0;
SetLength(msg, FOutput.Size);
Result := FOutput.Read(PChar(msg)^, Length(msg));
FOutput.Clear;
end;
end;
function TLTelnetClient.Send(const aData; const aSize: Integer;
aSocket: TLSocket): Integer;
var
Tmp: string;
begin
{$ifdef debug}
Writeln('**SEND START** ');
{$endif}
Result := 0;
if aSize > 0 then begin
SetLength(Tmp, aSize);
Move(aData, PChar(Tmp)^, aSize);
DoubleIAC(Tmp);
if LocalEcho and (not OptionIsSet(TS_ECHO)) and (not OptionIsSet(TS_HYI)) then
FOutput.Write(PChar(Tmp)^, Length(Tmp));
AddToBuffer(Tmp);
OnCs(nil);
Result := aSize;
end;
{$ifdef debug}
Writeln('**SEND END** ');
{$endif}
end;
function TLTelnetClient.SendMessage(const msg: string; aSocket: TLSocket
): Integer;
begin
Result := Send(PChar(msg)^, Length(msg));
end;
procedure TLTelnetClient.CallAction;
begin
FConnection.CallAction;
end;
initialization
for zz := #0 to #255 do
TNames[zz] := IntToStr(Ord(zz));
TNames[#1] := 'TS_ECHO';
TNames[#133] := 'TS_HYI';
TNames[#251] := 'TS_WILL';
TNames[#252] := 'TS_WONT';
TNames[#253] := 'TS_DO';
TNames[#254] := 'TS_DONT';
end.

70
components/fppkg/lnet/lws2tcpip.pp
View File

@ -1,70 +0,0 @@
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.

219
components/fppkg/lnet/sys/lepolleventer.inc
View File

@ -1,219 +0,0 @@
{% lepolleventer.inc included by levents.pas }
{$ifdef Linux}
{ TLEpollEventer }
const
BASE_SIZE = 100;
// bug in fpc 2.0.4-
EPOLL_CTL_ADD = 1;
EPOLL_CTL_DEL = 2;
EPOLL_CTL_MOD = 3;
EPOLLIN = $01; { The associated file is available for read(2) operations. }
EPOLLPRI = $02; { There is urgent data available for read(2) operations. }
EPOLLOUT = $04; { The associated file is available for write(2) operations. }
EPOLLERR = $08; { Error condition happened on the associated file descriptor. }
EPOLLHUP = $10; { Hang up happened on the associated file descriptor. }
EPOLLONESHOT = 1 shl 30;
EPOLLET = 1 shl 31; { Sets the Edge Triggered behaviour for the associated file descriptor. }
constructor TLEpollEventer.Create;
var
lEvent: TEpollEvent;
begin
inherited Create;
FFreeList := TFPObjectList.Create;
Inflate;
FTimeout := 0;
FEpollFD := epoll_create(BASE_SIZE);
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: ' + 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: ' + 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: ' + StrError(fpGetErrno));
end;
destructor TLEpollEventer.Destroy;
begin
fpClose(FEpollFD);
FFreeList.Free;
inherited Destroy;
end;
function TLEpollEventer.GetTimeout: Integer;
begin
Result := FTimeout;
end;
procedure TLEpollEventer.SetTimeout(const Value: Integer);
begin
if Value >= 0 then
FTimeout := Value
else
FTimeout := -1;
end;
procedure TLEpollEventer.HandleIgnoreRead(aHandle: TLHandle);
var
lEvent: TEpollEvent;
begin
lEvent.data.ptr := aHandle;
lEvent.events := EPOLLIN or EPOLLPRI or EPOLLHUP;
if not aHandle.IgnoreRead then begin
if epoll_ctl(FEpollReadFD, EPOLL_CTL_ADD, aHandle.Handle, @lEvent) < 0 then
Bail('Error modifying handle for reads', LSocketError);
end else begin
if epoll_ctl(FEpollReadFD, EPOLL_CTL_DEL, aHandle.Handle, @lEvent) < 0 then
Bail('Error modifying handle for reads', LSocketError);
end;
end;
procedure TLEpollEventer.Inflate;
var
OldLength: Integer;
begin
OldLength := Length(FEvents);
if OldLength > 1 then
SetLength(FEvents, Sqr(OldLength))
else
SetLength(FEvents, BASE_SIZE);
SetLength(FEventsRead, Length(FEvents));
end;
function TLEpollEventer.AddHandle(aHandle: TLHandle): Boolean;
var
lEvent: TEpollEvent;
begin
Result := inherited AddHandle(aHandle);
if Result then begin
Result := False;
lEvent.events := EPOLLET or EPOLLOUT or EPOLLERR;
lEvent.data.ptr := aHandle;
if epoll_ctl(FEpollFD, EPOLL_CTL_ADD, aHandle.FHandle, @lEvent) < 0 then
Bail('Error adding handle to epoll', LSocketError);
lEvent.events := EPOLLIN or EPOLLPRI or EPOLLHUP;
if not aHandle.IgnoreRead then begin
if epoll_ctl(FEpollReadFD, EPOLL_CTL_ADD, aHandle.FHandle, @lEvent) < 0 then
Bail('Error adding handle to epoll', LSocketError);
end;
if FCount > High(FEvents) then
Inflate;
end;
end;
function Max(const a, b: Integer): Integer; inline;
begin
if a > b then
Result := a
else
Result := b;
end;
function TLEpollEventer.CallAction: Boolean;
var
i, MasterChanges, Changes, ReadChanges: Integer;
Temp, TempRead: TLHandle;
MasterEvents: array[0..1] of TEpollEvent;
begin
Result := False;
if FInLoop then
Exit;
Changes := 0;
ReadChanges := 0;
MasterChanges := epoll_wait(FEpollMasterFD, @MasterEvents[0], 2, FTimeout);
if MasterChanges > 0 then begin
for i := 0 to MasterChanges - 1 do
if MasterEvents[i].Data.fd = FEpollFD then
Changes := epoll_wait(FEpollFD, @FEvents[0], FCount, 0)
else
ReadChanges := epoll_wait(FEpollReadFD, @FEventsRead[0], FCount, 0);
if (Changes < 0) or (ReadChanges < 0) then
Bail('Error on epoll', LSocketError)
else
Result := Changes + ReadChanges > 0;
if Result then begin
FInLoop := True;
for i := 0 to Max(Changes, ReadChanges) - 1 do begin
Temp := nil;
if i < Changes then begin
Temp := TLHandle(FEvents[i].data.ptr);
if (not Temp.FDispose)
and (FEvents[i].events and EPOLLOUT = EPOLLOUT) then
if Assigned(Temp.FOnWrite) and not Temp.IgnoreWrite then
Temp.FOnWrite(Temp);
if Temp.FDispose then
AddForFree(Temp);
end; // writes
if i < ReadChanges then begin
TempRead := TLHandle(FEventsRead[i].data.ptr);
if (not TempRead.FDispose)
and ((FEventsRead[i].events and EPOLLIN = EPOLLIN)
or (FEventsRead[i].events and EPOLLHUP = EPOLLHUP)
or (FEventsRead[i].events and EPOLLPRI = EPOLLPRI)) then
if Assigned(TempRead.FOnRead) and not TempRead.IgnoreRead then
TempRead.FOnRead(TempRead);
if TempRead.FDispose then
AddForFree(TempRead);
end; // reads
if i < Changes then begin
if not Assigned(Temp) then
Temp := TLHandle(FEvents[i].data.ptr);
if (not Temp.FDispose)
and (FEvents[i].events and EPOLLERR = EPOLLERR) then
if Assigned(Temp.FOnError) and not Temp.IgnoreError then
Temp.FOnError(Temp, 'Handle error' + LStrError(LSocketError));
if Temp.FDispose then
AddForFree(Temp);
end; // errors
end;
FInLoop := False;
if Assigned(FFreeRoot) then
FreeHandles;
end;
end else if MasterChanges < 0 then
Bail('Error on epoll', LSocketError);
end;
function BestEventerClass: TLEventerClass;
var
tmp: THandle;
begin
{$IFNDEF FORCE_SELECT}
try
tmp := epoll_create(1);
if tmp >= 0 then begin
FpClose(tmp);
Result := TLEpollEventer;
end else
Result := TLSelectEventer;
except
Result := TLSelectEventer;
end;
{$ELSE}
Result := TLSelectEventer;
{$ENDIF}
end;
{$endif} // Linux

32
components/fppkg/lnet/sys/lepolleventerh.inc
View File

@ -1,32 +0,0 @@
{% lepolleventerh.inc included by levents.pas }
{$ifdef Linux}
PEpollEvent = ^epoll_event;
TEpollEvent = epoll_event;
PEpollData = ^epoll_data;
TEpollData = epoll_data;
{ TLEpollEventer }
TLEpollEventer = class(TLEventer)
protected
FTimeout: cInt;
FEvents: array of TEpollEvent;
FEventsRead: array of TEpollEvent;
FEpollReadFD: THandle; // this one monitors LT style for READ
FEpollFD: THandle; // this one monitors ET style for other
FEpollMasterFD: THandle; // this one monitors the first two
FFreeList: TFPObjectList;
function GetTimeout: Integer; override;
procedure SetTimeout(const Value: Integer); override;
procedure HandleIgnoreRead(aHandle: TLHandle); override;
procedure Inflate;
public
constructor Create; override;
destructor Destroy; override;
function AddHandle(aHandle: TLHandle): Boolean; override;
function CallAction: Boolean; override;
end;
{$endif} // linux

147
components/fppkg/lnet/sys/lkqueueeventer.inc
View File

@ -1,147 +0,0 @@
{% lkqueueeventer.inc included by levents.pas }
{$ifdef BSD}
{ TLKQueueEventer }
constructor TLKQueueEventer.Create;
begin
inherited Create;
Inflate;
FFreeSlot := 0;
FTimeout.tv_sec := 0;
FTimeout.tv_nsec := 0;
FQueue := KQueue;
if FQueue < 0 then
raise Exception.Create('Unable to create kqueue: ' + StrError(fpGetErrno));
end;
destructor TLKQueueEventer.Destroy;
begin
fpClose(FQueue);
inherited Destroy;
end;
function TLKQueueEventer.GetTimeout: Integer;
begin
Result := FTimeout.tv_sec + FTimeout.tv_nsec * 1000 * 1000;
end;
procedure TLKQueueEventer.SetTimeout(const Value: Integer);
begin
if Value >= 0 then begin
FTimeout.tv_sec := Value div 1000;
FTimeout.tv_nsec := (Value mod 1000) * 1000;
end else begin
FTimeout.tv_sec := -1;
FTimeout.tv_nsec := 0;
end;
end;
procedure TLKQueueEventer.HandleIgnoreRead(aHandle: TLHandle);
const
INBOOL: array[Boolean] of Integer = (EV_ENABLE, EV_DISABLE);
begin
EV_SET(@FChanges[FFreeSlot], aHandle.FHandle, EVFILT_READ,
INBOOL[aHandle.IgnoreRead], 0, 0, Pointer(aHandle));
Inc(FFreeSlot);
if FFreeSlot > Length(FChanges) then
Inflate;
end;
procedure TLKQueueEventer.Inflate;
const
BASE_SIZE = 100;
var
OldLength: Integer;
begin
OldLength := Length(FChanges);
if OldLength > 1 then begin
SetLength(FChanges, Sqr(OldLength));
SetLength(FEvents, Sqr(OldLength));
end else begin
SetLength(FChanges, BASE_SIZE);
SetLength(FEvents, BASE_SIZE);
end;
end;
function TLKQueueEventer.AddHandle(aHandle: TLHandle): Boolean;
begin
Result := inherited AddHandle(aHandle);
if FFreeSlot > Length(FChanges) then
Inflate;
EV_SET(@FChanges[FFreeSlot], aHandle.FHandle, EVFILT_WRITE,
EV_ADD or EV_CLEAR, 0, 0, Pointer(aHandle));
Inc(FFreeSlot);
if FFreeSlot > Length(FChanges) then
Inflate;
if not aHandle.FIgnoreRead then begin
EV_SET(@FChanges[FFreeSlot], aHandle.FHandle, EVFILT_READ,
EV_ADD, 0, 0, Pointer(aHandle));
Inc(FFreeSlot);
end;
end;
function TLKQueueEventer.CallAction: Boolean;
var
i, n: Integer;
Temp: TLHandle;
begin
Result := False;
if FInLoop then
Exit;
if FTimeout.tv_sec >= 0 then
n := KEvent(FQueue, @FChanges[0], FFreeSlot,
@FEvents[0], Length(FEvents), @FTimeout)
else
n := KEvent(FQueue, @FChanges[0], FFreeSlot,
@FEvents[0], Length(FEvents), nil);
FFreeSlot := 0;
if n < 0 then
Bail('Error on kqueue', LSocketError);
Result := n > 0;
if Result then begin
FInLoop := True;
for i := 0 to n-1 do begin
Temp := TLHandle(FEvents[i].uData);
if (not Temp.FDispose)
and (FEvents[i].Filter = EVFILT_WRITE) then
if Assigned(Temp.FOnWrite) and not Temp.IgnoreWrite then
Temp.FOnWrite(Temp);
if (not Temp.FDispose)
and (FEvents[i].Filter = EVFILT_READ) then
if Assigned(Temp.FOnRead) and not Temp.IgnoreRead then
Temp.FOnRead(Temp);
if (not Temp.FDispose)
and ((FEvents[i].Flags and EV_ERROR) > 0) then
if Assigned(Temp.FOnError) and not Temp.IgnoreError then
Temp.FOnError(Temp, 'Handle error' + LStrError(LSocketError));
if Temp.FDispose then
AddForFree(Temp);
end;
FInLoop := False;
if Assigned(FFreeRoot) then
FreeHandles;
end;
end;
function BestEventerClass: TLEventerClass;
begin
{$IFNDEF FORCE_SELECT}
Result := TLKQueueEventer;
{$ELSE}
Result := TLSelectEventer;
{$ENDIF}
end;
{$endif} // BSD

25
components/fppkg/lnet/sys/lkqueueeventerh.inc
View File

@ -1,25 +0,0 @@
{% lkqueueeventerh.inc included by levents.pas }
{$ifdef BSD}
{ TLKQueueEventer }
TLKQueueEventer = class(TLEventer)
protected
FTimeout: TTimeSpec;
FEvents: array of TKEvent;
FChanges: array of TKEvent;
FFreeSlot: Integer;
FQueue: THandle;
function GetTimeout: Integer; override;
procedure SetTimeout(const Value: Integer); override;
procedure HandleIgnoreRead(aHandle: TLHandle); override;
procedure Inflate;
public
constructor Create; override;
destructor Destroy; override;
function AddHandle(aHandle: TLHandle): Boolean; override;
function CallAction: Boolean; override;
end;
{$endif} // bsd

51
components/fppkg/lnet/sys/lspawnfcgiunix.inc
View File

@ -1,51 +0,0 @@
uses
Classes, BaseUnix;
function SpawnFCGIProcess(App, Enviro: string; const aPort: Word): Integer;
var
TheSocket: TLSocket;
i: Integer;
SL: TStringList;
aNil: Pointer = nil;
ppEnv, ppArgs: ppChar;
begin
Result:=FpFork;
if Result = 0 then begin
ppArgs:=@aNil;
for i:=3 to 10000 do
CloseSocket(i);
if CloseSocket(StdInputHandle) <> 0 then
Exit(LSocketError);
TheSocket:=TLSocket.Create;
TheSocket.SetState(ssBlocking);
if not TheSocket.Listen(aPort) then
Exit(LSocketError);
ppEnv:=@aNil;
if Length(Enviro) > 0 then begin
SL:=TStringList.Create;
repeat
i:=Pos(':', Enviro);
if i > 0 then begin
SL.Add(Copy(Enviro, 1, i - 1));
Delete(Enviro, 1, i);
end else
SL.Add(Enviro);
until i = 0;
GetMem(ppEnv, SizeOf(pChar) * (SL.Count + 1));
for i:=0 to SL.Count-1 do
ppEnv[i]:=pChar(SL[i]);
ppEnv[SL.Count]:=nil;
end;
FpExecve(pChar(App), ppArgs, ppEnv);
end else if Result > 0 then
Result:=0; // it went ok
end;

7
components/fppkg/lnet/sys/lspawnfcgiwin.inc
View File

@ -1,7 +0,0 @@
function SpawnFCGIProcess(App, Enviro: string; const aPort: Word): Integer;
begin
Result:=0; // TODO: implement
end;

18
components/fppkg/lnet/sys/osunits.inc
View File

@ -1,18 +0,0 @@
{$ifdef WINDOWS}
Winsock2,
{$endif}
{$ifdef UNIX}
BaseUnix, NetDB,
{$endif}
{$ifdef NETWARE}
WinSock,
{$endif}
{$ifdef OS2}
WinSock,
{$endif}
SysUtils, Sockets;

6
components/fppkg/src/fppkg_mainfrm.pas
View File

@ -49,7 +49,7 @@ uses
// Package Handler components
pkghandler, laz_pkghandler, laz_pkgcommands, pkgcommands,
//downloader
pkgfphttp, pkglnet;
pkgfphttp;
type
TFppkgConfigOptions = record
@ -579,7 +579,7 @@ begin
cfgfile := GetAppConfigFile(False, False);
ForceDirectories(ExtractFilePath(cfgfile));
//make sure the downloader is FPC native
//GlobalOptions.Downloader := 'FPC';
GlobalOptions.Downloader := 'FPC';
GlobalOptions.SaveGlobalToFile(cfgfile);
GeneratedConfig := True;
end;
@ -590,7 +590,7 @@ begin
begin
GlobalOptions.LoadGlobalFromFile(cfgfile);
//make sure the downloader is FPC native
//GlobalOptions.Downloader := 'FPC';
GlobalOptions.Downloader := 'FPC';
if GlobalOptions.SaveInifileChanges and (not UseGlobalConfig or IsSuperUser) then
GlobalOptions.SaveGlobalToFile(cfgfile);
end;

2
components/fppkg/src/laz_pkgcommands.pas
View File

@ -203,7 +203,7 @@ begin
M := AvailableMirrors.FindMirror(P.Mirror);
if M.Protocol <> 'SVN' then
if not Assigned(M) or (M.Protocol <> 'SVN') then
begin
ArchiveFile:=PackageLocalArchive(P);
if not FileExists(ArchiveFile) then

7
components/fppkg/src/lazaruspackagemanager.lpk
View File

@ -8,7 +8,7 @@
<Version Value="10"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\svn;..\src;..\lnet"/>
<OtherUnitFiles Value="..\svn;..\src"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Other>
@ -21,7 +21,6 @@
</CompilerOptions>
<Description Value="A lazarus packagemanager based on FPC's fppkg"/>
<License Value="GPL"/>
<Version Release="1"/>
<Files Count="1">
<Item1>
<Filename Value="lazpackagemanagerintf.pas"/>
@ -29,6 +28,10 @@
<UnitName Value="LazPackageManagerIntf"/>
</Item1>
</Files>
<i18n>
<EnableI18N Value="True"/>
<OutDir Value="..\languages"/>
</i18n>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="3">
<Item1>

178
components/fppkg/src/pkglnet.pp
View File

@ -1,178 +0,0 @@
{$mode objfpc}
{$h+}
unit pkglnet;
interface
uses
SysUtils, Classes,
uriparser,
llnet, llftp, llhttp, pkgdownload,pkgoptions, fprepos;
Type
{ TLNetDownloader }
TLNetDownloader = Class(TBaseDownloader)
private
FQuit: Boolean;
FFTP: TLFTPClient;
FHTTP: TLHTTPClient;
FOutStream: TStream;
URI: TURI;
protected
// callbacks
function OnHttpClientInput(ASocket: TLHTTPClientSocket; ABuffer: pchar;
ASize: Integer): Integer;
procedure OnLNetDisconnect(aSocket: TLSocket);
procedure OnHttpDoneInput(aSocket: TLHTTPClientSocket);
procedure OnLNetError(const msg: string; aSocket: TLSocket);
procedure OnFTPControl(aSocket: TLSocket);
procedure OnFTPReceive(aSocket: TLSocket);
procedure OnFTPSuccess(aSocket: TLSocket; const aStatus: TLFTPStatus);
procedure OnFTPFailure(aSocket: TLSocket; const aStatus: TLFTPStatus);
// overrides
procedure FTPDownload(Const URL : String; Dest : TStream); override;
procedure HTTPDownload(Const URL : String; Dest : TStream); override;
public
constructor Create(AOwner : TComponent); override;
end;
implementation
uses
pkgglobals,
pkgmessages;
{ TLNetDownloader }
function TLNetDownloader.OnHttpClientInput(ASocket: TLHTTPClientSocket;
ABuffer: pchar; ASize: Integer): Integer;
begin
Result:=FOutStream.Write(aBuffer[0], aSize);
end;
procedure TLNetDownloader.OnLNetDisconnect(aSocket: TLSocket);
begin
FQuit:=True;
end;
procedure TLNetDownloader.OnHttpDoneInput(aSocket: TLHTTPClientSocket);
begin
ASocket.Disconnect;
FQuit:=True;
end;
procedure TLNetDownloader.OnLNetError(const msg: string; aSocket: TLSocket);
begin
Error(msg);
FQuit:=True;
end;
procedure TLNetDownloader.OnFTPControl(aSocket: TLSocket);
var
s: string;
begin
FFTP.GetMessage(s); // have to empty OS buffer, write the info if you wish to debug
end;
procedure TLNetDownloader.OnFTPReceive(aSocket: TLSocket);
const
BUF_SIZE = 65536; // standard OS recv buffer size
var
Buf: array[1..BUF_SIZE] of Byte;
begin
FOutStream.Write(Buf[1], FFTP.GetData(Buf[1], BUF_SIZE));
end;
procedure TLNetDownloader.OnFTPSuccess(aSocket: TLSocket;
const aStatus: TLFTPStatus);
begin
FFTP.Disconnect;
FQuit:=True;
end;
procedure TLNetDownloader.OnFTPFailure(aSocket: TLSocket;
const aStatus: TLFTPStatus);
begin
FFTP.Disconnect;
Error(SErrDownloadFailed,['FTP',EncodeURI(URI),'']);
FQuit:=True;
end;
procedure TLNetDownloader.FTPDownload(const URL: String; Dest: TStream);
begin
FOutStream:=Dest;
Try
{ parse URL }
URI:=ParseURI(URL);
if URI.Port = 0 then
URI.Port := 21;
FFTP.Connect(URI.Host, URI.Port);
while not FFTP.Connected and not FQuit do
FFTP.CallAction;
if not FQuit then begin
FFTP.Authenticate(URI.Username, URI.Password);
FFTP.ChangeDirectory(URI.Path);
FFTP.Retrieve(URI.Document);
while not FQuit do
FFTP.CallAction;
end;
finally
FOutStream:=nil;
end;
end;
procedure TLNetDownloader.HTTPDownload(const URL: String; Dest: TStream);
begin
FOutStream:=Dest;
Try
{ parse aURL }
URI := ParseURI(URL);
if URI.Port = 0 then
URI.Port := 80;
FHTTP.Host := URI.Host;
FHTTP.Method := hmGet;
FHTTP.Port := URI.Port;
FHTTP.URI := URI.Path + URI.Document;
FHTTP.SendRequest;
FQuit:=False;
while not FQuit do
FHTTP.CallAction;
if FHTTP.Response.Status<>HSOK then
Error(SErrDownloadFailed,['HTTP',EncodeURI(URI),FHTTP.Response.Reason]);
Finally
FOutStream:=nil; // to be sure
end;
end;
constructor TLNetDownloader.Create(AOwner: TComponent);
begin
inherited;
FFTP:=TLFTPClient.Create(Self);
FFTP.Timeout:=1000;
FFTP.StatusSet:=[fsRetr]; // watch for success/failure of retreives only
FFTP.OnError:=@OnLNetError;
FFTP.OnControl:=@OnFTPControl;
FFTP.OnReceive:=@OnFTPReceive;
FFTP.OnSuccess:=@OnFTPSuccess;
FFTP.OnFailure:=@OnFTPFailure;
FHTTP:=TLHTTPClient.Create(Self);
FHTTP.Timeout := 1000; // go by 1s times if nothing happens
FHTTP.OnDisconnect := @OnLNetDisconnect;
FHTTP.OnDoneInput := @OnHttpDoneInput;
FHTTP.OnError := @OnLNetError;
FHTTP.OnInput := @OnHttpClientInput;
end;
initialization
RegisterDownloader('lnet',TLNetDownloader);
end.

4
components/fppkg/standalone/lazarusfppkg.lpi
View File

@ -16,7 +16,7 @@
</General>
<i18n>
<EnableI18N Value="True"/>
<OutDir Value="..\lang"/>
<OutDir Value="..\languages"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
@ -87,7 +87,7 @@
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="..\src;..\svn;..\lnet"/>
<OtherUnitFiles Value="..\src;..\svn"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>