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

Opkman: Synchronize with FPC trunk. From FPC311 on OPM no longer depends on opkman_httpclient and opkman_zip.

Browse Source 
git-svn-id: trunk@54349 -
This commit is contained in:
balazs 2017-03-06 09:28:48 +00:00
parent 88a333dcd7
commit c5a84bc001
8 changed files with 840 additions and 398 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -3253,6 +3253,7 @@ components/onlinepackagemanager/opkman_createjsonforupdates.pas svneol=native#te
components/onlinepackagemanager/opkman_createrepositorypackage.lfm svneol=native#text/plain components/onlinepackagemanager/opkman_createrepositorypackage.lfm svneol=native#text/plain
components/onlinepackagemanager/opkman_createrepositorypackage.pas svneol=native#text/pascal components/onlinepackagemanager/opkman_createrepositorypackage.pas svneol=native#text/pascal
components/onlinepackagemanager/opkman_downloader.pas svneol=native#text/pascal components/onlinepackagemanager/opkman_downloader.pas svneol=native#text/pascal
components/onlinepackagemanager/opkman_fpcdef.inc svneol=native#text/pascal
components/onlinepackagemanager/opkman_installer.pas svneol=native#text/pascal components/onlinepackagemanager/opkman_installer.pas svneol=native#text/pascal
components/onlinepackagemanager/opkman_mainfrm.lfm svneol=native#text/plain components/onlinepackagemanager/opkman_mainfrm.lfm svneol=native#text/plain
components/onlinepackagemanager/opkman_mainfrm.pas svneol=native#text/pascal components/onlinepackagemanager/opkman_mainfrm.pas svneol=native#text/pascal

432
components/onlinepackagemanager/fpcmod/opkman_httpclient.pas
View File

@ -18,21 +18,10 @@ unit opkman_httpclient;
Todo: Todo:
* Proxy support ? * Proxy support ?
---------------------------------------------------------------------} ---------------------------------------------------------------------}
{
TFPHTTPClient does not implement a timeout/aborting mechanism(2016.10.01), which
is useful when downloading a large file for example. opkman_httpclient and opkman_downloader
fix this issue.
}
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{$IF FPC_VERSION = 3} {$INCLUDE opkman_fpcdef.inc}
{$IF FPC_RELEASE > 0}
{$IF FPC_PATCH > 0}
{$DEFINE FPC311}
{$ENDIF}
{$ENDIF}
{$ENDIF}
interface interface
@ -83,6 +72,7 @@ Type
FDataRead : Int64; FDataRead : Int64;
FContentLength : Int64; FContentLength : Int64;
FAllowRedirect: Boolean; FAllowRedirect: Boolean;
FKeepConnection: Boolean;
FMaxRedirects: Byte; FMaxRedirects: Byte;
FOnDataReceived: TDataEvent; FOnDataReceived: TDataEvent;
FOnHeaders: TNotifyEvent; FOnHeaders: TNotifyEvent;
@ -101,9 +91,9 @@ Type
FServerHTTPVersion: String; FServerHTTPVersion: String;
FSocket : TInetSocket; FSocket : TInetSocket;
FBuffer : Ansistring; FBuffer : Ansistring;
FTerminated: Boolean;
FUserName: String; FUserName: String;
FOnGetSocketHandler : TGetSocketHandlerEvent; FOnGetSocketHandler : TGetSocketHandlerEvent;
FNeedToBreak: Boolean;
FProxy : TProxyData; FProxy : TProxyData;
function CheckContentLength: Int64; function CheckContentLength: Int64;
function CheckTransferEncoding: string; function CheckTransferEncoding: string;
@ -111,11 +101,26 @@ Type
function GetProxy: TProxyData; function GetProxy: TProxyData;
Procedure ResetResponse; Procedure ResetResponse;
Procedure SetCookies(const AValue: TStrings); Procedure SetCookies(const AValue: TStrings);
procedure SetHTTPVersion(const AValue: String);
procedure SetKeepConnection(AValue: Boolean);
procedure SetProxy(AValue: TProxyData); procedure SetProxy(AValue: TProxyData);
Procedure SetRequestHeaders(const AValue: TStrings); Procedure SetRequestHeaders(const AValue: TStrings);
procedure SetIOTimeout(AValue: Integer); procedure SetIOTimeout(AValue: Integer);
Procedure ExtractHostPort(AURI: TURI; Out AHost: String; Out APort: Word);
Procedure CheckConnectionCloseHeader;
protected protected
Function NoContentAllowed(ACode : Integer) : Boolean; Function NoContentAllowed(ACode : Integer) : Boolean;
// Peform a request, close connection.
Procedure DoNormalRequest(const AURI: TURI; const AMethod: string;
AStream: TStream; const AAllowedResponseCodes: array of Integer;
AHeadersOnly, AIsHttps: Boolean); virtual;
// Peform a request, try to keep connection.
Procedure DoKeepConnectionRequest(const AURI: TURI; const AMethod: string;
AStream: TStream; const AAllowedResponseCodes: array of Integer;
AHeadersOnly, AIsHttps: Boolean); virtual;
// Return True if FSocket is assigned
Function IsConnected: Boolean; virtual;
// True if we need to use a proxy: ProxyData Assigned and Hostname Set // True if we need to use a proxy: ProxyData Assigned and Hostname Set
Function ProxyActive : Boolean; Function ProxyActive : Boolean;
// Override this if you want to create a custom instance of proxy. // Override this if you want to create a custom instance of proxy.
@ -127,19 +132,23 @@ Type
// Construct server URL for use in request line. // Construct server URL for use in request line.
function GetServerURL(URI: TURI): String; function GetServerURL(URI: TURI): String;
// Read 1 line of response. Fills FBuffer // Read 1 line of response. Fills FBuffer
function ReadString: String; function ReadString(out S: String): Boolean;
// Check if response code is in AllowedResponseCodes. if not, an exception is raised. // Check if response code is in AllowedResponseCodes. if not, an exception is raised.
// If AllowRedirect is true, and the result is a Redirect status code, the result is also true // If AllowRedirect is true, and the result is a Redirect status code, the result is also true
// If the OnPassword event is set, then a 401 will also result in True. // If the OnPassword event is set, then a 401 will also result in True.
function CheckResponseCode(ACode: Integer; const AllowedResponseCodes: array of Integer): Boolean; virtual; function CheckResponseCode(ACode: Integer; const AllowedResponseCodes: array of Integer): Boolean; virtual;
// Read response from server, and write any document to Stream. // Read response from server, and write any document to Stream.
Procedure ReadResponse(Stream: TStream; const AllowedResponseCodes: array of Integer; HeadersOnly: Boolean = False); virtual; Function ReadResponse(Stream: TStream; const AllowedResponseCodes: array of Integer; HeadersOnly: Boolean = False): Boolean; virtual;
// Read server response line and headers. Returns status code. // Read server response line and headers. Returns status code.
Function ReadResponseHeaders : integer; virtual; Function ReadResponseHeaders : integer; virtual;
// Allow header in request ? (currently checks only if non-empty and contains : token) // Allow header in request ? (currently checks only if non-empty and contains : token)
function AllowHeader(var AHeader: String): Boolean; virtual; function AllowHeader(var AHeader: String): Boolean; virtual;
// Return True if the "connection: close" header is present
Function HasConnectionClose: Boolean; virtual;
// Connect to the server. Must initialize FSocket. // Connect to the server. Must initialize FSocket.
Procedure ConnectToServer(const AHost: String; APort: Integer; UseSSL : Boolean=False); virtual; Procedure ConnectToServer(const AHost: String; APort: Integer; UseSSL : Boolean=False); virtual;
// Re-connect to the server. Must reinitialize FSocket.
Procedure ReconnectToServer(const AHost: String; APort: Integer; UseSSL : Boolean=False); virtual;
// Disconnect from server. Must free FSocket. // Disconnect from server. Must free FSocket.
Procedure DisconnectFromServer; virtual; Procedure DisconnectFromServer; virtual;
// Run method AMethod, using request URL AURL. Write Response to Stream, and headers in ResponseHeaders. // Run method AMethod, using request URL AURL. Write Response to Stream, and headers in ResponseHeaders.
@ -160,13 +169,16 @@ Type
Class Function IndexOfHeader(HTTPHeaders : TStrings; Const AHeader : String) : Integer; Class Function IndexOfHeader(HTTPHeaders : TStrings; Const AHeader : String) : Integer;
// Return value of header AHeader from httpheaders. Returns empty if it doesn't exist yet. // Return value of header AHeader from httpheaders. Returns empty if it doesn't exist yet.
Class Function GetHeader(HTTPHeaders : TStrings; Const AHeader : String) : String; Class Function GetHeader(HTTPHeaders : TStrings; Const AHeader : String) : String;
{ Terminate the current request.
It will stop the client from trying to send and/or receive data after the current chunk is sent/received. }
Procedure Terminate;
// Request Header management // Request Header management
// Return index of header, -1 if not present. // Return index of header, -1 if not present.
Function IndexOfHeader(Const AHeader : String) : Integer; Function IndexOfHeader(Const AHeader : String) : Integer;
// Add header, replacing an existing one if it exists. // Add header, replacing an existing one if it exists.
Procedure AddHeader(Const AHeader,AValue : String); Procedure AddHeader(Const AHeader,AValue : String);
// Return header value, empty if not present. // Return header value, empty if not present.
Function GetHeader(Const AHeader : String) : String; Function GetHeader(Const AHeader : String) : String;
// General-purpose call. Handles redirect and authorization retry (OnPassword). // General-purpose call. Handles redirect and authorization retry (OnPassword).
Procedure HTTPMethod(Const AMethod,AURL : String; Stream : TStream; Const AllowedResponseCodes : Array of Integer); virtual; Procedure HTTPMethod(Const AMethod,AURL : String; Stream : TStream; Const AllowedResponseCodes : Array of Integer); virtual;
// Execute GET on server, store result in Stream, File, StringList or string // Execute GET on server, store result in Stream, File, StringList or string
@ -239,7 +251,7 @@ Type
Procedure FormPost(const URL : string; FormData: TStrings; const Response: TStrings); Procedure FormPost(const URL : string; FormData: TStrings; const Response: TStrings);
function FormPost(const URL, FormData: string): String; function FormPost(const URL, FormData: string): String;
function FormPost(const URL: string; FormData : TStrings): String; function FormPost(const URL: string; FormData : TStrings): String;
// Simple form // Simple form
Class Procedure SimpleFormPost(const URL, FormData: string; const Response: TStream); Class Procedure SimpleFormPost(const URL, FormData: string; const Response: TStream);
Class Procedure SimpleFormPost(const URL : string; FormData: TStrings; const Response: TStream); Class Procedure SimpleFormPost(const URL : string; FormData: TStrings; const Response: TStream);
Class Procedure SimpleFormPost(const URL, FormData: string; const Response: TStrings); Class Procedure SimpleFormPost(const URL, FormData: string; const Response: TStrings);
@ -256,6 +268,8 @@ Type
Procedure StreamFormPost(const AURL: string; FormData: TStrings; const AFieldName, AFileName: string; const AStream: TStream; const Response: TStream); Procedure StreamFormPost(const AURL: string; FormData: TStrings; const AFieldName, AFileName: string; const AStream: TStream; const Response: TStream);
// Simple form of Posting a file // Simple form of Posting a file
Class Procedure SimpleFileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream); Class Procedure SimpleFileFormPost(const AURL, AFieldName, AFileName: string; const Response: TStream);
// Has Terminate been called ?
Property Terminated : Boolean Read FTerminated;
Protected Protected
// Timeouts // Timeouts
Property IOTimeout : Integer read FIOTimeout write SetIOTimeout; Property IOTimeout : Integer read FIOTimeout write SetIOTimeout;
@ -268,7 +282,8 @@ Type
// Optional body to send (mainly in POST request) // Optional body to send (mainly in POST request)
Property RequestBody : TStream read FRequestBody Write FRequestBody; Property RequestBody : TStream read FRequestBody Write FRequestBody;
// used HTTP version when constructing the request. // used HTTP version when constructing the request.
Property HTTPversion : String Read FHTTPVersion Write FHTTPVersion; // Setting this to any other value than 1.1 will set KeepConnection to False.
Property HTTPversion : String Read FHTTPVersion Write SetHTTPVersion;
// After request properties. // After request properties.
// After request, this contains the headers sent by server. // After request, this contains the headers sent by server.
Property ResponseHeaders : TStrings Read FResponseHeaders; Property ResponseHeaders : TStrings Read FResponseHeaders;
@ -292,6 +307,10 @@ Type
// They also override any Authenticate: header in Requestheaders. // They also override any Authenticate: header in Requestheaders.
Property UserName : String Read FUserName Write FUserName; Property UserName : String Read FUserName Write FUserName;
Property Password : String Read FPassword Write FPassword; Property Password : String Read FPassword Write FPassword;
// Is client connected?
Property Connected: Boolean read IsConnected;
// Keep-Alive support. Setting to true will set HTTPVersion to 1.1
Property KeepConnection: Boolean Read FKeepConnection Write SetKeepConnection;
// If a request returns a 401, then the OnPassword event is fired. // If a request returns a 401, then the OnPassword event is fired.
// It can modify the username/password and set RepeatRequest to true; // It can modify the username/password and set RepeatRequest to true;
Property OnPassword : TPasswordEvent Read FOnPassword Write FOnPassword; Property OnPassword : TPasswordEvent Read FOnPassword Write FOnPassword;
@ -301,12 +320,14 @@ Type
Property OnHeaders : TNotifyEvent Read FOnHeaders Write FOnHeaders; Property OnHeaders : TNotifyEvent Read FOnHeaders Write FOnHeaders;
// Called to create socket handler. If not set, or Nil is returned, a standard socket handler is created. // Called to create socket handler. If not set, or Nil is returned, a standard socket handler is created.
Property OnGetSocketHandler : TGetSocketHandlerEvent Read FOnGetSocketHandler Write FOnGetSocketHandler; Property OnGetSocketHandler : TGetSocketHandlerEvent Read FOnGetSocketHandler Write FOnGetSocketHandler;
Property NeedToBreak: Boolean read FNeedToBreak write FNeedToBreak;
end; end;
TFPHTTPClient = Class(TFPCustomHTTPClient) TFPHTTPClient = Class(TFPCustomHTTPClient)
Published Published
Property KeepConnection;
Property Connected;
Property IOTimeout; Property IOTimeout;
Property RequestHeaders; Property RequestHeaders;
Property RequestBody; Property RequestBody;
@ -326,7 +347,6 @@ Type
Property OnHeaders; Property OnHeaders;
Property OnGetSocketHandler; Property OnGetSocketHandler;
Property Proxy; Property Proxy;
Property NeedToBreak;
end; end;
EHTTPClient = Class(EHTTP); EHTTPClient = Class(EHTTP);
@ -335,19 +355,19 @@ Function EncodeURLElement(S : String) : String;
Function DecodeURLElement(Const S : String) : String; Function DecodeURLElement(Const S : String) : String;
implementation implementation
{$IFnDEF HASAMIGA} {$if not defined(hasamiga)}
uses sslsockets; uses sslsockets;
{$ENDIF} {$endif}
resourcestring resourcestring
SErrInvalidProtocol = 'Invalid protocol: "%s"'; SErrInvalidProtocol = 'Invalid protocol : "%s"';
SErrReadingSocket = 'Error reading data from socket'; SErrReadingSocket = 'Error reading data from socket';
SErrInvalidProtocolVersion = 'Invalid protocol version in response: "%s"'; SErrInvalidProtocolVersion = 'Invalid protocol version in response: "%s"';
SErrInvalidStatusCode = 'Invalid response status code: %s'; SErrInvalidStatusCode = 'Invalid response status code: %s';
SErrUnexpectedResponse = 'Unexpected response status code: %d'; SErrUnexpectedResponse = 'Unexpected response status code: %d';
SErrChunkTooBig = 'Chunk too big'; SErrChunkTooBig = 'Chunk too big';
SErrChunkLineEndMissing = 'Chunk line end missing'; SErrChunkLineEndMissing = 'Chunk line end missing';
SErrMaxRedirectsReached = 'Maximum allowed redirects reached: %d'; SErrMaxRedirectsReached = 'Maximum allowed redirects reached : %d';
//SErrRedirectAborted = 'Redirect aborted.'; //SErrRedirectAborted = 'Redirect aborted.';
Const Const
@ -475,6 +495,11 @@ begin
{$ENDIF} {$ENDIF}
end; end;
function TFPCustomHTTPClient.IsConnected: Boolean;
begin
Result := Assigned(FSocket);
end;
function TFPCustomHTTPClient.NoContentAllowed(ACode: Integer): Boolean; function TFPCustomHTTPClient.NoContentAllowed(ACode: Integer): Boolean;
begin begin
Result:=((ACode div 100)=1) or ((ACode=204) or (ACode=304)) Result:=((ACode div 100)=1) or ((ACode=204) or (ACode=304))
@ -545,11 +570,11 @@ begin
if Assigned(FonGetSocketHandler) then if Assigned(FonGetSocketHandler) then
FOnGetSocketHandler(Self,UseSSL,Result); FOnGetSocketHandler(Self,UseSSL,Result);
if (Result=Nil) then if (Result=Nil) then
{$IFnDEF HASAMIGA} {$if not defined(HASAMIGA)}
If UseSSL then If UseSSL then
Result:=TSSLSocketHandler.Create Result:=TSSLSocketHandler.Create
else else
{$ENDIF} {$endif}
Result:=TSocketHandler.Create; Result:=TSocketHandler.Create;
end; end;
@ -561,17 +586,19 @@ Var
begin begin
If IsConnected Then
DisconnectFromServer; // avoid memory leaks
if (Aport=0) then if (Aport=0) then
if UseSSL then if UseSSL then
Aport:=443 Aport:=443
else else
Aport:=80; Aport:=80;
G:=GetSocketHandler(UseSSL); G:=GetSocketHandler(UseSSL);
FSocket:=TInetSocket.Create(AHost,APort,G); FSocket:=TInetSocket.Create(AHost,APort,G);
try try
{$IFDEF FPC311} {$IFDEF FPC311}
if FIOTimeout <> 0 then if FIOTimeout<>0 then
FSocket.IOTimeout := FIOTimeout; FSocket.IOTimeout:=FIOTimeout;
{$ENDIF} {$ENDIF}
FSocket.Connect; FSocket.Connect;
except except
@ -580,6 +607,13 @@ begin
end; end;
end; end;
Procedure TFPCustomHTTPClient.ReconnectToServer(const AHost: String;
APort: Integer; UseSSL: Boolean);
begin
DisconnectFromServer;
ConnectToServer(AHost, APort, UseSSL);
end;
procedure TFPCustomHTTPClient.DisconnectFromServer; procedure TFPCustomHTTPClient.DisconnectFromServer;
begin begin
@ -592,6 +626,11 @@ begin
Result:=(AHeader<>'') and (Pos(':',AHeader)<>0); Result:=(AHeader<>'') and (Pos(':',AHeader)<>0);
end; end;
Function TFPCustomHTTPClient.HasConnectionClose: Boolean;
begin
Result := CompareText(GetHeader('Connection'), 'close') = 0;
end;
procedure TFPCustomHTTPClient.SendRequest(const AMethod: String; URI: TURI); procedure TFPCustomHTTPClient.SendRequest(const AMethod: String; URI: TURI);
Var Var
@ -626,6 +665,7 @@ begin
S:=S+CRLF; S:=S+CRLF;
If Assigned(RequestBody) and (IndexOfHeader('Content-Length')=-1) then If Assigned(RequestBody) and (IndexOfHeader('Content-Length')=-1) then
AddHeader('Content-Length',IntToStr(RequestBody.Size)); AddHeader('Content-Length',IntToStr(RequestBody.Size));
CheckConnectionCloseHeader;
For I:=0 to FRequestHeaders.Count-1 do For I:=0 to FRequestHeaders.Count-1 do
begin begin
l:=FRequestHeaders[i]; l:=FRequestHeaders[i];
@ -648,55 +688,60 @@ begin
FSentCookies:=FCookies; FSentCookies:=FCookies;
FCookies:=Nil; FCookies:=Nil;
S:=S+CRLF; S:=S+CRLF;
FSocket.WriteBuffer(S[1],Length(S)); if not Terminated then
If Assigned(FRequestBody) then FSocket.WriteBuffer(S[1],Length(S));
If Assigned(FRequestBody) and not Terminated then
FSocket.CopyFrom(FRequestBody,FRequestBody.Size); FSocket.CopyFrom(FRequestBody,FRequestBody.Size);
end; end;
function TFPCustomHTTPClient.ReadString : String; function TFPCustomHTTPClient.ReadString(out S: String): Boolean;
Procedure FillBuffer; Function FillBuffer: Boolean;
Var Var
R : Integer; R : Integer;
begin begin
if Terminated then
Exit(False);
SetLength(FBuffer,ReadBufLen); SetLength(FBuffer,ReadBufLen);
r:=FSocket.Read(FBuffer[1],ReadBufLen); r:=FSocket.Read(FBuffer[1],ReadBufLen);
If r<0 then If (r=0) or Terminated Then
Exit(False);
If (r<0) then
Raise EHTTPClient.Create(SErrReadingSocket); Raise EHTTPClient.Create(SErrReadingSocket);
if (r<ReadBuflen) then if (r<ReadBuflen) then
SetLength(FBuffer,r); SetLength(FBuffer,r);
FDataRead:=FDataRead+R; FDataRead:=FDataRead+R;
DoDataRead; DoDataRead;
Result:=r>0;
end; end;
Var Var
CheckLF,Done : Boolean; CheckLF: Boolean;
P,L : integer; P,L : integer;
begin begin
Result:=''; S:='';
Done:=False; Result:=False;
CheckLF:=False; CheckLF:=False;
Repeat Repeat
if NeedToBreak then
Break;
if Length(FBuffer)=0 then if Length(FBuffer)=0 then
FillBuffer; if not FillBuffer then
Break;
if Length(FBuffer)=0 then if Length(FBuffer)=0 then
Done:=True Result:=True
else if CheckLF then else if CheckLF then
begin begin
If (FBuffer[1]<>#10) then If (FBuffer[1]<>#10) then
Result:=Result+#13 S:=S+#13
else else
begin begin
System.Delete(FBuffer,1,1); System.Delete(FBuffer,1,1);
Done:=True; Result:=True;
end; end;
end; end;
if not Done then if not Result then
begin begin
P:=Pos(#13#10,FBuffer); P:=Pos(#13#10,FBuffer);
If P=0 then If P=0 then
@ -704,20 +749,21 @@ begin
L:=Length(FBuffer); L:=Length(FBuffer);
CheckLF:=FBuffer[L]=#13; CheckLF:=FBuffer[L]=#13;
if CheckLF then if CheckLF then
Result:=Result+Copy(FBuffer,1,L-1) S:=S+Copy(FBuffer,1,L-1)
else else
Result:=Result+FBuffer; S:=S+FBuffer;
FBuffer:=''; FBuffer:='';
end end
else else
begin begin
Result:=Result+Copy(FBuffer,1,P-1); S:=S+Copy(FBuffer,1,P-1);
System.Delete(FBuffer,1,P+1); System.Delete(FBuffer,1,P+1);
Done:=True; Result:=True;
end; end;
end; end;
until Done; until Result or Terminated;
end; end;
Function GetNextWord(Var S : String) : string; Function GetNextWord(Var S : String) : string;
Const Const
@ -770,15 +816,13 @@ function TFPCustomHTTPClient.ReadResponseHeaders: integer;
P:=Pos(':',S); P:=Pos(':',S);
System.Delete(S,1,P); System.Delete(S,1,P);
Repeat Repeat
if NeedToBreak then
Break;
P:=Pos(';',S); P:=Pos(';',S);
If (P=0) then If (P=0) then
P:=Length(S)+1; P:=Length(S)+1;
C:=Trim(Copy(S,1,P-1)); C:=Trim(Copy(S,1,P-1));
Cookies.Add(C); Cookies.Add(C);
System.Delete(S,1,P); System.Delete(S,1,P);
Until (S=''); Until (S='') or Terminated;
end; end;
Const Const
@ -788,20 +832,18 @@ Var
StatusLine,S : String; StatusLine,S : String;
begin begin
StatusLine:=ReadString; if not ReadString(StatusLine) then
Exit(0);
Result:=ParseStatusLine(StatusLine); Result:=ParseStatusLine(StatusLine);
Repeat Repeat
if NeedToBreak then if ReadString(S) and (S<>'') then
Break;
S:=ReadString;
if (S<>'') then
begin begin
ResponseHeaders.Add(S); ResponseHeaders.Add(S);
If (LowerCase(Copy(S,1,Length(SetCookie)))=SetCookie) then If (LowerCase(Copy(S,1,Length(SetCookie)))=SetCookie) then
DoCookies(S); DoCookies(S);
end end
Until (S=''); Until (S='') or Terminated;
If Assigned(FOnHeaders) then If Assigned(FOnHeaders) and not Terminated then
FOnHeaders(Self); FOnHeaders(Self);
end; end;
@ -902,14 +944,33 @@ begin
GetCookies.Assign(AValue); GetCookies.Assign(AValue);
end; end;
procedure TFPCustomHTTPClient.SetHTTPVersion(const AValue: String);
begin
if FHTTPVersion = AValue then Exit;
FHTTPVersion := AValue;
if (AValue<>'1.1') then
KeepConnection:=False;
end;
procedure TFPCustomHTTPClient.SetKeepConnection(AValue: Boolean);
begin
if FKeepConnection=AValue then Exit;
FKeepConnection:=AValue;
if AValue then
HTTPVersion:='1.1'
else if IsConnected then
DisconnectFromServer;
CheckConnectionCloseHeader;
end;
procedure TFPCustomHTTPClient.SetProxy(AValue: TProxyData); procedure TFPCustomHTTPClient.SetProxy(AValue: TProxyData);
begin begin
if (AValue=FProxy) then exit; if (AValue=FProxy) then exit;
Proxy.Assign(AValue); Proxy.Assign(AValue);
end; end;
procedure TFPCustomHTTPClient.ReadResponse(Stream: TStream; Function TFPCustomHTTPClient.ReadResponse(Stream: TStream;
const AllowedResponseCodes: array of Integer; HeadersOnly: Boolean); const AllowedResponseCodes: array of Integer; HeadersOnly: Boolean): Boolean;
Function Transfer(LB : Integer) : Integer; Function Transfer(LB : Integer) : Integer;
@ -944,6 +1005,9 @@ procedure TFPCustomHTTPClient.ReadResponse(Stream: TStream;
function FetchData(out Cnt: integer): boolean; function FetchData(out Cnt: integer): boolean;
begin begin
Result:=False;
If Terminated then
exit;
SetLength(FBuffer,ReadBuflen); SetLength(FBuffer,ReadBuflen);
Cnt:=FSocket.Read(FBuffer[1],length(FBuffer)); Cnt:=FSocket.Read(FBuffer[1],length(FBuffer));
If Cnt<0 then If Cnt<0 then
@ -984,31 +1048,28 @@ procedure TFPCustomHTTPClient.ReadResponse(Stream: TStream;
begin begin
BufPos:=1; BufPos:=1;
repeat repeat
if NeedToBreak then
Break;
// read ChunkSize // read ChunkSize
ChunkSize:=0; ChunkSize:=0;
repeat repeat
if NeedToBreak then
Break;
if ReadData(@c,1)<1 then exit; if ReadData(@c,1)<1 then exit;
case c of case c of
'0'..'9': ChunkSize:=ChunkSize*16+ord(c)-ord('0'); '0'..'9': ChunkSize:=ChunkSize*16+ord(c)-ord('0');
'a'..'f': ChunkSize:=ChunkSize*16+ord(c)-ord('a')+10; 'a'..'f': ChunkSize:=ChunkSize*16+ord(c)-ord('a')+10;
'A'..'F': ChunkSize:=ChunkSize*16+ord(c)-ord('A')+10; 'A'..'F': ChunkSize:=ChunkSize*16+ord(c)-ord('A')+10;
else break; else
break;
end; end;
if ChunkSize>1000000 then if ChunkSize>1000000 then
Raise EHTTPClient.Create(SErrChunkTooBig); Raise EHTTPClient.Create(SErrChunkTooBig);
until false; until Terminated;
// read till line end // read till line end
while (c<>#10) do while (c<>#10) and not Terminated do
if ReadData(@c,1)<1 then exit; if ReadData(@c,1)<1 then exit;
if ChunkSize=0 then exit; if ChunkSize=0 then exit;
// read data // read data
repeat repeat
if NeedToBreak then if Terminated then
Break; exit;
l:=length(FBuffer)-BufPos+1; l:=length(FBuffer)-BufPos+1;
if l=0 then if l=0 then
if not FetchData(l) then if not FetchData(l) then
@ -1024,14 +1085,18 @@ procedure TFPCustomHTTPClient.ReadResponse(Stream: TStream;
end; end;
until ChunkSize=0; until ChunkSize=0;
// read #13#10 // read #13#10
if ReadData(@c,1)<1 then exit; if ReadData(@c,1)<1 then
if c<>#13 then exit;
Raise EHTTPClient.Create(SErrChunkLineEndMissing); if Not Terminated then
if ReadData(@c,1)<1 then exit; begin
if c<>#10 then if c<>#13 then
Raise EHTTPClient.Create(SErrChunkLineEndMissing); Raise EHTTPClient.Create(SErrChunkLineEndMissing);
// next chunk if ReadData(@c,1)<1 then exit;
until false; if c<>#10 then
Raise EHTTPClient.Create(SErrChunkLineEndMissing);
// next chunk
end;
until Terminated;
end; end;
Var Var
@ -1043,6 +1108,9 @@ begin
FContentLength:=0; FContentLength:=0;
SetLength(FBuffer,0); SetLength(FBuffer,0);
FResponseStatusCode:=ReadResponseHeaders; FResponseStatusCode:=ReadResponseHeaders;
Result := FResponseStatusCode > 0;
if not Result then
Exit;
if not CheckResponseCode(FResponseStatusCode,AllowedResponseCodes) then if not CheckResponseCode(FResponseStatusCode,AllowedResponseCodes) then
Raise EHTTPClient.CreateFmt(SErrUnexpectedResponse,[ResponseStatusCode]); Raise EHTTPClient.CreateFmt(SErrUnexpectedResponse,[ResponseStatusCode]);
if HeadersOnly Or (AllowRedirect and IsRedirect(FResponseStatusCode)) then if HeadersOnly Or (AllowRedirect and IsRedirect(FResponseStatusCode)) then
@ -1064,34 +1132,122 @@ begin
// We cannot use copyfrom, it uses ReadBuffer, and this is dangerous with sockets // We cannot use copyfrom, it uses ReadBuffer, and this is dangerous with sockets
L:=L-LB; L:=L-LB;
Repeat Repeat
if NeedToBreak then
Break;
LB:=ReadBufLen; LB:=ReadBufLen;
If (LB>L) then If (LB>L) then
LB:=L; LB:=L;
R:=Transfer(LB); R:=Transfer(LB);
L:=L-R; L:=L-R;
until (L=0) or (R=0); until (L=0) or (R=0) or Terminated;
end end
else if (L<0) and (Not NoContentAllowed(ResponseStatusCode)) then else if (L<0) and (Not NoContentAllowed(ResponseStatusCode)) then
begin begin
// No content-length, so we read till no more data available. // No content-length, so we read till no more data available.
Repeat Repeat
if NeedToBreak then
Break;
R:=Transfer(ReadBufLen); R:=Transfer(ReadBufLen);
until (R=0); until (R=0) or Terminated;
end; end;
end; end;
end; end;
procedure TFPCustomHTTPClient.DoMethod(const AMethod, AURL: String; Procedure TFPCustomHTTPClient.ExtractHostPort(AURI: TURI; Out AHost: String;
Stream: TStream; const AllowedResponseCodes: array of Integer); Out APort: Word);
Begin
if ProxyActive then
begin
AHost:=Proxy.Host;
APort:=Proxy.Port;
end
else
begin
AHost:=AURI.Host;
APort:=AURI.Port;
end;
End;
procedure TFPCustomHTTPClient.CheckConnectionCloseHeader;
Var Var
URI : TURI; I : integer;
P,CHost : String; N,V : String;
CPort : Word;
begin
V:=GetHeader('Connection');
If FKeepConnection Then
begin
I:=IndexOfHeader(FRequestHeaders,'Connection');
If i>-1 Then
begin
// It can be keep-alive, check value
FRequestHeaders.GetNameValue(I,N,V);
If CompareText(V,'close')=0 then
FRequestHeaders.Delete(i);
end
end
Else
AddHeader('Connection', 'close');
end;
Procedure TFPCustomHTTPClient.DoNormalRequest(const AURI: TURI;
const AMethod: string; AStream: TStream;
const AAllowedResponseCodes: array of Integer;
AHeadersOnly, AIsHttps: Boolean);
Var
CHost: string;
CPort: Word;
begin
ExtractHostPort(AURI, CHost, CPort);
ConnectToServer(CHost,CPort,AIsHttps);
Try
SendRequest(AMethod,AURI);
if not Terminated then
ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
Finally
DisconnectFromServer;
End;
end;
Procedure TFPCustomHTTPClient.DoKeepConnectionRequest(const AURI: TURI;
const AMethod: string; AStream: TStream;
const AAllowedResponseCodes: array of Integer;
AHeadersOnly, AIsHttps: Boolean);
Var
T: Boolean;
CHost: string;
CPort: Word;
begin
ExtractHostPort(AURI, CHost, CPort);
T := False;
Repeat
If Not IsConnected Then
ConnectToServer(CHost,CPort,AIsHttps);
Try
if not Terminated then
SendRequest(AMethod,AURI);
if not Terminated then
begin
T := ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
If Not T Then
ReconnectToServer(CHost,CPort,AIsHttps);
end;
Finally
// On terminate, we close the request
If HasConnectionClose or Terminated Then
DisconnectFromServer;
End;
Until T or Terminated;
end;
Procedure TFPCustomHTTPClient.DoMethod(Const AMethod, AURL: String;
Stream: TStream; Const AllowedResponseCodes: Array of Integer);
Var
URI: TURI;
P: String;
IsHttps, HeadersOnly: Boolean;
begin begin
ResetResponse; ResetResponse;
@ -1099,23 +1255,12 @@ begin
p:=LowerCase(URI.Protocol); p:=LowerCase(URI.Protocol);
If Not ((P='http') or (P='https')) then If Not ((P='http') or (P='https')) then
Raise EHTTPClient.CreateFmt(SErrInvalidProtocol,[URI.Protocol]); Raise EHTTPClient.CreateFmt(SErrInvalidProtocol,[URI.Protocol]);
if ProxyActive then IsHttps:=P='https';
begin HeadersOnly:=CompareText(AMethod,'HEAD')=0;
CHost:=Proxy.Host; if FKeepConnection then
CPort:=Proxy.Port; DoKeepConnectionRequest(URI,AMethod,Stream,AllowedResponseCodes,HeadersOnly,IsHttps)
end
else else
begin DoNormalRequest(URI,AMethod,Stream,AllowedResponseCodes,HeadersOnly,IsHttps);
CHost:=URI.Host;
CPort:=URI.Port;
end;
ConnectToServer(CHost,CPort,P='https');
try
SendRequest(AMethod,URI);
ReadResponse(Stream,AllowedResponseCodes,CompareText(AMethod,'HEAD')=0);
finally
DisconnectFromServer;
end;
end; end;
constructor TFPCustomHTTPClient.Create(AOwner: TComponent); constructor TFPCustomHTTPClient.Create(AOwner: TComponent);
@ -1124,13 +1269,17 @@ begin
// Infinite timeout on most platforms // Infinite timeout on most platforms
FIOTimeout:=0; FIOTimeout:=0;
FRequestHeaders:=TStringList.Create; FRequestHeaders:=TStringList.Create;
FRequestHeaders.NameValueSeparator:=':';
FResponseHeaders:=TStringList.Create; FResponseHeaders:=TStringList.Create;
FHTTPVersion:='1.1'; FResponseHeaders.NameValueSeparator:=':';
HTTPVersion:='1.1';
FMaxRedirects:=DefMaxRedirects; FMaxRedirects:=DefMaxRedirects;
end; end;
destructor TFPCustomHTTPClient.Destroy; destructor TFPCustomHTTPClient.Destroy;
begin begin
if IsConnected then
DisconnectFromServer;
FreeAndNil(FProxy); FreeAndNil(FProxy);
FreeAndNil(FCookies); FreeAndNil(FCookies);
FreeAndNil(FSentCookies); FreeAndNil(FSentCookies);
@ -1184,6 +1333,11 @@ begin
end; end;
end; end;
procedure TFPCustomHTTPClient.Terminate;
begin
FTerminated:=True;
end;
procedure TFPCustomHTTPClient.ResetResponse; procedure TFPCustomHTTPClient.ResetResponse;
begin begin
@ -1204,19 +1358,19 @@ Var
RR : Boolean; // Repeat request ? RR : Boolean; // Repeat request ?
begin begin
// Reset Terminated
FTerminated:=False;
L:=AURL; L:=AURL;
RC:=0; RC:=0;
RR:=False; RR:=False;
M:=AMethod; M:=AMethod;
Repeat Repeat
if FNeedToBreak then
Break;
if Not AllowRedirect then if Not AllowRedirect then
DoMethod(M,L,Stream,AllowedResponseCodes) DoMethod(M,L,Stream,AllowedResponseCodes)
else else
begin begin
DoMethod(M,L,Stream,AllowedResponseCodes); DoMethod(M,L,Stream,AllowedResponseCodes);
if IsRedirect(FResponseStatusCode) then if IsRedirect(FResponseStatusCode) and not Terminated then
begin begin
Inc(RC); Inc(RC);
if (RC>MaxRedirects) then if (RC>MaxRedirects) then
@ -1242,8 +1396,8 @@ begin
FOnPassword(Self,RR); FOnPassword(Self,RR);
end end
else else
RR:=AllowRedirect and IsRedirect(FResponseStatusCode) and (L<>'') RR:=AllowRedirect and IsRedirect(FResponseStatusCode) and (L<>'');
until not RR; until Terminated or not RR ;
end; end;
procedure TFPCustomHTTPClient.Get(const AURL: String; Stream: TStream); procedure TFPCustomHTTPClient.Get(const AURL: String; Stream: TStream);
@ -1310,7 +1464,7 @@ class procedure TFPCustomHTTPClient.SimpleGet(const AURL: String;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Get(AURL,Stream); Get(AURL,Stream);
finally finally
Free; Free;
@ -1324,7 +1478,7 @@ class procedure TFPCustomHTTPClient.SimpleGet(const AURL: String;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Get(AURL,LocalFileName); Get(AURL,LocalFileName);
finally finally
Free; Free;
@ -1338,7 +1492,7 @@ class procedure TFPCustomHTTPClient.SimpleGet(const AURL: String;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Get(AURL,Response); Get(AURL,Response);
finally finally
Free; Free;
@ -1347,7 +1501,7 @@ end;
class function TFPCustomHTTPClient.SimpleGet(const AURL: String): String; class function TFPCustomHTTPClient.SimpleGet(const AURL: String): String;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
@ -1406,7 +1560,7 @@ class procedure TFPCustomHTTPClient.SimplePost(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Post(URL,Response); Post(URL,Response);
finally finally
Free; Free;
@ -1420,7 +1574,7 @@ class procedure TFPCustomHTTPClient.SimplePost(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Post(URL,Response); Post(URL,Response);
finally finally
Free; Free;
@ -1434,7 +1588,7 @@ class procedure TFPCustomHTTPClient.SimplePost(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Post(URL,LocalFileName); Post(URL,LocalFileName);
finally finally
Free; Free;
@ -1447,7 +1601,7 @@ class function TFPCustomHTTPClient.SimplePost(const URL: string): String;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Result:=Post(URL); Result:=Post(URL);
finally finally
Free; Free;
@ -1498,7 +1652,7 @@ class procedure TFPCustomHTTPClient.SimplePut(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Put(URL,Response); Put(URL,Response);
finally finally
Free; Free;
@ -1511,7 +1665,7 @@ class procedure TFPCustomHTTPClient.SimplePut(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Put(URL,Response); Put(URL,Response);
finally finally
Free; Free;
@ -1524,7 +1678,7 @@ class procedure TFPCustomHTTPClient.SimplePut(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Put(URL,LocalFileName); Put(URL,LocalFileName);
finally finally
Free; Free;
@ -1536,7 +1690,7 @@ class function TFPCustomHTTPClient.SimplePut(const URL: string): String;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Result:=Put(URL); Result:=Put(URL);
finally finally
Free; Free;
@ -1588,7 +1742,7 @@ class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Delete(URL,Response); Delete(URL,Response);
finally finally
Free; Free;
@ -1601,7 +1755,7 @@ class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Delete(URL,Response); Delete(URL,Response);
finally finally
Free; Free;
@ -1614,7 +1768,7 @@ class procedure TFPCustomHTTPClient.SimpleDelete(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Delete(URL,LocalFileName); Delete(URL,LocalFileName);
finally finally
Free; Free;
@ -1626,7 +1780,7 @@ class function TFPCustomHTTPClient.SimpleDelete(const URL: string): String;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Result:=Delete(URL); Result:=Delete(URL);
finally finally
Free; Free;
@ -1678,7 +1832,7 @@ class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Options(URL,Response); Options(URL,Response);
finally finally
Free; Free;
@ -1691,7 +1845,7 @@ class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Options(URL,Response); Options(URL,Response);
finally finally
Free; Free;
@ -1704,7 +1858,7 @@ class procedure TFPCustomHTTPClient.SimpleOptions(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Options(URL,LocalFileName); Options(URL,LocalFileName);
finally finally
Free; Free;
@ -1716,7 +1870,7 @@ class function TFPCustomHTTPClient.SimpleOptions(const URL: string): String;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Result:=Options(URL); Result:=Options(URL);
finally finally
Free; Free;
@ -1727,7 +1881,7 @@ class procedure TFPCustomHTTPClient.Head(AURL: String; Headers: TStrings);
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
HTTPMethod('HEAD', AURL, Nil, [200]); HTTPMethod('HEAD', AURL, Nil, [200]);
Headers.Assign(ResponseHeaders); Headers.Assign(ResponseHeaders);
Finally Finally
@ -1812,7 +1966,7 @@ class procedure TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
FormPost(URL,FormData,Response); FormPost(URL,FormData,Response);
Finally Finally
Free; Free;
@ -1826,7 +1980,7 @@ class procedure TFPCustomHTTPClient.SimpleFormPost(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
FormPost(URL,FormData,Response); FormPost(URL,FormData,Response);
Finally Finally
Free; Free;
@ -1840,7 +1994,7 @@ class procedure TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
FormPost(URL,FormData,Response); FormPost(URL,FormData,Response);
Finally Finally
Free; Free;
@ -1853,7 +2007,7 @@ class procedure TFPCustomHTTPClient.SimpleFormPost(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
FormPost(URL,FormData,Response); FormPost(URL,FormData,Response);
Finally Finally
Free; Free;
@ -1866,7 +2020,7 @@ class function TFPCustomHTTPClient.SimpleFormPost(const URL, FormData: string
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Result:=FormPost(URL,FormData); Result:=FormPost(URL,FormData);
Finally Finally
Free; Free;
@ -1879,7 +2033,7 @@ class function TFPCustomHTTPClient.SimpleFormPost(const URL: string;
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
Result:=FormPost(URL,FormData); Result:=FormPost(URL,FormData);
Finally Finally
Free; Free;
@ -1958,7 +2112,7 @@ class procedure TFPCustomHTTPClient.SimpleFileFormPost(const AURL, AFieldName,
begin begin
With Self.Create(nil) do With Self.Create(nil) do
try try
RequestHeaders.Add('Connection: Close'); KeepConnection := False;
FileFormPost(AURL,AFieldName,AFileName,Response); FileFormPost(AURL,AFieldName,AFileName,Response);
Finally Finally
Free; Free;

716
components/onlinepackagemanager/fpcmod/opkman_zip.pas
View File

File diff suppressed because it is too large Load Diff

13
components/onlinepackagemanager/opkman_downloader.pas
View File

@ -26,11 +26,14 @@ unit opkman_downloader;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{$INCLUDE opkman_fpcdef.inc}
interface interface
uses uses
Classes, SysUtils, fpjson, opkman_httpclient, opkman_timer, opkman_common, Classes, SysUtils, fpjson, opkman_timer, opkman_common, opkman_serializablepackages,
opkman_serializablepackages; {$IFDEF FPC311}fphttpclient{$ELSE}opkman_httpclient{$ENDIF};
type type
TDownloadType = (dtJSON, dtPackage, dtUpdate); TDownloadType = (dtJSON, dtPackage, dtUpdate);
@ -270,7 +273,7 @@ procedure TThreadDownload.DoOnTimer(Sender: TObject);
begin begin
if FDownloadType = dtJSON then if FDownloadType = dtJSON then
begin begin
FHTTPClient.NeedToBreak := True; FHTTPClient.Terminate;
FErrMsg := rsMainFrm_rsMessageError2; FErrMsg := rsMainFrm_rsMessageError2;
FErrTyp := etTimeOut; FErrTyp := etTimeOut;
FTimer.StopTimer; FTimer.StopTimer;
@ -679,7 +682,7 @@ procedure TPackageDownloader.CancelDownloadPackages;
begin begin
if Assigned(FDownload) then if Assigned(FDownload) then
begin begin
FDownload.FHTTPClient.NeedToBreak := True; FDownload.FHTTPClient.Terminate;
FDownload.FTimer.StopTimer; FDownload.FTimer.StopTimer;
FDownload.NeedToBreak := True; FDownload.NeedToBreak := True;
end; end;
@ -700,7 +703,7 @@ procedure TPackageDownloader.CancelUpdatePackages;
begin begin
if Assigned(FDownload) then if Assigned(FDownload) then
begin begin
FDownload.FHTTPClient.NeedToBreak := True; FDownload.FHTTPClient.Terminate;
FDownload.FTimer.StopTimer; FDownload.FTimer.StopTimer;
FDownload.NeedToBreak := True; FDownload.NeedToBreak := True;
end; end;

7
components/onlinepackagemanager/opkman_fpcdef.inc Normal file
View File

@ -0,0 +1,7 @@
{$IF FPC_VERSION = 3}
{$IF FPC_RELEASE > 0}
{$IF FPC_PATCH > 0}
{$DEFINE FPC311}
{$ENDIF}
{$ENDIF}
{$ENDIF}

12
components/onlinepackagemanager/opkman_updates.pas
View File

@ -25,11 +25,14 @@ unit opkman_updates;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{$INCLUDE opkman_fpcdef.inc}
interface interface
uses uses
Classes, SysUtils, LazIDEIntf, Laz2_XMLCfg, LazFileUtils, fpjson, fpjsonrtti, Classes, SysUtils, LazIDEIntf, Laz2_XMLCfg, LazFileUtils, fpjson, fpjsonrtti,
opkman_httpclient, opkman_timer, opkman_serializablepackages, dateutils; opkman_timer, opkman_serializablepackages, dateutils,
{$IFDEF FPC311}fphttpclient{$ELSE}opkman_httpclient{$ENDIF};
const const
OpkVersion = 1; OpkVersion = 1;
@ -128,7 +131,8 @@ var
implementation implementation
uses opkman_options, opkman_common, opkman_const, opkman_zip; uses opkman_options, opkman_common, opkman_const,
{$IFDEF FPC311}zipper{$ELSE}opkman_zip{$ENDIF};
{ TUpdatePackage } { TUpdatePackage }
@ -527,7 +531,7 @@ begin
ResetPackageData(SerializablePackages.Items[I]); ResetPackageData(SerializablePackages.Items[I]);
end end
else else
FHTTPClient.NeedToBreak := True; FHTTPClient.Terminate;
end; end;
if Assigned(FOnUpdate) and (not FNeedToBreak) and (not FPaused) then if Assigned(FOnUpdate) and (not FNeedToBreak) and (not FPaused) then
Synchronize(@DoOnUpdate); Synchronize(@DoOnUpdate);
@ -561,7 +565,7 @@ begin
Save; Save;
FTimer.StopTimer; FTimer.StopTimer;
FStarted := False; FStarted := False;
FHTTPClient.NeedToBreak := True; FHTTPClient.Terminate;
end; end;
procedure TUpdates.PauseUpdate; procedure TUpdates.PauseUpdate;

9
components/onlinepackagemanager/opkman_uploader.pas
View File

@ -26,12 +26,15 @@ unit opkman_uploader;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{$INCLUDE opkman_fpcdef.inc}
interface interface
uses uses
Classes, SysUtils, fpjson, base64, LazFileUtils, opkman_httpclient, Classes, SysUtils, fpjson, base64, LazFileUtils,
{$IFDEF FPC311}fphttpclient{$ELSE}opkman_httpclient{$ENDIF};
dialogs;
type type
TOnUploadProgress = procedure(Sender: TObject; AFileName: String) of object; TOnUploadProgress = procedure(Sender: TObject; AFileName: String) of object;
@ -210,7 +213,7 @@ end;
procedure TUploader.StopUpload; procedure TUploader.StopUpload;
begin begin
if Assigned(FHTTPClient) then if Assigned(FHTTPClient) then
FHTTPClient.NeedToBreak := True; FHTTPClient.Terminate;
FNeedToBreak := True; FNeedToBreak := True;
end; end;

48
components/onlinepackagemanager/opkman_zipper.pas
View File

@ -26,10 +26,13 @@ unit opkman_zipper;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{$INCLUDE opkman_fpcdef.inc}
interface interface
uses uses
Classes, SysUtils, FileUtil, LazFileUtils, strutils, opkman_timer, opkman_zip; Classes, SysUtils, FileUtil, LazFileUtils, strutils, opkman_timer,
{$IFDEF FPC311}zipper{$ELSE}opkman_zip{$ENDIF};
type type
TOnProgressEx = procedure(Sender : TObject; const ATotPos, ATotSize: Int64); TOnProgressEx = procedure(Sender : TObject; const ATotPos, ATotSize: Int64);
@ -69,6 +72,7 @@ type
procedure DoOnZipProgress; procedure DoOnZipProgress;
procedure DoOnZipError; procedure DoOnZipError;
procedure DoOnZipCompleted; procedure DoOnZipCompleted;
function GetZipSize(var AIsDirZipped: Boolean; var ABaseDir: String): Int64;
protected protected
procedure Execute; override; procedure Execute; override;
public public
@ -226,6 +230,42 @@ begin
Sleep(5); Sleep(5);
end; end;
function TPackageUnzipper.GetZipSize(var AIsDirZipped: Boolean; var ABaseDir: String): Int64;
var
I: Integer;
Item: TFullZipFileEntry;
AllFiles: Boolean;
P: Integer;
begin
FUnZipper.Examine;
AllFiles := (FUnZipper.Files.Count = 0);
Result := 0;
if FUnZipper.Entries.Count > 0 then
begin
P := Pos('/', TZipFileEntry(FUnZipper.Entries.Items[0]).ArchiveFileName);
if P = 0 then
P := Pos('\', TZipFileEntry(FUnZipper.Entries.Items[0]).ArchiveFileName);
if P <> 0 then
ABaseDir := Copy(TZipFileEntry(FUnZipper.Entries.Items[0]).ArchiveFileName, 1, P);
end;
for I := 0 to FUnZipper.Entries.Count-1 do
begin
Item := FUnZipper.Entries[i];
if AllFiles or (FUnZipper.Files.IndexOf(Item.ArchiveFileName)<>-1) then
begin
Result := Result + TZipFileEntry(Item).Size;
if AIsDirZipped then
if Pos(ABaseDir, Item.ArchiveFileName) = 0 then
AIsDirZipped := False;
end;
end;
if not AIsDirZipped then
ABaseDir := ''
else
ABaseDir := Copy(ABaseDir, 1, Length(ABaseDir) - 1);
end;
procedure TPackageUnzipper.StartUnZip(const ASrcDir, ADstDir: String; procedure TPackageUnzipper.StartUnZip(const ASrcDir, ADstDir: String;
const AIsUpdate: Boolean); const AIsUpdate: Boolean);
var var
@ -250,7 +290,7 @@ begin
FUnZipper.Examine; FUnZipper.Examine;
IsDirZipped := True; IsDirZipped := True;
BaseDir := ''; BaseDir := '';
FTotSize := FTotSize + FUnZipper.GetZipSize(IsDirZipped, BaseDir); FTotSize := FTotSize + GetZipSize(IsDirZipped, BaseDir);
SerializablePackages.Items[I].IsDirZipped := IsDirZipped; SerializablePackages.Items[I].IsDirZipped := IsDirZipped;
if BaseDir <> '' then if BaseDir <> '' then
BaseDir := AppendPathDelim(BaseDir); BaseDir := AppendPathDelim(BaseDir);
@ -276,7 +316,7 @@ end;
procedure TPackageUnzipper.StopUnZip; procedure TPackageUnzipper.StopUnZip;
begin begin
if Assigned(FUnZipper) then if Assigned(FUnZipper) then
FUnZipper.NeedToBreak := True; FUnZipper.Terminate;
if Assigned(FTimer) then if Assigned(FTimer) then
FTimer.StopTimer; FTimer.StopTimer;
FNeedToBreak := True; FNeedToBreak := True;
@ -373,7 +413,7 @@ end;
procedure TPackageZipper.StopZip; procedure TPackageZipper.StopZip;
begin begin
if Assigned(FZipper) then if Assigned(FZipper) then
FZipper.NeedToBreak := True; FZipper.Terminate;
FNeedToBreak := True; FNeedToBreak := True;
FStarted := False; FStarted := False;
end; end;