Created
November 27, 2020 16:12
-
-
Save mmmcorpsvit/c01c04076ba92e621707f566339628c8 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{$IFDEF FPC} | |
{$mode delphi} | |
{$ENDIF} | |
unit KOLHTTPDownload; | |
{ | |
("`-''-/").___..--''"`-._ | |
`6_ 6 ) `-. ( ).`-.__.`) | |
(_Y_.)' ._ ) `._ `. ``-..-' | |
_..`--'_..-_/ /--'_.' ,' | |
(il).-'' (li).' ((!.-' | |
Download with HTTP-protocol | |
Copyright © 2007-2008 Denis Fateyev (Danger) | |
Website: <http://www.fateyev.com> | |
E-Mail: <denis@fateyev.com> | |
'ParseURL' and 'Posn' functions are copyright (C) 1997-2001 by Francois Piette | |
"Permission is granted to anyone to use this software for any purpose, including | |
commercial applications, and to alter it and redistribute it freely." } | |
{* TKOLHTTPDownload is the non-visual component that provides a downloading resources with HTTP-protocol. Now uses WinInet routines. | |
|<pre> | |
|Copyright (C) 2007-2008 Denis Fateyev (Danger) (<a href="mailto:denis@fateyev.com">denis@fateyev.com</a>). | |
|</pre> | |
|TKOLHTTPDownload coming under the form of a KOL library unit, it can be simply used | |
by creating object at runtime, setting the necessary properties: | |
!uses Windows, Messages, KOL, ..., KOLHTTPDownload; | |
! //... | |
!var DL : PHTTPDownload; | |
! //... | |
!DL := NewHTTPDownload; | |
!DL.OnDownload:= MyDownload_Proc; | |
!DL.GetResource( 'http://example.com/foo/bar.zip' ); | |
!DL. ... | |
!DL.Free; | |
|<p>Certainly you can use the 'MCK mirror' provided with component to manage control properties at design time. } | |
interface | |
// This conditional define allows some manupulations with HTTP-headers, | |
// you can disable it (if you really don't need it) by commenting the following line. | |
{$DEFINE USE_CUSTOMHEADERS} | |
//----------------------------------------------------- | |
uses | |
Windows, WinInet, KOL, err, UrlMon; | |
type | |
TArrOptions = array[0..11] of Integer; | |
//----------------------------------------------------- | |
const | |
// Internet_options_consts | |
// http://msdn.microsoft.com/en-us/library/windows/desktop/aa385328%28v=vs.85%29.aspx | |
INTERNET_OPTION_FROM_CACHE_TIMEOUT = 63; // omg... | |
// key, value in msec, set after InternetOpen | |
DefInternet_Options : TArrOptions = ( | |
INTERNET_OPTION_CONNECT_TIMEOUT , 5000, | |
INTERNET_OPTION_DATA_RECEIVE_TIMEOUT, 5000, | |
INTERNET_OPTION_DATA_SEND_TIMEOUT , 5000, | |
INTERNET_OPTION_FROM_CACHE_TIMEOUT , 5000, | |
INTERNET_OPTION_RECEIVE_TIMEOUT , 5000, | |
INTERNET_OPTION_SEND_TIMEOUT , 5000 | |
); | |
//INTERNET_FLAG_NO_COOKIES or // mmm_corp, manual Cookies work | |
iHttpOpenRequestFlagDefault=INTERNET_FLAG_NO_UI or | |
INTERNET_FLAG_PRAGMA_NOCACHE or | |
INTERNET_FLAG_IGNORE_CERT_CN_INVALID or | |
INTERNET_FLAG_IGNORE_CERT_DATE_INVALID; | |
iDefProxyPort = 3128; | |
iTimeOutValue = 200; // 0.2 sec | |
// iDataBufSize must be > 256 !!!!! | |
//iDataBufSize = 4096; // 4 KByte buffer | |
iDataBufSize = 4096*10; // 40 KByte buffer | |
// mmm_corp, Content-Disposition must be this or other IE user agent, cyrilic fix | |
strUserAgentDefault = 'Mozilla/5.0 (Windows; U; MSIE 7.0; Windows NT 6.0; en-US)'; | |
// strUserAgentDefault = 'Mozilla/5.0 (Windows NT 6.3; Trident/7.0; rv 11.0)'; | |
strConnectType = 'Connection: close'; | |
strProxyConnectType = 'Proxy-Connection: close'; | |
// mmm_corp, add some const | |
ole32 = 'ole32.dll'; | |
{$EXTERNALSYM FMFD_DEFAULT} | |
FMFD_DEFAULT = $00000000; | |
{$EXTERNALSYM FMFD_URLASFILENAME} | |
FMFD_URLASFILENAME = $00000001; | |
{$EXTERNALSYM FMFD_ENABLEMIMESNIFFING} | |
FMFD_ENABLEMIMESNIFFING = $00000002; | |
{$EXTERNALSYM FMFD_IGNOREMIMETEXTPLAIN} | |
FMFD_IGNOREMIMETEXTPLAIN = $00000004; | |
{FMFD_SERVERMIME (0x00000008) | |
Internet Explorer 8. Use the authoritative MIME type specified in pwzMimeProposed. Unless FMFD_IGNOREMIMETEXTPLAIN is specified, no data sniffing is performed. | |
FMFD_RESPECTTEXTPLAIN (0x00000010) | |
Internet Explorer 9. Do not perform detection if "text/plain" is specified in pwzMimeProposed. | |
FMFD_RETURNUPDATEDIMGMIMES (0x00000020) | |
Internet Explorer 9. Returns image/png and image/jpeg instead of image/x-png and image/pjpeg.} | |
strUnknownError = 'Unknown error'; | |
strMethodNameGET = 'GET'; | |
strMethodNameHEAD = 'HEAD'; | |
strMethodNameDELETE = 'DELETE'; | |
strMethodNamePOST = 'POST'; | |
strMethodNamePUT = 'PUT'; | |
strDefMethodName = strMethodNameGET; | |
// mmm_corp, for POST data | |
strContentTypePost = 'Content-Type: application/x-www-form-urlencoded'; | |
// mmm_corp, some declarations from synacode (synapse) | |
type | |
TSpecials = set of AnsiChar; | |
const | |
URISpecialChar: TSpecials = | |
[#$00..#$20, '_', '<', '>', '"', '%', '{', '}', '|', '\', '^', '~', '[', ']', | |
'`', '/', '?', '&', '+', ':', '@', '#', '=', #$7F..#$FF]; | |
URLSpecialChar: TSpecials = | |
[#$00..#$20, '_', '<', '>', '"', '%', '{', '}', '|', '\', '^', '~', '[', ']', | |
'`', #$7F..#$FF]; | |
FileSpecialChar: TSpecials = | |
['\', '/', ':', '*', '?', '"', '<', '>', '|']; | |
// mmm_corp, use for dwContext, http://msdn.microsoft.com/en-us/library/windows/desktop/aa383976%28v=vs.85%29.aspx | |
{ http://msdn.microsoft.com/en-us/library/windows/desktop/aa383976%28v=vs.85%29.aspx | |
typedef struct | |
HWND hWindow; // Window handle | |
int nStatusList; // List box control to hold callbacks | |
HINTERNET hResource; // HINTERNET handle created by InternetOpenUrl | |
char szMemo[512]; // String to store status memo | |
REQUEST_CONTEXT;} | |
type | |
PREQUEST_CONTEXT = ^TREQUEST_CONTEXT; | |
TREQUEST_CONTEXT = record | |
hWindow: HWND; // Window handle | |
nStatusList: integer; // List box control to hold callbacks | |
hResource: HINTERNET; // HINTERNET handle created by InternetOpenUrl | |
szMemo: array[1..512] of char; // String to store status memo | |
end; | |
//----------------------------------------------------- | |
{ THTTPHeader } | |
type | |
PHTTPHeader = ^THTTPHeader; | |
THTTPHeader = record | |
{* |<p>Most important values that can be extracted from http-servers response | |
|(see <a href="thttpdownload.htm#parseheaders">ParseHeaders</a> procedure | |
|below for more details).</p> } | |
HTTPVersion: KOLstring; | |
StatusCode: Integer; | |
ReasonPhrase: KOLstring; | |
ServerDate: KOLstring; | |
ServerStr: KOLstring; | |
LastModified: KOLstring; | |
Location: KOLstring; | |
SetCookie: KOLstring; | |
Expires: KOLstring; | |
AcceptRanges: KOLstring; | |
ContentLength: Integer; | |
// mmm_corp | |
Content_Disposition: KOLstring; | |
TransferEncoding: KOLstring; | |
ContentType: KOLstring; | |
end; | |
//----------------------------------------------------- | |
{ THTTPDownload } | |
PHTTPDownload = ^THTTPDownload; | |
PDownloadWorker = ^TDownloadWorker; | |
TKOLHTTPDownload = PHTTPDownload; | |
THTTPHdrRecvEvent = procedure( Sender: PHTTPDownload; HeaderList: PStrList ) of object; | |
{* |Event to be called when http-headers received from http-server. } | |
// mmm_corp, add download speed and remaining time | |
THTTPProgressEvent = procedure(Sender: PHTTPDownload; BytesRecv: Integer; BytesAll: Integer; | |
DownloadSpeed: integer; RemainingTime: Integer) of object; | |
{* |Event to be called when download progress is changed. } | |
THTTPErrorEvent = procedure( Sender: PHTTPDownload; Error: Word ) of object; | |
{* |Event to be called when error occured while download process. } | |
//THTTPDownloadEvent = procedure( Sender: PHTTPDownload; Data: PStream ) of object; | |
THTTPDownloadEvent = reference to procedure( Sender: PHTTPDownload; Data: PStream ); | |
{* |Event to be called when resource download completed. } | |
// mmm_corp, Internet status, http://msdn.microsoft.com/en-us/library/windows/desktop/aa385121%28v=vs.85%29.aspx | |
THTTPStatusEvent = procedure(Sender: PHTTPDownload; hInt: HINTERNET; dwContext: DWORD_PTR; | |
dwInternetStatus: DWORD; pvStatusInformation: Pointer; | |
dwStatusInformationLength: DWORD) of object; | |
THTTPDownload = object( TObj ) | |
{* |This object implements all functionality of component.<br> | |
|Use <i>NewHTTPDownload</i> constuction function for creation of object instance. Here is the prototype: | |
! function NewHTTPDownload: PHTTPDownload; } | |
private | |
fWorker: PDownloadWorker; | |
fHeaderList: PStrList; | |
{$IFDEF USE_CUSTOMHEADERS} | |
fCHeaderList: PStrList; | |
// fCHeaderListEmpty: boolean; // save fHeaderList pointer for re-use/free | |
{$ENDIF} | |
fFormFields:PStrList; | |
fDataStream: PStream; | |
fDataStreamEmpty: Boolean; // save fDataStream pointer for re-use/free | |
fResource: string; | |
fBusy: Boolean; | |
fPort: Word; | |
fHostName: string; | |
fPath: string; | |
fUserName: string; | |
fPassword: string; | |
fProxySrv: string; | |
fProxyPort: Word; | |
fPreConfigProxy: Boolean; | |
// mmm_corp, add prop | |
fMethodName: String; // get/head etc.... | |
fPOSTData: String; // for POST | |
fProgressInterval: Integer; // call OnProgress by interval in ms | |
fLastOnProgressUpdate: Integer; // ms from last call fOnProgressInterval | |
fRealResource: string; | |
strUserAgent: string; | |
fHttpOpenRequestFlag: Cardinal; | |
// mmm_corp, add share declare Error, for Except or OnError speed fixes..... | |
fOnError: THTTPErrorEvent; | |
fOnHeaderReceived: THTTPHdrRecvEvent; | |
fOnProgress: THTTPProgressEvent; | |
fOnDownload: THTTPDownloadEvent; | |
fInternet_Options : TArrOptions; | |
// mmm_corp | |
fOnHTTPStatus: THTTPStatusEvent; | |
procedure SetDataStream(ds: PStream); // set data stream | |
// procedure SetHeaderList(hs: PStrList); // set data stream | |
public | |
// mmm_corp, add prop | |
procedure fOnErrorCall(Sender: PHTTPDownload; ThreadSender: PThread; Error: Word); | |
property RequestMethodName: string read fMethodName write fMethodName; | |
property POSTData: string read fPOSTData write fPOSTData; | |
property DataFieldsList: PStrList read fFormFields; | |
property DataStream: PStream read fDataStream write SetDataStream; | |
property RealResource: string read fRealResource; | |
property ProgressInterval: Integer read fProgressInterval write fProgressInterval; | |
property OnHTTPStatus: THTTPStatusEvent read fOnHTTPStatus write fOnHTTPStatus; | |
property UserAgent: string read strUserAgent write strUserAgent; | |
property HttpOpenRequestFlag: Cardinal read fHttpOpenRequestFlag write fHttpOpenRequestFlag; | |
property Internet_Options : TArrOptions read fInternet_Options write fInternet_Options; | |
procedure FormFieldsClear; | |
procedure FormField(name, value: string); | |
function CheckConnection( AResourceName: string ): Boolean; | |
{* Simple check if a connection to host that provides specified resource can be established, | |
and requested resource can be retrieved. By example: | |
! CheckConnection( 'http://www.example.com/foo/bar.zip' ); | |
Note that this function may give the wrong results if destination host doesn't accept 'ping' requests. | |
|Return value: <i>True</i> if a connection is made successfully, or <i>False</i> otherwise. } | |
function GetResource( AResourceName: string ): Boolean; | |
{* |Initiate download process for the specified resource.<br> | |
|The parameter <i>AResourceName</i> must contains full path of the requested resource | |
in such syntax: | |
! protocol://[user[:password]@]server[:port]/path | |
|If parameter <i>port</i> not specified, then <i>standard http-port (80)</i> will be used in request. | |
Authorization parameters can be omitted too, if isn't needed. | |
In simple case can be used, by example: | |
! GetResource( 'http://www.example.com/foo/bar.zip' ); | |
|Return value: the function returns <i>False</i> if resource request has invalid syntax, | |
|otherwise <i>True</i> returned. } | |
procedure SetProxySettings( AProxyServer: string; iProxyPort: Integer = iDefProxyPort ); | |
{* |Proxy settings for the resource request.<br> | |
|<i>iProxyPort</i> parameter can be omitted then <i>standard proxy port (3128)</i> will be used. } | |
procedure SetAuthInfo( AUserName: string; APassword: string ); | |
{* Authorization parameters for the resource request. } | |
function ParseHeaders( var Header: PHTTPHeader ): Boolean; | |
{* Extract http-headers information and put into the specified HTTPHeader. By example: | |
!var | |
! DL: PHTTPDownload; | |
! Header: PHTTPHeader; | |
!// ... | |
!procedure TForm1.DLHeaderReceived( Sender: PHTTPDownload; HeaderList: PStrList ); | |
!begin | |
! New( Header ); | |
! DL.ParseHeaders( Header ); | |
! // ... do something with Header ... | |
! MsgOk( Header.ReasonPhrase ); | |
! // ... | |
! Dispose( Header ); | |
!end; | |
|Return value: <i>False</i> if http-headers doesn't exists (nothing to analyze). } | |
{$IFDEF USE_CUSTOMHEADERS} | |
// procedure AddCustomHeader( AHeader: string ); | |
{* |Add custom line to requests http-header. By example: | |
!var | |
! DL: PHTTPDownload; | |
!// ... | |
!procedure TForm1.Button1Click( Sender: PObj ); | |
!begin | |
! DL.AddCustomHeader( 'Cookie: PHPSESSID=abcdef' ); | |
! DL.GetResource( 'http://www.example.com/foo/bar.zip' ); | |
!end; | |
Once assigned these headers will be added automatically to each request sent to http-server | |
(while the current THTTPDownload object is in use). Custom headers are not assigned by default. | |
|To clear user defined http-headers list, call <i>ClearCustomHeaders</i> procedure. | |
|Note that <i>'Connection: close'</i> or <i>'Proxy-Connection: close'</i> (depends on connection type) | |
|will be included in the request headers anyway.<br> | |
|You must add <b>USE_CUSTOMHEADERS</b> conditional symbol into the project options list. } | |
procedure SetCustomHeaders( AHeaderList: PStrList ); | |
{* |Assign the custom http-headers list from another one. By example: | |
!var | |
! DL: PHTTPDownload; | |
! CList: PStrList; | |
!// ... | |
!procedure TForm1.Button1Click( Sender: PObj ); | |
!begin | |
! CList:= NewStrList; | |
! CList.Add( 'Cookie: PHPSESSID=abcdef' ); | |
! DL.SetCustomHeaders( CList ); | |
! DL.GetResource( 'http://www.example.com/foo/bar.zip' ); | |
! CList.Free; | |
!end; | |
|You must add <b>USE_CUSTOMHEADERS</b> conditional symbol into the project options list. } | |
// procedure ClearCustomHeaders; | |
{* |Clear user defined http-headers list (restore to defaults). | |
|You must add <b>USE_CUSTOMHEADERS</b> conditional symbol into the project options list. } | |
{$ENDIF} | |
procedure CancelDownload; | |
{* |Drop current download process immediately. } | |
property Resource: string read fResource; | |
{* |Currently requested resource. By default: <i>None.</i> } | |
property ProxyServer: string read fProxySrv write fProxySrv; | |
{* |IP-address or hostname of http-proxy server. By default: <i>None.</i> } | |
property ProxyPort: Word read fProxyPort write fProxyPort; | |
{* |TCP Port of http-proxy server. By default: <i>3128.</i> } | |
property UserName: string read fUserName write fUserName; | |
{* |HTTP Autorization parameters: username. By default: <i>None.</i> } | |
property Password: string read fPassword write fPassword; | |
{* |HTTP Autorization parameters: password. By default: <i>None.</i> } | |
property UsePreconfigProxy: Boolean read fPreConfigProxy write fPreConfigProxy; | |
{*|Parameter that allows to use connection settings stored in Internet Explorer. | |
Retrieves the proxy or direct configuration from the Windows registry. | |
|By default: <i>False.</i> } | |
property HeaderList: PStrList read fHeaderList; | |
{*|Retrieves all received http-headers in raw format (as is). | |
Most important parameters can be retrieved with ParseHeaders procedure. } | |
{$IFDEF USE_CUSTOMHEADERS} | |
property CustomHeaderList: PStrList read fCHeaderList; | |
{*|Retrieves custom http-header list assigned by user. | |
See SetCustomHeaders procedure for more details. } | |
{$ENDIF} | |
property ReceivedData: PStream read fDataStream; | |
{*|Retrieves downloaded resource if present. } | |
property Busy: Boolean read fBusy; | |
{*| If <i>True</i>, the object is busy and resource download is in progress at the moment. | |
If you wish, you can terminate download process at any moment with CancelDownload procedure. } | |
property OnError: THTTPErrorEvent read fOnError write fOnError; | |
{* |Event to be called when error occured while download process. } | |
property OnHeaderReceived: THTTPHdrRecvEvent read fOnHeaderReceived write fOnHeaderReceived; | |
{* |Event to be called when http-headers received from http-server. } | |
property OnProgress: THTTPProgressEvent read fOnProgress write fOnProgress; | |
{* |Event to be called when download progress is changed. | |
Note that there's no way to automatically determine the whole size of requested resource | |
|if <i>'Content-Length'</i> field is missing in the http-header (i.e. if <i>Transfer-Encoding</i> | |
|header field (rfc-2068 section 14.40) is present and indicates that the <i>"chunked"</i> transfer | |
|coding has been applied). Therefore, if <i>'Content-Length'</i> is present, <i>BytesAll</i> | |
|parameter indicates the requested resource size, otherwise it's equal to <i>'-1'</i>. } | |
property OnDownload: THTTPDownloadEvent read fOnDownload write fOnDownload; | |
{* |Event to be called when resource download completed. } | |
destructor Destroy; virtual; | |
end; | |
//----------------------------------------------------- | |
{ TDownloadWorker } | |
TDownloadWorker = object (TObj ) | |
private | |
// Contains parent object's pointer (or NIL if download terminated) | |
fOwner: PHTTPDownload; | |
fWThread: PThread; | |
fDLThread: PThread; | |
fCritSection: TRTLCriticalSection; | |
fDataBuf: PChar; | |
fPort: Word; | |
fHostName: string; | |
fPath: string; | |
fUserName: string; | |
fPassword: string; | |
fProxySrv: string; | |
fProxyPort: Word; | |
fPreConfigProxy: Boolean; | |
iContentLen: Integer; | |
iReadCount: Integer; | |
// mmm_corp, add prop | |
fRequestMethodName: String; | |
fPOSTData: string; | |
fRealURL: String; | |
iStartTickCounter: Integer; | |
fDownloadSpeed: integer; | |
fRemainingTime: Integer; | |
function On_DownloadExecute( Sender: PThread ): Integer; | |
function On_WatchExecute( Sender: PThread ): Integer; | |
procedure On_UpdateProgress; | |
public | |
procedure StartDownload; | |
function StopDownload: Integer; | |
destructor Destroy; virtual; | |
end; | |
// from ActiveX | |
{$EXTERNALSYM CoTaskMemFree} | |
procedure CoTaskMemFree(pv: Pointer); stdcall; | |
procedure CoTaskMemFree; external ole32 name 'CoTaskMemFree'; | |
//----------------------------------------------------- | |
function NewHTTPDownload: PHTTPDownload; | |
function NewDownloadWorker( AOwner: PHTTPDownload ): PDownloadWorker; | |
//----------------------------------------------------- | |
// mmm_corp, some aroud function | |
function EncodeURL(const Value: string): string; | |
function EncodeURI(const Value: String): String; | |
function EncodeURIAnsi(const Value: AnsiString): AnsiString; | |
function DecodeURL(const Value: AnsiString): AnsiString; | |
function GetWinInetError(ErrorCode:Cardinal): string; | |
function HttpGetText(const URL: string; Response: PStrList; method: String=strDefMethodName; PostData: string=''; Headers: PStrList=nil): Boolean; overload; | |
function HttpGetText(const http: PHTTPDownload; const URL: string; Response: PStrList; method: String=strDefMethodName; PostData: string=''): Boolean; overload; | |
function HttpGetStream(const URL: string; Response: PStream; method: String=strDefMethodName; PostData: string=''): Boolean; overload; | |
function HttpGetStream(const http: PHTTPDownload; const URL: string; Response: PStream; method: String=strDefMethodName; PostData: string=''): Boolean; overload; | |
function GetMimeTypeExtension(MimeType: string):string; | |
function GetMimeTypeFromData(strContentType: string; pstrData: PStream):string; | |
function GetURLFileName(http: TKOLHTTPDownload; sMimeType: string; DefFileName: string = ''):string; | |
procedure WaitUntilTrue(bTrueValue: boolean; iSleep: integer=10); inline; // inline; - must be! | |
procedure ParseURL(const url : String; var Proto, User, Pass, Host, Port, Path : String); | |
//----------------------------------------------------- | |
// mmm_corp, fake class | |
type | |
TEventHandlers = class // create a dummy class | |
public | |
private | |
procedure onDownload(Sender: PHTTPDownload; Data: PStream); | |
procedure onError(Sender: PHTTPDownload; Error: Word); | |
procedure OnHeaderReceived(Sender: PHTTPDownload; HeaderList: PStrList); | |
end; | |
var | |
EvHandler: TEventHandlers; | |
implementation | |
procedure WaitUntilTrue(bTrueValue: boolean; iSleep: integer=10); inline; // inline; - must be! | |
var | |
IsMainThread: Boolean; | |
begin | |
IsMainThread := MainThreadID = GetCurrentThreadId; | |
while bTrueValue do | |
begin | |
{$IFNDEF NO_APPLET} | |
if IsMainThread then | |
Applet.ProcessMessages; | |
{$ENDIF} | |
Sleep(iSleep); | |
end; | |
end; | |
// get file extension from mimetype | |
function GetMimeTypeExtension(MimeType: string):string; | |
var | |
r:HKEY; | |
val: string; | |
begin | |
val:=''; | |
Result := ''; | |
r := 0; | |
try | |
r := RegKeyOpenRead(HKEY_CLASSES_ROOT,'MIME\Database\Content Type\'+MimeType); | |
if r<>0 then | |
val := RegKeyGetStr(r,'Extension'); | |
except | |
val := ''; | |
end; | |
if r<>0 then | |
RegCloseKey(r); | |
Result := val; | |
end; | |
// get filename from url | |
function GetURLFileName(http: TKOLHTTPDownload; sMimeType: string; DefFileName: string = ''):string; | |
function RightFileName(const FileName: string): string; | |
var | |
I: integer; | |
begin | |
result:=''; | |
for I := 0 to Length(FileName) do | |
if CharIn(FileName[i], FileSpecialChar)=False then | |
Result:=Result+FileName[i]; | |
end; | |
const | |
strDefHTMLExt = 'html'; | |
strDefaultFileName = 'default.'+strDefHTMLExt; | |
strContentDisposeFilename = 'filename'; | |
var | |
Header: PHTTPHeader; | |
s,ext: string; | |
j: Integer; | |
strProto, fUserName, fPassword, fHostName, strPort, fPath: string; | |
begin | |
// dont use title tag in HTML how do browsers ! | |
Result:=''; | |
// set from 'Content-Disposition' header | |
New(Header); | |
if http.ParseHeaders(Header) then | |
begin | |
s:=header.Content_Disposition; | |
j:=Pos(strContentDisposeFilename, s); | |
if j>0 then | |
begin | |
s:=Copy(s, j+length(strContentDisposeFilename)+1, Length(s)-j); | |
j:=Pos(';', s); | |
if j>0 then | |
s:=Copy(s, 0, j-1); | |
Result:=s; | |
end; | |
end; | |
Dispose(Header); | |
// set from file name url | |
if Result='' then | |
begin | |
ParseURL(http.RealResource, strProto, fUserName, fPassword, fHostName, strPort, fPath ); | |
s:=fPath; | |
{$WARNINGS OFF} | |
s:=DecodeURL(s); | |
{$WARNINGS ON} | |
// '/images/brain.gif?fsdfsdf=1' | |
j:=Pos('?', s); | |
if j>0 then | |
s:=Copy(s, 0, j-1); | |
// '/images/brain.gif' | |
j:=DelimiterLast(s, '/'); | |
if j>0 then | |
Delete(s, 1, j); | |
// set 'html' if not present '.' | |
j:=Pos('.', s); | |
if j=0 then | |
begin | |
if DefFileName<>'' then | |
s := DefFileName; | |
ext:=GetMimeTypeExtension(sMimeType); | |
if ext <> '' then | |
s:=s+ext | |
else | |
s:=s+'.'+strDefHTMLExt; | |
//MsgOK(s); | |
end; | |
// change ext to HTML if text/htm | |
if sMimeType=UrlMon.CFSTR_MIME_HTML then | |
s:=ChangeFileExt(s, '.'+strDefHTMLExt); | |
Result:=s; | |
end; | |
// set default | |
if Result='.'+strDefHTMLExt then | |
Result:=strDefaultFileName; | |
Result:=Trim(RightFileName(Result)); | |
end; | |
// get MimeType from pstr | |
function GetMimeTypeFromData(strContentType: string; pstrData: PStream):string; | |
var | |
pMimeTypeOut, pwzMimeProposed: PWideChar; | |
dwMimeFlags: Cardinal; | |
begin | |
// http://msdn.microsoft.com/en-us/library/ms775147%28v=vs.85%29.aspx#Known_MimeTypes | |
// can to help | |
// GetClassFileOrMime | |
// http://msdn.microsoft.com/en-us/library/ms775108%28v=vs.85%29.aspx | |
Result:=strUnknownError; | |
// http://msdn.microsoft.com/en-us/library/ie/ms775107%28v=vs.85%29.aspx | |
dwMimeFlags:=FMFD_DEFAULT; | |
{pwzMimeProposed (strContentType) | |
A pointer to a string value that contains the proposed MIME type. | |
This value is authoritative if type cannot be determined from the data. | |
If the proposed type contains a semi-colon (;) it is removed. | |
This parameter can be set to NULL.} | |
if Pos(';', strContentType)>0 then | |
strContentType:=Copy(strContentType, 0, Pos(';', strContentType)-1); | |
// zero size string <> nil !, fix it, but why??? 0_o... | |
pwzMimeProposed:=PWideChar(strContentType); | |
if Trim(strContentType)='' | |
then pwzMimeProposed:=nil; | |
pstrData.Position:=0; | |
try | |
case UrlMon.FindMimeFromData( | |
nil, // bind context - can be nil | |
nil, // url - can be nil | |
pstrData, // buffer with data to sniff - can be nil (pwzUrl must be valid) | |
pstrData.Size, // size of buffer | |
pwzMimeProposed, // proposed mime if - can be nil | |
dwMimeFlags, // will be defined | |
pMimeTypeOut, // the suggested mime | |
0) of // must be 0 | |
S_OK: SetString(Result, pMimeTypeOut, length(pMimeTypeOut)); | |
E_FAIL: Result:='E_FAIL'; | |
E_INVALIDARG: Result:='E_INVALIDARG'; | |
E_OUTOFMEMORY: Result:='E_OUTOFMEMORY'; | |
end; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
CoTaskMemFree(pMimeTypeOut); // ActiveX | |
end; | |
end; | |
function DecodeTriplet(const Value: AnsiString; Delimiter: AnsiChar): AnsiString; | |
var | |
x, l, lv: Integer; | |
c: AnsiChar; | |
b: Byte; | |
bad: Boolean; | |
begin | |
lv := Length(Value); | |
SetLength(Result, lv); | |
x := 1; | |
l := 1; | |
while x <= lv do | |
begin | |
c := Value[x]; | |
Inc(x); | |
if c <> Delimiter then | |
begin | |
Result[l] := c; | |
Inc(l); | |
end | |
else | |
if x < lv then | |
begin | |
Case Value[x] Of | |
#13: | |
if (Value[x + 1] = #10) then | |
Inc(x, 2) | |
else | |
Inc(x); | |
#10: | |
if (Value[x + 1] = #13) then | |
Inc(x, 2) | |
else | |
Inc(x); | |
else | |
begin | |
bad := False; | |
Case Value[x] Of | |
'0'..'9': b := (Byte(Value[x]) - 48) Shl 4; | |
'a'..'f', 'A'..'F': b := ((Byte(Value[x]) And 7) + 9) shl 4; | |
else | |
begin | |
b := 0; | |
bad := True; | |
end; | |
end; | |
Case Value[x + 1] Of | |
'0'..'9': b := b Or (Byte(Value[x + 1]) - 48); | |
'a'..'f', 'A'..'F': b := b Or ((Byte(Value[x + 1]) And 7) + 9); | |
else | |
bad := True; | |
end; | |
if bad then | |
begin | |
Result[l] := c; | |
Inc(l); | |
end | |
else | |
begin | |
Inc(x, 2); | |
Result[l] := AnsiChar(b); | |
Inc(l); | |
end; | |
end; | |
end; | |
end | |
else | |
break; | |
end; | |
Dec(l); | |
SetLength(Result, l); | |
end; | |
function DecodeURL(const Value: AnsiString): AnsiString; | |
begin | |
Result := DecodeTriplet(Value, '%'); | |
end; | |
function chrTrimLeft(const S: KOLString; chr:KOLChar=' '): KOLString; | |
var | |
I, L: Integer; | |
begin | |
L := Length(S); | |
I := 1; | |
while (I <= L) and (S[I] <= chr) do Inc(I); | |
Result := Copy(S, I, Maxint); | |
end; | |
function chrTrimRight(const S: KOLString; chr:KOLChar=' '): KOLString; | |
var | |
I: Integer; | |
begin | |
I := Length(S); | |
while (I > 0) and (S[I] <= chr) do Dec(I); | |
Result := Copy(S, 1, I); | |
end; | |
function chrTrim( const S : KOLString; chr:KOLChar=' '): KOLString; | |
begin | |
Result := chrTrimLeft( chrTrimRight( S, chr ), chr ); | |
end; | |
// mmm_corp, aroud functions in almost synapse style | |
procedure TEventHandlers.onDownload(Sender: PHTTPDownload; Data: PStream); | |
begin | |
; // need assign method, because data only create when onDownload assigned | |
end; | |
procedure TEventHandlers.onError(Sender: PHTTPDownload; Error: Word); | |
begin | |
Sender.DataStream.Size:=0; // clear if get error | |
end; | |
procedure TEventHandlers.OnHeaderReceived(Sender: PHTTPDownload; HeaderList: PStrList); | |
begin | |
// | |
end; | |
function HttpGetText(const URL: string; Response: PStrList; method: String=strDefMethodName; PostData: string=''; Headers: PStrList=nil): Boolean; | |
const | |
DwnldInternet_Options : TArrOptions = ( | |
INTERNET_OPTION_CONNECT_TIMEOUT , 20000, | |
INTERNET_OPTION_DATA_RECEIVE_TIMEOUT, 20000, | |
INTERNET_OPTION_DATA_SEND_TIMEOUT , 20000, | |
INTERNET_OPTION_FROM_CACHE_TIMEOUT , 20000, | |
INTERNET_OPTION_RECEIVE_TIMEOUT , 20000, | |
INTERNET_OPTION_SEND_TIMEOUT , 20000 | |
); | |
var | |
http: TKOLHTTPDownload; | |
ms: PStream; | |
begin | |
Result := False; | |
if Assigned(Response) then | |
Response.Clear; | |
ms:=NewMemoryStream; | |
http:=NewHTTPDownload; | |
try | |
http.Internet_Options := DwnldInternet_Options; | |
http.RequestMethodName:=method; | |
http.POSTData:=PostData; | |
http.DataStream:=ms; | |
http.OnDownload:=EvHandler.onDownload; // must be! | |
// http.UsePreconfigProxy:=true; // proxy settings as in IE | |
http.OnError:=EvHandler.onError; | |
http.OnHeaderReceived := EvHandler.OnHeaderReceived; | |
if Assigned(Headers) then | |
begin | |
http.SetCustomHeaders(Headers); | |
end; | |
http.GetResource(URL); | |
WaitUntilTrue(http.Busy); | |
ms.Position:=0; | |
if Assigned(Response) then | |
Response.LoadFromStream(ms, false); // hm... can be compatible with PStrList ? | |
if Assigned(Headers) then | |
begin | |
if Assigned(http.HeaderList) then | |
begin | |
Headers.NameDelimiter := http.HeaderList.NameDelimiter; | |
Headers.Text := http.HeaderList.Text; | |
end; | |
end; | |
Result:=ms.Size>0; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
ms.Free; | |
http.Free; | |
end; | |
end; | |
function HttpGetText(const http: PHTTPDownload; const URL: string; Response: PStrList; method: String=strDefMethodName; PostData: string=''): Boolean; | |
const | |
DwnldInternet_Options : TArrOptions = ( | |
INTERNET_OPTION_CONNECT_TIMEOUT , 60000, | |
INTERNET_OPTION_DATA_RECEIVE_TIMEOUT, 60000, | |
INTERNET_OPTION_DATA_SEND_TIMEOUT , 60000, | |
INTERNET_OPTION_FROM_CACHE_TIMEOUT , 60000, | |
INTERNET_OPTION_RECEIVE_TIMEOUT , 60000, | |
INTERNET_OPTION_SEND_TIMEOUT , 60000 | |
); | |
var | |
ms: PStream; | |
begin | |
Result := False; | |
Response.Clear; | |
ms:=NewMemoryStream; | |
//http:=NewHTTPDownload; | |
try | |
{http.RequestMethodName:=method; | |
http.POSTData:=PostData; | |
http.DataStream:=ms; | |
http.OnDownload:=EvHandler.onDownload; // must be! | |
http.UsePreconfigProxy:=true; // proxy settings as in IE | |
http.GetResource(URL); | |
//http.SetCustomHeaders(); | |
WaitUntilTrue(http.Busy); | |
ms.Position:=0; | |
Response.LoadFromStream(ms, false); // hm... can be compatible with PStrList ? | |
Result:=True;} | |
http.Internet_Options := DwnldInternet_Options; | |
http.RequestMethodName:=method; | |
http.POSTData:=PostData; | |
http.DataStream:=ms; | |
// http.OnDownload:=EvHandler.onDownload; // must be! | |
// http.UsePreconfigProxy:=true; // proxy settings as in IE | |
http.OnError:=EvHandler.onError; | |
http.GetResource(URL); | |
WaitUntilTrue(http.Busy); | |
ms.Position:=0; | |
Response.LoadFromStream(ms, false); // hm... can be compatible with PStrList ? | |
Result:=ms.Size>0; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
ms.Free; | |
//http.Free; | |
end; | |
//http.Free; | |
end; | |
function HttpGetStream(const URL: string; Response: PStream; method: String=strDefMethodName; PostData: string=''): Boolean; | |
var | |
http: TKOLHTTPDownload; | |
begin | |
Result := False; | |
http:=NewHTTPDownload; | |
try | |
http.RequestMethodName:=method; | |
http.POSTData:=PostData; | |
http.DataStream:=Response; | |
http.OnDownload:=EvHandler.onDownload; // must be! | |
// http.UsePreconfigProxy:=true; // proxy settings as in IE | |
http.OnError:=EvHandler.onError; | |
http.GetResource(URL); | |
WaitUntilTrue(http.Busy); | |
Response.Position:=0; | |
Result:=Response.Size>0; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
//ms.Free; | |
http.Free; | |
end; | |
end; | |
function HttpGetStream(const http: PHTTPDownload; const URL: string; Response: PStream; method: String=strDefMethodName; PostData: string=''): Boolean; | |
begin | |
Result := False; | |
try | |
http.RequestMethodName:=method; | |
http.POSTData:=PostData; | |
http.DataStream:=Response; | |
// http.OnDownload:=EvHandler.onDownload; // must be! | |
// http.UsePreconfigProxy:=true; // proxy settings as in IE | |
http.OnError:=EvHandler.onError; | |
http.GetResource(URL); | |
WaitUntilTrue(http.Busy); | |
Response.Position:=0; | |
Result:=Response.Size>0; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
end; | |
end; | |
// mmm_corp, add declaration, th Ìèõàèë) | |
function GetWinInetError(ErrorCode:Cardinal): string; | |
const | |
winetdll = 'wininet.dll'; | |
var | |
Len: Integer; | |
Buffer: PChar; | |
begin | |
Len := FormatMessage( | |
FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_FROM_SYSTEM or | |
FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY, | |
Pointer(GetModuleHandle(winetdll)), ErrorCode, 0, @Buffer, SizeOf(Buffer), nil); | |
try | |
while (Len > 0) and {$IFDEF UNICODE}(CharIn(Buffer[Len - 1], [#0..#32, '.'])) {$ELSE}(Buffer[Len - 1] in [#0..#32, '.']) {$ENDIF} do Dec(Len); | |
SetString(Result, Buffer, Len); | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LocalFree(HLOCAL(Buffer)); | |
end; | |
end; | |
// mmm_corp, imported from synacode (Synapse) | |
function EncodeTriplet(const Value: string; Delimiter: Char; Specials: TSpecials): string; | |
var | |
n: Integer; | |
s: string; | |
begin | |
for n := 1 to Length(Value) do | |
begin | |
s := Value[n]; | |
if CharIn(s[1], Specials) then | |
s := Delimiter + Int2Hex(Ord(s[1]), 2); | |
Result := Result + s; | |
end; | |
end; | |
function EncodeTripletAnsi(const Value: Ansistring; Delimiter: AnsiChar; Specials: TSpecials): AnsiString; | |
var | |
n: Integer; | |
s: AnsiString; | |
begin | |
for n := 1 to Length(Value) do | |
begin | |
s := Value[n]; | |
if s[1] in Specials then | |
s := Delimiter + AnsiString(Int2Hex(Ord(s[1]), 2)); | |
Result := Result + s; | |
end; | |
end; | |
function EncodeURIAnsi(const Value: AnsiString): AnsiString; | |
begin | |
Result := EncodeTripletAnsi(Value, '%', URISpecialChar); | |
end; | |
function EncodeURI(const Value: String): String; | |
begin | |
Result := EncodeTriplet(Value, '%', URISpecialChar); | |
end; | |
function EncodeURL(const Value: string): string; | |
begin | |
Result := EncodeTriplet(Value, '%', URLSpecialChar); | |
end; | |
//----------------------------------------------------- | |
function NewHTTPDownload: PHTTPDownload; | |
begin | |
New( Result, Create ); | |
Result^.fBusy:=false; | |
Result^.fPreConfigProxy:= false; | |
Result^.fProxyPort:= iDefProxyPort; | |
// mmm_corp, add def prop | |
Result^.fMethodName:= strDefMethodName; | |
Result^.ProgressInterval:=0; | |
Result^.UsePreconfigProxy:=True; | |
Result^.fDataStreamEmpty:=True; | |
Result^.UserAgent:=strUserAgentDefault; | |
Result^.HttpOpenRequestFlag:=iHttpOpenRequestFlagDefault; | |
Result^.fInternet_Options := DefInternet_Options; | |
end; | |
//----------------------------------------------------- | |
function NewDownloadWorker( AOwner: PHTTPDownload ): PDownloadWorker; | |
begin | |
New( Result, Create ); | |
Result^.fOwner:= AOwner; | |
InitializeCriticalSection( Result^.fCritSection ); | |
end; | |
//----------------------------------------------------- | |
function StrPas(const Str: PChar): string; | |
begin | |
Result:= Str; | |
end; | |
//----------------------------------------------------- | |
{ Find the count'th occurence of the s string in the t string. } | |
{ If count < 0 then look from the back } | |
function Posn(const s , t : String; Count : Integer) : Integer; | |
var | |
i, h, Last : Integer; | |
u : String; | |
begin | |
u := t; | |
if Count > 0 then | |
begin | |
Result := Length(t); | |
for i := 1 to Count do | |
begin | |
h := Pos(s, u); | |
if h > 0 then | |
u := Copy(u, h + 1, Length(u)) | |
else | |
begin | |
u := ''; | |
Inc(Result); | |
end; | |
end; | |
Result := Result - Length(u); | |
end | |
else if Count < 0 then | |
begin | |
Last := 0; | |
for i := Length(t) downto 1 do | |
begin | |
u := Copy(t, i, Length(t)); | |
h := Pos(s, u); | |
if (h <> 0) and ((h + i) <> Last) then | |
begin | |
Last := h + i - 1; | |
Inc(count); | |
if Count = 0 then | |
break; | |
end; | |
end; | |
if Count = 0 then | |
Result := Last | |
else | |
Result := 0; | |
end | |
else | |
Result := 0; | |
end; | |
//----------------------------------------------------- | |
{ Syntax of an URL: protocol://[user[:password]@]server[:port]/path } | |
procedure ParseURL(const url : String; var Proto, User, Pass, Host, Port, Path : String); | |
var | |
p, q : Integer; | |
s : String; | |
CurPath : String; | |
begin | |
CurPath := Path; | |
proto := ''; | |
User := ''; | |
Pass := ''; | |
Host := ''; | |
Port := ''; | |
Path := ''; | |
if Length(url) < 1 then Exit; | |
{ Handle path beginning with "./" or "../". } | |
{ This code handle only simple cases ! } | |
{ Handle path relative to current document directory } | |
if (Copy(url, 1, 2) = './') then | |
begin | |
p := Posn('/', CurPath, -1); | |
if p > Length(CurPath) then | |
p := 0; | |
if p = 0 then | |
CurPath := '/' | |
else | |
CurPath := Copy(CurPath, 1, p); | |
Path := CurPath + Copy(url, 3, Length(url)); | |
Exit; | |
end | |
{ Handle path relative to current document parent directory } | |
else if (Copy(url, 1, 3) = '../') then | |
begin | |
p := Posn('/', CurPath, -1); | |
if p > Length(CurPath) then | |
p := 0; | |
if p = 0 then | |
CurPath := '/' | |
else | |
CurPath := Copy(CurPath, 1, p); | |
s := Copy(url, 4, Length(url)); | |
{ We could have several levels } | |
while TRUE do | |
begin | |
CurPath := Copy(CurPath, 1, p-1); | |
p := Posn('/', CurPath, -1); | |
if p > Length(CurPath) then | |
p := 0; | |
if p = 0 then | |
CurPath := '/' | |
else | |
CurPath := Copy(CurPath, 1, p); | |
if (Copy(s, 1, 3) <> '../') then | |
break; | |
s := Copy(s, 4, Length(s)); | |
end; | |
Path := CurPath + Copy(s, 1, Length(s)); | |
Exit; | |
end; | |
p := pos('://',url); | |
if p = 0 then | |
begin | |
if (url[1] = '/') then | |
begin | |
{ Relative path without protocol specified } | |
proto := 'http'; | |
p := 1; | |
if (Length(url) > 1) and (url[2] <> '/') then | |
begin | |
{ Relative path } | |
Path := Copy(url, 1, Length(url)); | |
Exit; | |
end; | |
end | |
{$WARNINGS OFF} | |
else if lowercase(Copy(url, 1, 5)) = 'http:' then | |
{$WARNINGS ON} | |
begin | |
proto := 'http'; | |
p := 6; | |
if (Length(url) > 6) and (url[7] <> '/') then | |
begin | |
{ Relative path } | |
Path := Copy(url, 6, Length(url)); | |
Exit; | |
end; | |
end | |
{$WARNINGS OFF} | |
else if lowercase(Copy(url, 1, 7)) = 'mailto:' then | |
{$WARNINGS ON} | |
begin | |
proto := 'mailto'; | |
p := pos(':', url); | |
end; | |
end | |
else | |
begin | |
proto := Copy(url, 1, p - 1); | |
inc(p, 2); | |
end; | |
s := Copy(url, p + 1, Length(url)); | |
p := pos('/', s); | |
q := pos('?', s); | |
if (q > 0) and ((q < p) or (p = 0)) then | |
p := q; | |
if p = 0 then | |
p := Length(s) + 1; | |
Path := Copy(s, p, Length(s)); | |
s := Copy(s, 1, p-1); | |
p := Posn(':', s, -1); | |
if p > Length(s) then | |
p := 0; | |
q := Posn('@', s, -1); | |
if q > Length(s) then | |
q := 0; | |
if (p = 0) and (q = 0) then | |
begin { no user, password or port } | |
Host := s; | |
Exit; | |
end | |
else if q < p then | |
begin { a port given } | |
Port := Copy(s, p + 1, Length(s)); | |
Host := Copy(s, q + 1, p - q - 1); | |
if q = 0 then | |
Exit; { no user, password } | |
s := Copy(s, 1, q - 1); | |
end | |
else | |
begin | |
Host := Copy(s, q + 1, Length(s)); | |
s := Copy(s, 1, q - 1); | |
end; | |
p := pos(':', s); | |
if p = 0 then | |
User := s | |
else | |
begin | |
User := Copy(s, 1, p - 1); | |
Pass := Copy(s, p + 1, Length(s)); | |
end; | |
end; | |
//---------------- { THTTPDownload } ------------------------------- | |
procedure THTTPDownload.SetDataStream(ds: PStream); // set data stream | |
begin | |
fDataStreamEmpty:=not Assigned(ds); | |
fDataStream:=ds; | |
end; | |
// mmm_corp, add share OnError fix function | |
procedure THTTPDownload.fOnErrorCall(Sender: PHTTPDownload; ThreadSender: PThread; Error: Word); | |
procedure CallError; //(Error: Word); | |
var | |
E: Exception; | |
begin | |
E:= Exception.Create(e_Custom, GetWinInetError(Error)); | |
E.ErrorCode := Error; | |
raise E; // im main thread | |
E.Free; | |
end; | |
procedure SyncCallError; | |
begin | |
CallError; //(Error); | |
end; | |
begin | |
if Assigned(fOnError) | |
then fOnError(Sender, Error) | |
else ; | |
// new try (((( | |
Exit; | |
if Assigned(ThreadSender) | |
then ThreadSender.SynchronizeEx(TThreadMethodEx(MakeMethod(nil, @SyncCallError)), Pointer(Error)) // from thread | |
else CallError; //(Error); // from main thread | |
end; | |
function THTTPDownload.ParseHeaders( var Header: PHTTPHeader ): Boolean; | |
var | |
i: Integer; S: KOLstring; | |
begin | |
Result:= false; | |
if ( not Assigned( fHeaderList ) ) then Exit; | |
// HTTP/1.1 200 OK | |
{$WARNINGS OFF} | |
Header.ReasonPhrase:= fHeaderList.Items[0]; | |
{$WARNINGS ON} | |
Header.HTTPVersion:= Parse( Header.ReasonPhrase, ' ' ); | |
Header.StatusCode:= Str2Int( Parse(Header.ReasonPhrase, ' ') ); | |
// avoid curious things if value isn't present in the list | |
Header.ContentLength:= -1; | |
// begin from second list item | |
for i:= 2 to fHeaderList.Count do | |
begin | |
{$WARNINGS OFF} | |
S:= fHeaderList.Items[i-1]; | |
{$WARNINGS ON} | |
// Date: Wed, 09 May 2007 14:31:23 GMT | |
if ( Pos('Date: ', S) > 0 ) then | |
begin | |
Parse(S, ' '); Header.ServerDate:= S; | |
Continue; | |
end; | |
// Server: Apache x.x.x (Unix) | |
if ( Pos('Server: ', S) > 0 ) then | |
begin | |
Parse(S, ' '); Header.ServerStr:= S; | |
Continue; | |
end; | |
// Last-Modified: Wed, 09 May 2007 14:31:23 GMT | |
if ( Pos('Last-Modified: ', S) > 0 ) then | |
begin | |
Parse(S, ' '); Header.LastModified:= S; | |
Continue; | |
end; | |
// Set-Cookie: PHPSESSID=xxxxxxxxx | |
if ( Pos('Set-Cookie: ', S) > 0 ) then | |
begin | |
Parse(S, ' '); Header.SetCookie:= S; | |
Continue; | |
end; | |
// Expires: Wed, 10 May 2007 14:31:23 GMT | |
if ( Pos('Expires: ', S) > 0 ) then | |
begin | |
Parse(S, ' '); Header.Expires:= S; | |
Continue; | |
end; | |
// Location: foobar.html | |
if ( Pos('Location: ', S) > 0 ) then | |
begin | |
Parse(S, ' '); Header.Location:= S; | |
Continue; | |
end; | |
// Content-Length: 12345 | |
if ( Pos('Content-Length: ', S) > 0 ) then | |
begin | |
Parse(S, ' '); Header.ContentLength:= Str2Int( S ); | |
Continue; | |
end; | |
// Transfer-Encoding: chunked | |
if ( Pos('Transfer-Encoding: ', S) > 0 ) then | |
begin | |
Parse(S, ' '); Header.TransferEncoding:= S; | |
Continue; | |
end; | |
// Content-Type: application/zip | |
if ( Pos('Content-Type: ', S) > 0 ) then | |
begin | |
Parse(S, ' '); Header.ContentType:= S; | |
Continue; | |
end; | |
// mmm_corp | |
// Content-Disposition: attachment; filename="fname.ext" | |
if ( Pos('Content-Disposition: ', S) > 0 ) then | |
begin | |
Parse(S, ' '); Header.Content_Disposition:= S; | |
Continue; | |
end; | |
if ( Pos('Accept-Ranges: ', S) > 0 ) then | |
begin | |
Parse(S, ' '); Header.AcceptRanges:= S; | |
Continue; | |
end; | |
end; | |
Result:= true; | |
end; | |
//----------------------------------------------------- | |
procedure THTTPDownload.SetProxySettings( AProxyServer: string; iProxyPort: Integer = iDefProxyPort ); | |
begin | |
fProxySrv:= AProxyServer; | |
fProxyPort:= iProxyPort; | |
end; | |
//----------------------------------------------------- | |
procedure THTTPDownload.SetAuthInfo( AUserName: string; APassword: string ); | |
begin | |
fUserName:= AUserName; | |
fPassword:= APassword; | |
end; | |
//----------------------------------------------------- | |
{$IFDEF USE_CUSTOMHEADERS} | |
{procedure THTTPDownload.AddCustomHeader( AHeader: string ); | |
begin | |
if Length(AHeader)=0 then Exit; | |
if not Assigned(fCHeaderList) then | |
fCHeaderList:=NewStrList; | |
$WARNINGS OFF | |
fCHeaderList.Add(AHeader); | |
$WARNINGS ON | |
end; } | |
//----------------------------------------------------- | |
{procedure THTTPDownload.ClearCustomHeaders; | |
begin | |
if Assigned( fCHeaderList ) then fCHeaderList.Clear; | |
end; } | |
//----------------------------------------------------- | |
procedure THTTPDownload.SetCustomHeaders( AHeaderList: PStrList ); | |
begin | |
// fCHeaderListEmpty:=not Assigned(AHeaderList); | |
if not Assigned(AHeaderList) then Exit; | |
if not Assigned(fCHeaderList) then | |
begin | |
fCHeaderList:=NewStrList; | |
// fCHeaderList.Add2AutoFree( @Self ); | |
end; // 'if ( not Assigned( fCHeaderList )' | |
fCHeaderList.Assign( AHeaderList ); | |
end; | |
{$ENDIF} | |
//----------------------------------------------------- | |
function THTTPDownload.CheckConnection( AResourceName: string ): Boolean; | |
begin | |
Result:= false; | |
// I'm wondering why FLAG_ICC_FORCE_CONNECTION declaration is missing in WinInet.pas | |
if ( InternetCheckConnection( PChar( AResourceName ), $00000001 {FLAG_ICC_FORCE_CONNECTION}, 0 ) ) then | |
Result:= true | |
else | |
fOnErrorCall(@Self, nil, GetLastError); | |
end; | |
//----------------------------------------------------- | |
function THTTPDownload.GetResource( AResourceName: string ): Boolean; | |
var | |
strPort, strProto: string; | |
begin | |
Result:= false; | |
fRealResource:=AResourceName; | |
CancelDownload; | |
if fBusy then Exit; | |
fResource:= AResourceName; | |
// checking request data | |
ParseURL( fResource, strProto, fUserName, fPassword, fHostName, strPort, fPath ); | |
// mmm_corp, fix 12005 error if call 'http://www.redbird.te.ua' with empty fPath | |
if fPath='' then fPath:='/'; | |
if ( strProto = '' ) then strProto:= 'http'; | |
if ( ( fHostName = '' ) or ( fPath = '' ) or ( (strProto <> 'http') and (strProto <> 'https') )) then | |
begin | |
fOnErrorCall(@Self, nil, ERROR_INTERNET_INVALID_URL); | |
Exit; | |
end; | |
if ( strPort = '' ) then fPort:= INTERNET_DEFAULT_HTTP_PORT | |
else fPort:= Str2Int( strPort ); | |
// mmm_corp, fix mem leaks, Add2AutoFree not work correct | |
if Assigned(fOnHeaderReceived) then | |
if not Assigned(fHeaderList) then | |
begin | |
fHeaderList:= NewStrList; | |
// fHeaderList.Add2AutoFree( @Self ); | |
end; | |
if Assigned(fDataStream) then | |
fDataStream.Size:= 0 | |
else | |
begin | |
if Assigned(fOnDownload) then | |
fDataStream:= NewMemoryStream; | |
end; | |
fBusy:= true; | |
fWorker:= NewDownloadWorker( @Self ); | |
fWorker.StartDownload; | |
Result:= true; | |
end; | |
//----------------------------------------------------- | |
procedure THTTPDownload.CancelDownload; | |
begin | |
if ( fBusy ) then | |
fWorker.StopDownload; | |
end; | |
//----------------------------------------------------- | |
procedure THTTPDownload.FormFieldsClear; | |
begin | |
if ( not Assigned( fFormFields ) ) then | |
begin | |
fFormFields:= NewStrList; | |
//fFormFields.Add2AutoFree( @Self ); | |
fFormFields.NameDelimiter:='='; | |
end; | |
fFormFields.Clear; | |
end; | |
//----------------------------------------------------- | |
procedure THTTPDownload.FormField(name, value: string); | |
begin | |
if ( not Assigned( fFormFields ) ) then | |
begin | |
fFormFields:= NewStrList; | |
// fFormFields.Add2AutoFree( @Self ); | |
end; | |
{$WARNINGS OFF} | |
fFormFields.Values[name]:=EncodeURI(AnsiToUtf8(value)); | |
{$WARNINGS ON} | |
end; | |
//----------------------------------------------------- | |
destructor THTTPDownload.Destroy; | |
begin | |
CancelDownload; | |
fResource:= ''; | |
fHostName:= ''; | |
fPath:= ''; | |
fProxySrv:= ''; | |
fUserName:= ''; | |
fPassword:= ''; | |
fRealResource:=''; | |
fMethodName:=''; | |
fPOSTData:=''; | |
strUserAgent:=''; | |
// mmm_corp, mem leak, free fDataStream if use OnDownload and not assign fDataStream | |
if Assigned(fCHeaderList) {and fCHeaderListEmpty=True} then | |
fCHeaderList.Free; | |
if Assigned(fFormFields) then | |
fFormFields.Free; | |
if Assigned(fDataStream) and fDataStreamEmpty=True then | |
fDataStream.Free; | |
if Assigned(fHeaderList) then | |
fHeaderList.Free; | |
inherited; | |
end; | |
//---------------- { TDownloadWorker } ------------------------------- | |
procedure TDownloadWorker.StartDownload; | |
begin | |
fWThread:= NewThread; | |
fWThread.OnExecute:= On_WatchExecute; | |
// mmm_corp, fix mem leak | |
fWThread.AutoFree:=True; | |
// fWThread.Add2AutoFree( @Self ); | |
fWThread.Resume; | |
end; | |
//----------------------------------------------------- | |
function TDownloadWorker.On_WatchExecute( Sender: PThread ): Integer; | |
begin | |
Result:= 0; // stub | |
// create download working thread | |
fDLThread:= NewThreadEx( On_DownloadExecute ); | |
// wait for download thread finished (any way) | |
fDLThread.WaitFor; | |
// destroy worker object | |
Free; | |
end; | |
//----------------------------------------------------- | |
function TDownloadWorker.StopDownload: Integer; | |
var | |
lpOwner: PHTTPDownload; | |
begin | |
Result:= 0; // stub | |
lpOwner:= nil; // avoid compiler warning | |
EnterCriticalSection( fCritSection ); | |
try | |
if Assigned( fOwner ) then | |
begin | |
lpOwner:= PHTTPDownload( fOwner ); | |
fOwner:= nil; | |
end; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LeaveCriticalSection( fCritSection ); | |
end; | |
// trying to terminate thread gracefully | |
if ( not fDLThread.Terminated ) then fDLThread.WaitForTime( iTimeOutValue ); | |
// terminate thread forcefully | |
if ( not fDLThread.Terminated ) then fDLThread.Terminate; | |
if Assigned( lpOwner ) then | |
begin | |
// don't keep partially downloaded file | |
if Assigned( lpOwner.fDataStream ) then | |
lpOwner.fDataStream.Size:= 0; | |
lpOwner.fBusy:= false; | |
end; | |
end; | |
//----------------------------------------------------- | |
procedure TDownloadWorker.On_UpdateProgress; | |
begin | |
if Assigned(fOwner) then | |
fOwner.fOnProgress(fOwner, iReadCount, iContentLen, fDownloadSpeed, fRemainingTime); | |
end; | |
//----------------------------------------------------- | |
// mmm_corp, realurl, containe real url if redirected, can catch any events | |
procedure InternetStatusCallback(hInt: HINTERNET; dwContext: DWORD_PTR; | |
dwInternetStatus: DWORD; pvStatusInformation: Pointer; | |
dwStatusInformationLength: DWORD); stdcall; | |
var | |
cpContext: PREQUEST_CONTEXT; | |
ht: THTTPDownload; | |
begin | |
cpContext:= PREQUEST_CONTEXT(dwContext); | |
// get HTTPDownload object | |
ht:=PHTTPDownload(cpContext.nStatusList)^; | |
case dwInternetStatus of | |
INTERNET_STATUS_REDIRECT: | |
if Assigned(pvStatusInformation) then | |
{$WARNINGS OFF} | |
ht.fWorker.fRealURL:=PAnsiChar(pvStatusInformation); // Real URL | |
{$WARNINGS ON} | |
end; | |
if Assigned(ht.OnHTTPStatus) then | |
ht.fOnHTTPStatus(@ht, hInt, dwContext, | |
dwInternetStatus, pvStatusInformation, | |
dwStatusInformationLength); | |
end; | |
function TDownloadWorker.On_DownloadExecute( Sender: PThread ): Integer; | |
var | |
hSession, hConnect, hRequest: HINTERNET; | |
iBufSize, lpdwIndex, iNumRead: Cardinal; | |
Buf: PChar; i, iErrorCode, timeout: Integer; | |
dwFlags: Cardinal; | |
dwContext: DWORD_PTR; | |
dwContextRecord : TREQUEST_CONTEXT; | |
d: real; | |
dwBuffer:array[1..20] of Char; | |
dwBufferLen {,dwIndex}:DWORD; | |
pfStatus: PFNInternetStatusCallback; | |
rawData:RawByteString; | |
s: string; | |
procedure CloseHandles; | |
begin | |
InternetCloseHandle( hRequest ); | |
InternetCloseHandle( hConnect ); | |
InternetCloseHandle( hSession ); | |
end; | |
begin | |
Result:= 0; // stub | |
EnterCriticalSection( fCritSection ); | |
try | |
if Assigned( fOwner ) then | |
begin | |
// mmm_corp, add private prop | |
fRequestMethodName :=fOwner.fMethodName; | |
fPOSTData :=fOwner.fPOSTData; | |
fHostName:= fOwner.fHostName; | |
fPath:= fOwner.fPath; | |
fPort:= fOwner.fPort; | |
fUserName:= fOwner.fUserName; | |
fPassword:= fOwner.fPassword; | |
fPreConfigProxy:= fOwner.fPreConfigProxy; | |
if ( not fPreConfigProxy ) then | |
begin | |
fProxySrv:= fOwner.fProxySrv; | |
fProxyPort:= fOwner.fProxyPort; | |
end; | |
end // 'if Assigned( fOwner ) then' | |
else Exit; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LeaveCriticalSection( fCritSection ); | |
end; | |
// initializing Wininet, settings some connection parameters | |
// mmm_corp, use flags, http://msdn.microsoft.com/en-us/library/windows/desktop/aa383928%28v=vs.85%29.aspx | |
dwFlags := 0; //WinInet.INTERNET_FLAG_NO_CACHE_WRITE; | |
if (fPreConfigProxy) then | |
hSession:= InternetOpen(PWideChar(fOwner.strUserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, dwFlags) | |
else | |
begin | |
if (fProxySrv <> '') then | |
hSession:= InternetOpen(PWideChar(fOwner.strUserAgent), INTERNET_OPEN_TYPE_PROXY, | |
PChar( 'http=' + fProxySrv + ':' + Int2Str( fProxyPort) ), nil, dwFlags) | |
else | |
hSession:= InternetOpen(PWideChar(fOwner.strUserAgent), INTERNET_OPEN_TYPE_DIRECT, nil, nil, dwFlags); | |
end; | |
if ( hSession = nil ) then | |
begin | |
fOwner^.fOnErrorCall(fOwner, Sender, GetLastError); | |
Exit; | |
end; | |
// mmm_corp, add custom settings from Internet_Options | |
for I:=0 to trunc(High(fOwner^.fInternet_Options)/2) do | |
begin | |
timeout:=fOwner^.fInternet_Options[i*2+1]; | |
if InternetSetOption(hSession, fOwner^.fInternet_Options[i*2], @timeout, sizeof(timeout))=False then | |
fOwner^.fOnErrorCall(fOwner, Sender, GetLastError); | |
end; | |
// mmm_corp, handle status events | |
with dwContextRecord do | |
begin | |
hWindow:=0; | |
nStatusList:=Integer(@fOwner^); // link to Owner | |
hResource:=hSession; | |
for I := Low(szMemo) to High(szMemo) do | |
szMemo[I] := #0; // clear array | |
end; | |
dwContext:=DWORD_PTR(addr(dwContextRecord)); | |
if Assigned(hSession) then | |
begin | |
pfStatus:=PFNInternetStatusCallback(@InternetStatusCallback); | |
pfStatus:=InternetSetStatusCallback(hSession, pfStatus); | |
if NativeInt(pfStatus) = INTERNET_INVALID_STATUS_CALLBACK then | |
fOwner^.fOnErrorCall(fOwner, Sender, NativeInt(pfStatus)); | |
end; | |
// checking if thread must be terminated | |
EnterCriticalSection( fCritSection ); | |
try | |
if ( not Assigned( fOwner ) ) then Exit; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LeaveCriticalSection( fCritSection ); | |
end; | |
// connecting to http-server | |
hConnect:= InternetConnect( hSession, PChar( fHostName ), fPort, | |
PChar( fUserName ), PChar( fPassword ), INTERNET_SERVICE_HTTP, 0, dwContext); | |
if ( hConnect = nil ) then | |
begin | |
fOwner^.fOnErrorCall(fOwner, Sender, GetLastError); | |
CloseHandles; | |
Exit; | |
end; | |
// checking if thread must be terminated | |
EnterCriticalSection( fCritSection ); | |
try | |
if ( not Assigned( fOwner ) ) then | |
begin | |
CloseHandles; | |
Exit; | |
end; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LeaveCriticalSection( fCritSection ); | |
end; | |
// prepare resource request to http-server | |
// we're prefer HTTP/1.0 version but this parameter can be ignored by Wininet | |
// see KB258425 (http://support.microsoft.com/kb/258425) for more details. | |
{Yes, InternetOpenUrl (and HttpSendRequest) will follow HTTP redirects. | |
(However, WinInet may not automatically follow HTTPS to HTTP, or HTTP to | |
HTTPS, redirects unless the application specifies the | |
INTERNET_FLAG_IGNORE_REDIRECT_TO_HTTP[S] flags.) | |
Automatic HTTP redirect following may be disabled by specifying the | |
INTERNET_FLAG_NO_AUTO_REDIRECT flag to InternetOpenUrl (or HttpOpenRequest) | |
to let the application manually handle a redirect response. By default, | |
InternetOpenUrl will follow up to 100 redirects. There is no way via the | |
WinInet API to override the 100 redirect maximum limit, but it can be | |
configured by setting a registry key, although this will affect all | |
WinInet-based applications, like Internet Explorer, for the current user. | |
The registry value is: | |
HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet | |
Settings : MaxHttpRedirects (REG_DWORD) | |
} | |
// mmm_corp, get/head | |
//hRequest:= HttpOpenRequest( hConnect, nil, PChar( fPath ), nil, | |
// http://msdn.microsoft.com/en-us/library/windows/desktop/aa383661%28v=vs.85%29.aspx | |
hRequest:= HttpOpenRequest(hConnect, | |
PChar(fRequestMethodName), | |
PChar(fPath), | |
nil, | |
nil, | |
nil, | |
fOwner^.fHttpOpenRequestFlag, | |
dwContext); | |
if (hRequest = nil) then | |
begin | |
fOwner^.fOnErrorCall(fOwner, Sender, GetLastError); | |
CloseHandles; | |
Exit; | |
end; | |
// adding custom http headers to request | |
{$IFDEF USE_CUSTOMHEADERS} | |
if Assigned(fOwner^.fCHeaderList) then | |
for i:=0 to fOwner^.fCHeaderList^.Count-1 do | |
begin | |
{$WARNINGS OFF} | |
s:=fOwner^.fCHeaderList^.Items[i]; | |
{$WARNINGS ON} | |
if not HttpAddRequestHeaders(hRequest, PWideChar(s), Length(s), HTTP_ADDREQ_FLAG_ADD) then | |
begin | |
fOwner^.fOnErrorCall(fOwner, Sender, GetLastError); | |
CloseHandles; | |
Exit; | |
end; | |
end; | |
{$ENDIF} | |
// setting http headers 'connection type' field (don't allow persistent connection) | |
if ( fPreConfigProxy or ( fProxySrv <> '' ) ) then | |
HttpAddRequestHeaders( hRequest, strProxyConnectType, Length( strProxyConnectType ), HTTP_ADDREQ_FLAG_ADD ) | |
else | |
HttpAddRequestHeaders( hRequest, strConnectType, Length( strConnectType ), HTTP_ADDREQ_FLAG_ADD ); | |
// mmm_corp, add header for POST | |
if fRequestMethodName=strMethodNamePOST then | |
HttpAddRequestHeaders(hRequest, strContentTypePost , Length(strContentTypePost), HTTP_ADDREQ_FLAG_ADD ); | |
// checking if thread must be terminated | |
EnterCriticalSection( fCritSection ); | |
try | |
if ( not Assigned( fOwner ) ) then | |
begin | |
CloseHandles; | |
Exit; | |
end; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LeaveCriticalSection( fCritSection ); | |
end; | |
// mmm_corp, add post data (POST, PUT) | |
if Assigned( fOwner.fFormFields ) and (fOwner.fFormFields.Count>0) and (fPOSTData = '') then | |
begin | |
fPOSTData:=string(fOwner.fFormFields.Join('&')); | |
{$WARNINGS OFF} | |
fPOSTData:=chrTrim(fPOSTData,'&'); | |
{$WARNINGS ON} | |
end; | |
if (fRequestMethodName<>strMethodNamePOST) | |
and (fRequestMethodName<>strMethodNamePUT) | |
then fPOSTData:=''; | |
// send http request to server | |
rawData:=Utf8Encode(fPOSTData); | |
if (not HttpSendRequest(hRequest, | |
nil, | |
0, | |
PRawByteString(rawData), | |
Length(rawData) | |
)) then | |
begin | |
fOwner^.fOnErrorCall(fOwner, Sender, GetLastError); | |
CloseHandles; | |
Exit; | |
end; | |
// mmm_corp, fill real resource url | |
if Assigned(fOwner) and (fRealURL<>'') then | |
fOwner.fRealResource:=fRealURL; | |
// checking if thread must be terminated | |
EnterCriticalSection( fCritSection ); | |
try | |
if ( not Assigned( fOwner ) ) then | |
begin | |
CloseHandles; | |
Exit; | |
end; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LeaveCriticalSection( fCritSection ); | |
end; | |
// receiving headers (if event assigned) | |
if Assigned( fOwner.fOnHeaderReceived ) then | |
begin | |
lpdwIndex:= 0; Buf:= nil; iBufSize:=0; | |
HttpQueryInfo( hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Buf, iBufSize, lpdwIndex ); | |
// NB: it's ok when 'unsufficient buffer' message received now | |
iErrorCode:= GetLastError; | |
if ( iErrorCode = ERROR_INSUFFICIENT_BUFFER ) then | |
begin | |
GetMem( Buf, iBufSize ); | |
lpdwIndex:= 0; | |
try | |
if ( HttpQueryInfo( hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Buf, iBufSize, lpdwIndex ) ) then | |
with ( fOwner^ ) do | |
begin | |
{$WARNINGS OFF} | |
fHeaderList.SetText( Buf, false ); | |
{$WARNINGS ON} | |
with ( fHeaderList^ ) do | |
if ( Items[Count-1] = '' ) then Delete( Count-1 ); | |
fOnHeaderReceived( fOwner, fHeaderList ); | |
end // 'if ( HttpQueryInfo( hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Buf, iBufSize, iReserved ) )' | |
else fOwner^.fOnErrorCall(fOwner, Sender, GetLastError); | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
FreeMem( Buf ); | |
end; | |
end // 'if ( iErrorCode = ERROR_INSUFFICIENT_BUFFER )' | |
else fOwner^.fOnErrorCall(fOwner, Sender, iErrorCode); | |
// checking if thread must be terminated | |
EnterCriticalSection( fCritSection ); | |
try | |
if ( not Assigned( fOwner ) ) then | |
begin | |
CloseHandles; | |
Exit; | |
end; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LeaveCriticalSection( fCritSection ); | |
end; | |
end; | |
// checking if thread must be terminated | |
EnterCriticalSection( fCritSection ); | |
try | |
if ( not Assigned( fOwner ) ) then | |
begin | |
CloseHandles; | |
Exit; | |
end; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LeaveCriticalSection( fCritSection ); | |
end; | |
// getting http status code | |
iBufSize:= 16; | |
iErrorCode:= 0; | |
lpdwIndex:= 0; | |
GetMem( Buf, iBufSize ); | |
try | |
if ( HttpQueryInfo( hRequest, HTTP_QUERY_STATUS_CODE, Buf, iBufSize, lpdwIndex ) ) then | |
iErrorCode:= Str2Int( StrPas( Buf ) ) | |
else fOwner^.fOnErrorCall(fOwner, Sender, GetLastError); | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
FreeMem( Buf ); | |
end; | |
// checking if thread must be terminated | |
EnterCriticalSection( fCritSection ); | |
try | |
if ( not Assigned( fOwner ) ) then | |
begin | |
CloseHandles; | |
Exit; | |
end; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LeaveCriticalSection( fCritSection ); | |
end; | |
// mmm_corp, prevent fOnDownload if HEAD method | |
if fOwner.fMethodName=strMethodNameHEAD then | |
begin | |
fOwner.fOnDownload:=nil; | |
fOwner.fDataStream:=nil; | |
end; | |
// mmm_corp, | |
// checking if resource is available | |
// if ( ( Assigned( fOwner.fOnDownload ) and ( iErrorCode = HTTP_STATUS_OK {HTTP/1.1 200 OK} ) ) ) then | |
if ( ( Assigned( fOwner.fDataStream ) and ( (iErrorCode = HTTP_STATUS_OK) or (iErrorCode = HTTP_STATUS_PARTIAL_CONTENT) {HTTP/1.1 200 OK} ) ) ) then | |
begin | |
iBufSize:= 16; | |
lpdwIndex:= 0; | |
iContentLen:= 0; | |
GetMem( Buf, iBufSize ); | |
try | |
dwBufferLen:=20; | |
if ( HttpQueryInfo( hRequest, HTTP_QUERY_CONTENT_LENGTH, @dwBuffer, dwBufferLen, lpdwIndex ) ) then | |
iContentLen:= Str2Int( StrPas( @dwBuffer ) ); | |
// set iContentLen value to '-1' if not present or invalid | |
if ( iContentLen <= 0 ) then iContentLen:= -1; | |
iReadCount:= 0; | |
GetMem( fDataBuf, iDataBufSize ); | |
iStartTickCounter:=GetTickCount; | |
try | |
// downloading resource | |
with ( fOwner^ ) do | |
while ( InternetReadFile( hRequest, fDataBuf, iDataBufSize, iNumRead ) ) do | |
if ( iNumRead > 0 ) then | |
begin | |
// checking if thread must be terminated | |
EnterCriticalSection( fCritSection ); | |
try | |
if ( not Assigned( fOwner ) ) then Break; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LeaveCriticalSection( fCritSection ); | |
end; | |
// write received data to stream | |
fDataStream.Write( fDataBuf^, iNumRead ); | |
Inc( iReadCount, iNumRead ); | |
// fDownloadSpeed and fRemainingTime | |
d:=((Integer(GetTickCount)-iStartTickCounter))/1000; | |
fDownloadSpeed:=Trunc(iReadCount/d); | |
fRemainingTime:=trunc((iContentLen-iReadCount)/fDownloadSpeed); | |
// mmm_corp, update download progress, (no each time call, inc UI response) | |
if Assigned(fOnProgress) then | |
begin | |
if fOwner.fProgressInterval=0 | |
then {$IFNDEF NO_APPLET}fDLThread.Synchronize(On_UpdateProgress){$ELSE}On_UpdateProgress{$ENDIF} | |
else | |
if (Integer(GetTickCount)-fOwner.fLastOnProgressUpdate) > fOwner.fProgressInterval then | |
begin | |
fOwner.fLastOnProgressUpdate:=GetTickCount; | |
{$IFNDEF NO_APPLET}fDLThread.Synchronize(On_UpdateProgress){$ELSE}On_UpdateProgress{$ENDIF} | |
end; | |
end; | |
end | |
else Break; | |
// checking if thread must be terminated | |
EnterCriticalSection( fCritSection ); | |
try | |
if ( not Assigned( fOwner ) ) then | |
begin | |
CloseHandles; | |
Exit; | |
end; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LeaveCriticalSection( fCritSection ); | |
end; | |
// download complete | |
with ( fOwner^ ) do | |
begin | |
fDataStream.Position:= 0; | |
// call assigned event handler | |
fOnDownload( @Self, fDataStream ); | |
end; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
FreeMem( fDataBuf ); | |
end; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
FreeMem( Buf ); | |
end; | |
end | |
else | |
if ( iErrorCode <> HTTP_STATUS_OK { HTTP/1.1 OK } ) then | |
fOwner^.fOnErrorCall(fOwner, Sender, ERROR_INTERNET_EXTENDED_ERROR); | |
CloseHandles; | |
end; | |
//----------------------------------------------------- | |
destructor TDownloadWorker.Destroy; | |
begin | |
fDLThread.Free; | |
fHostName:= ''; | |
fPath:= ''; | |
fUserName:= ''; | |
fPassword:= ''; | |
fProxySrv:= ''; | |
fRequestMethodName:=''; | |
fRealURL:=''; | |
fPOSTData:=''; | |
EnterCriticalSection( fCritSection ); | |
try | |
if Assigned( fOwner ) then | |
fOwner.fBusy:= false; | |
{finally} except on E: err.Exception do OnExcept(E); end; begin | |
LeaveCriticalSection( fCritSection ); | |
end; | |
DeleteCriticalSection( fCritSection ); | |
inherited; | |
end; | |
//----------------------------------------------------- | |
end. |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Delphi KOL/MCK Extensions
KOLHTTPDownload
Add properties:
Add functions:
EncodeURL(const Value: string): string;
EncodeURI(const Value: String): String;
EncodeURIAnsi(const Value: AnsiString): AnsiString;
DecodeURL(const Value: AnsiString): AnsiString;
GetWinInetError(ErrorCode:Cardinal): string;
HttpGetText(const URL: string; Response: PStrList; method: String=strDefMethodName; PostData: string=''; Headers: PStrList=nil): Boolean; overload;
HttpGetText(const http: PHTTPDownload; const URL: string; Response: PStrList; method: String=strDefMethodName; PostData: string=''): Boolean; overload;
HttpGetStream(const URL: string; Response: PStream; method: String=strDefMethodName; PostData: string=''): Boolean; overload;
HttpGetStream(const http: PHTTPDownload; const URL: string; Response: PStream; method: String=strDefMethodName; PostData: string=''): Boolean; overload;
GetMimeTypeExtension(MimeType: string):string;
GetMimeTypeFromData(strContentType: string; pstrData: PStream):string;
GetURLFileName(http: TKOLHTTPDownload; sMimeType: string; DefFileName: string = ''):string;
Add procedures: