summaryrefslogtreecommitdiff
path: root/orig/pq/HTTPGet.pas
diff options
context:
space:
mode:
Diffstat (limited to 'orig/pq/HTTPGet.pas')
-rw-r--r--orig/pq/HTTPGet.pas448
1 files changed, 448 insertions, 0 deletions
diff --git a/orig/pq/HTTPGet.pas b/orig/pq/HTTPGet.pas
new file mode 100644
index 0000000..dab952b
--- /dev/null
+++ b/orig/pq/HTTPGet.pas
@@ -0,0 +1,448 @@
+{*************************************************************}
+{ HTTPGet component for Delphi 32 }
+{ Version: 1.94 }
+{ E-Mail: info@utilmind.com }
+{ WWW: http://www.utilmind.com }
+{ Created: October 19, 1999 }
+{ Modified: June 6, 2000 }
+{ Legal: Copyright (c) 1999-2000, UtilMind Solutions }
+{*************************************************************}
+{ PROPERTIES: }
+{ Agent: String - User Agent }
+{ }
+{* BinaryData: Boolean - This setting specifies which type }
+{* of data will taken from the web. }
+{* If you set this property TRUE then }
+{* component will determinee the size }
+{* of files *before* getting them from }
+{* the web. }
+{* If this property is FALSE then as we}
+{* do not knows the file size the }
+{* OnProgress event will doesn't work. }
+{* Also please remember that is you set}
+{* this property as TRUE you will not }
+{* capable to get from the web ASCII }
+{* data and ofter got OnError event. }
+{ }
+{ FileName: String - Path to local file to store the data }
+{ taken from the web }
+{ Password, UserName - set this properties if you trying to }
+{ get data from password protected }
+{ directories. }
+{ Referer: String - Additional data about referer document }
+{ URL: String - The url to file or document }
+{ UseCache: Boolean - Get file from the Internet Explorer's }
+{ cache if requested file is cached. }
+{*************************************************************}
+{ METHODS: }
+{ GetFile - Get the file from the web specified in the URL }
+{ property and store it to the file specified in }
+{ the FileName property }
+{ GetString - Get the data from web and return it as usual }
+{ String. You can receive this string hooking }
+{ the OnDoneString event. }
+{ Abort - Stop the current session }
+{*************************************************************}
+{ EVENTS: }
+{ OnDoneFile - Occurs when the file is downloaded }
+{ OnDoneString - Occurs when the string is received }
+{ OnError - Occurs when error happend }
+{ OnProgress - Occurs at the receiving of the BINARY DATA }
+{*************************************************************}
+{ Please see demo program for more information. }
+{*************************************************************}
+{ IMPORTANT NOTE: }
+{ This software is provided 'as-is', without any express or }
+{ implied warranty. In no event will the author be held }
+{ liable for any damages arising from the use of this }
+{ software. }
+{ Permission is granted to anyone to use this software for }
+{ any purpose, including commercial applications, and to }
+{ alter it and redistribute it freely, subject to the }
+{ following restrictions: }
+{ 1. The origin of this software must not be misrepresented, }
+{ you must not claim that you wrote the original software. }
+{ If you use this software in a product, an acknowledgment }
+{ in the product documentation would be appreciated but is }
+{ not required. }
+{ 2. Altered source versions must be plainly marked as such, }
+{ and must not be misrepresented as being the original }
+{ software. }
+{ 3. This notice may not be removed or altered from any }
+{ source distribution. }
+{*************************************************************}
+
+unit HTTPGet;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, WinInet;
+
+type
+ TOnProgressEvent = procedure(Sender: TObject; TotalSize, Readed: Integer) of object;
+ TOnDoneFileEvent = procedure(Sender: TObject; FileName: String; FileSize: Integer) of object;
+ TOnDoneStringEvent = procedure(Sender: TObject; Result: String) of object;
+
+ THTTPGetThread = class(TThread)
+ private
+ FTAcceptTypes,
+ FTAgent,
+ FTURL,
+ FTFileName,
+ FTStringResult,
+ FTUserName,
+ FTPassword,
+ FTPostQuery,
+ FTReferer: String;
+ FTBinaryData,
+ FTUseCache: Boolean;
+
+ FTResult: Boolean;
+ FTFileSize: Integer;
+ FTToFile: Boolean;
+
+ BytesToRead, BytesReaded: DWord;
+
+ FTProgress: TOnProgressEvent;
+
+ procedure UpdateProgress;
+ protected
+ procedure Execute; override;
+ public
+ constructor Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName, aPassword, aPostQuery, aReferer: String;
+ aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);
+ end;
+
+ THTTPGet = class(TComponent)
+ private
+ FAcceptTypes: String;
+ FAgent: String;
+ FBinaryData: Boolean;
+ FURL: String;
+ FUseCache: Boolean;
+ FFileName: String;
+ FUserName: String;
+ FPassword: String;
+ FPostQuery: String;
+ FReferer: String;
+ FWaitThread: Boolean;
+
+ FThread: THTTPGetThread;
+ FError: TNotifyEvent;
+ FResult: Boolean;
+
+ FProgress: TOnProgressEvent;
+ FDoneFile: TOnDoneFileEvent;
+ FDoneString: TOnDoneStringEvent;
+
+ procedure ThreadDone(Sender: TObject);
+ public
+ constructor Create(aOwner: TComponent); override;
+ destructor Destroy; override;
+
+ procedure GetFile;
+ procedure GetString;
+ procedure Abort;
+ published
+ property AcceptTypes: String read FAcceptTypes write FAcceptTypes;
+ property Agent: String read FAgent write FAgent;
+ property BinaryData: Boolean read FBinaryData write FBinaryData;
+ property URL: String read FURL write FURL;
+ property UseCache: Boolean read FUseCache write FUseCache;
+ property FileName: String read FFileName write FFileName;
+ property UserName: String read FUserName write FUserName;
+ property Password: String read FPassword write FPassword;
+ property PostQuery: String read FPostQuery write FPostQuery;
+ property Referer: String read FReferer write FReferer;
+ property WaitThread: Boolean read FWaitThread write FWaitThread;
+
+ property OnProgress: TOnProgressEvent read FProgress write FProgress;
+ property OnDoneFile: TOnDoneFileEvent read FDoneFile write FDoneFile;
+ property OnDoneString: TOnDoneStringEvent read FDoneString write FDoneString;
+ property OnError: TNotifyEvent read FError write FError;
+ end;
+
+procedure Register;
+
+implementation
+
+// THTTPGetThread
+
+constructor THTTPGetThread.Create(aAcceptTypes, aAgent, aURL, aFileName, aUserName, aPassword, aPostQuery, aReferer: String;
+ aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);
+begin
+ FreeOnTerminate := True;
+ inherited Create(True);
+
+ FTAcceptTypes := aAcceptTypes;
+ FTAgent := aAgent;
+ FTURL := aURL;
+ FTFileName := aFileName;
+ FTUserName := aUserName;
+ FTPassword := aPassword;
+ FTPostQuery := aPostQuery;
+ FTReferer := aReferer;
+ FTProgress := aProgress;
+ FTBinaryData := aBinaryData;
+ FTUseCache := aUseCache;
+
+ FTToFile := aToFile;
+ Resume;
+end;
+
+procedure THTTPGetThread.UpdateProgress;
+begin
+ FTProgress(Self, FTFileSize, BytesReaded);
+end;
+
+procedure THTTPGetThread.Execute;
+var
+ hSession, hConnect, hRequest: hInternet;
+ HostName, FileName: String;
+ f: File;
+ Buf: Pointer;
+ dwBufLen, dwIndex: DWord;
+ Data: Array[0..$400] of Char;
+ TempStr: String;
+ RequestMethod: PChar;
+ InternetFlag: DWord;
+ AcceptType: LPStr;
+
+ procedure ParseURL(URL: String; var HostName, FileName: String);
+
+ procedure ReplaceChar(c1, c2: Char; var St: String);
+ var
+ p: Integer;
+ begin
+ while True do
+ begin
+ p := Pos(c1, St);
+ if p = 0 then Break
+ else St[p] := c2;
+ end;
+ end;
+
+ var
+ i: Integer;
+ begin
+ if Pos('http://', LowerCase(URL)) <> 0 then
+ System.Delete(URL, 1, 7);
+
+ i := Pos('/', URL);
+ HostName := Copy(URL, 1, i);
+ FileName := Copy(URL, i, Length(URL) - i + 1);
+
+ if (Length(HostName) > 0) and (HostName[Length(HostName)] = '/') then
+ SetLength(HostName, Length(HostName) - 1);
+ end;
+
+ procedure CloseHandles;
+ begin
+ InternetCloseHandle(hRequest);
+ InternetCloseHandle(hConnect);
+ InternetCloseHandle(hSession);
+ end;
+
+begin
+ try
+ ParseURL(FTURL, HostName, FileName);
+
+ if Terminated then
+ begin
+ FTResult := False;
+ Exit;
+ end;
+
+ if FTAgent <> '' then
+ hSession := InternetOpen(PChar(FTAgent),
+ INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0)
+ else
+ hSession := InternetOpen(nil,
+ INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
+
+ hConnect := InternetConnect(hSession, PChar(HostName),
+ INTERNET_DEFAULT_HTTP_PORT, PChar(FTUserName), PChar(FTPassword), INTERNET_SERVICE_HTTP, 0, 0);
+
+ if FTPostQuery = '' then RequestMethod := 'GET'
+ else RequestMethod := 'POST';
+
+ if FTUseCache then InternetFlag := 0
+ else InternetFlag := INTERNET_FLAG_RELOAD;
+
+ AcceptType := PChar('Accept: ' + FTAcceptTypes);
+ hRequest := HttpOpenRequest(hConnect, RequestMethod, PChar(FileName), 'HTTP/1.0',
+ PChar(FTReferer), @AcceptType, InternetFlag, 0);
+
+ if FTPostQuery = '' then
+ HttpSendRequest(hRequest, nil, 0, nil, 0)
+ else
+ HttpSendRequest(hRequest, 'Content-Type: application/x-www-form-urlencoded', 47,
+ PChar(FTPostQuery), Length(FTPostQuery));
+
+ if Terminated then
+ begin
+ CloseHandles;
+ FTResult := False;
+ Exit;
+ end;
+
+ dwIndex := 0;
+ dwBufLen := 1024;
+ GetMem(Buf, dwBufLen);
+
+ FTResult := HttpQueryInfo(hRequest, HTTP_QUERY_CONTENT_LENGTH,
+ Buf, dwBufLen, dwIndex);
+
+ if Terminated then
+ begin
+ FreeMem(Buf);
+ CloseHandles;
+ FTResult := False;
+ Exit;
+ end;
+
+ if FTResult or not FTBinaryData then
+ begin
+ if FTResult then
+ FTFileSize := StrToInt(StrPas(Buf));
+
+ BytesReaded := 0;
+
+ if FTToFile then
+ begin
+ AssignFile(f, FTFileName);
+ Rewrite(f, 1);
+ end
+ else FTStringResult := '';
+
+ while True do
+ begin
+ if Terminated then
+ begin
+ if FTToFile then CloseFile(f);
+ FreeMem(Buf);
+ CloseHandles;
+
+ FTResult := False;
+ Exit;
+ end;
+
+ if not InternetReadFile(hRequest, @Data, SizeOf(Data), BytesToRead) then Break
+ else
+ if BytesToRead = 0 then Break
+ else
+ begin
+ if FTToFile then
+ BlockWrite(f, Data, BytesToRead)
+ else
+ begin
+ TempStr := Data;
+ SetLength(TempStr, BytesToRead);
+ FTStringResult := FTStringResult + TempStr;
+ end;
+
+ inc(BytesReaded, BytesToRead);
+ if Assigned(FTProgress) then
+ Synchronize(UpdateProgress);
+ end;
+ end;
+
+ if FTToFile then
+ FTResult := FTFileSize = Integer(BytesReaded)
+ else
+ begin
+ SetLength(FTStringResult, BytesReaded);
+ FTResult := BytesReaded <> 0;
+ end;
+
+ if FTToFile then CloseFile(f);
+ end;
+
+ FreeMem(Buf);
+
+ CloseHandles;
+ except
+ end;
+end;
+
+// HTTPGet
+
+constructor THTTPGet.Create(aOwner: TComponent);
+begin
+ inherited Create(aOwner);
+ FAcceptTypes := '*/*';
+ FAgent := 'UtilMind HTTPGet';
+end;
+
+destructor THTTPGet.Destroy;
+begin
+ Abort;
+ inherited Destroy;
+end;
+
+procedure THTTPGet.GetFile;
+var
+ Msg: TMsg;
+begin
+ if not Assigned(FThread) then
+ begin
+ FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName, FUserName, FPassword, FPostQuery, FReferer,
+ FBinaryData, FUseCache, FProgress, True);
+ FThread.OnTerminate := ThreadDone;
+ if FWaitThread then
+ while Assigned(FThread) do
+ while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
+ begin
+ TranslateMessage(Msg);
+ DispatchMessage(Msg);
+ end;
+ end
+end;
+
+procedure THTTPGet.GetString;
+var
+ Msg: TMsg;
+begin
+ if not Assigned(FThread) then
+ begin
+ FThread := THTTPGetThread.Create(FAcceptTypes, FAgent, FURL, FFileName, FUserName, FPassword, FPostQuery, FReferer,
+ FBinaryData, FUseCache, FProgress, False);
+ FThread.OnTerminate := ThreadDone;
+ if FWaitThread then
+ while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
+ begin
+ TranslateMessage(Msg);
+ DispatchMessage(Msg);
+ end;
+ end
+end;
+
+procedure THTTPGet.Abort;
+begin
+ if Assigned(FThread) then
+ begin
+ FThread.Terminate;
+ FThread.FTResult := False;
+ end;
+end;
+
+procedure THTTPGet.ThreadDone(Sender: TObject);
+begin
+ FResult := FThread.FTResult;
+ if FResult then
+ if FThread.FTToFile then
+ if Assigned(FDoneFile) then FDoneFile(Self, FThread.FTFileName, FThread.FTFileSize) else
+ else
+ if Assigned(FDoneString) then FDoneString(Self, FThread.FTStringResult) else
+ else
+ if Assigned(FError) then FError(Self);
+ FThread := nil;
+end;
+
+procedure Register;
+begin
+ RegisterComponents('UtilMind', [THTTPGet]);
+end;
+
+end.