mirror of
https://bitbucket.org/grumdrig/pq.git
synced 2026-09-29 00:33:59 -06:00
Part II: This is an ex post facto rendering of pq6 in its various versions in
svn, so that changes will be trackable thataway This is version 6.1 as found in the old sources. Used whathappened.py to update it.
This commit is contained in:
Eric Fredricksen
+448
@@ -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.
|
||||
Reference in New Issue
Block a user