Although there is only such something, I still did it for 3 days, old.
/ ** The core of the program, a POST thread, used to submit an XML packet
* Author: Liu Kun
* Last modified Date: 2004-9-23
* The above code is free, if you directly quote the code, please tell and keep this comment
* As a programmer, there should be the most basic professional ethics * /
Unit httpgetthread;
InterfaceUses Classes, Sysutils, Wininet, Windows
Type TonProgressEvent = Procedure (Totalsize, Readed: Integer) OF Object;
THTTPGETTHREAD = Class (TTHREAD)
Private fTACCEPTTYPES: STRING; // Receive file type *. * ftagent: string; // Browser NOKIA6610 / 1.0 (5.52) Profile / MIDP-1.0 Configuration / CLDC-1.02 fTURL: String; // URL FTFileName: String; / / File name ftstringResult: Ansistring; ftusername: string; // User name ftpassword: string; // password ftpostQuery: string; // method name, post or get ftreferr: string; ftbinarydata: boolean; ftusecache: boolean; // Cache read data ftmimeType: string; // mime type
FTRESULT: BOOLEAN; ftfilesize: integer; fttofile: boolean; //
Bytestoread, bytesReaded: longword;
FTProgress: TOnProgressEvent; procedure ParseURL (URL: string; var HostName, FileName: string; var portNO: integer); // get the url host name and file name procedure UpdateProgress; protected procedure Execute; override; public procedure setResult (FResult: boolean) ; function getResult (): boolean; function getFileName (): string; function getToFile (): boolean; function getFileSize (): integer; function getStringResult (): AnsiString; constructor Create (aAcceptTypes, aMimeType, aAgent, aURL, aFileName, aUserName Apassword, ApostQuery, Areferer: String; ABINARYDATA, AUSECACHE: Boolean; APRESS: TONPROGRESSEVENT; ATOFILE: BOOLEAN);
END;
IMPLEMENTATION
{THTTPGETTHREAD}
constructor THTTPGetThread.Create (aAcceptTypes, aMimeType, aAgent, aURL, aFileName, aUserName, aPassword, aPostQuery, aReferer: string; aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile: Boolean); begin FreeOnTerminate: = True; inherited Create (True FTACCEPTTYPES: = AACCEPTTTYPES; ftagent: = aagent; ftURL: = AURL; ftFileName: = AFILENAME; ftusername: = ausername; ftpassword: = apassword;
// ftpostQuery: = apostquery;
FtpostQuery: = StringReplace (apostQuery, # 13 # 10, '', [RFREPLACEALL]);
FTREFERER: = Areferer; ftprogress: = APROGRESS; ftbinarydata: = abinerarydata; ftusecache: = ausecache; ftmimety: = amimetype;
FTTOFILE: = ATOFILE; RESUME;
procedure THTTPGetThread.Execute; var hSession: hInternet; // Handle answer hConnect: hInternet; // connection handle hRequest: hInternet; // request handle Host_Name: string; // hostname File_Name: string; // file name port_no: integer;
RequestMethod: PChar; InternetFlag: longWord; AcceptType: PAnsiChar; dwBufLen, dwIndex: longword; Buf: Pointer; // Buffer f: file; Data: array [0 .. $ 400] of Char; TempStr: AnsiString; mime_Head: string;
Procedure closehandles; begin internetcloseHandle (HREQUEST); InternetCloseHandle (HConnect); InternetCloseHandle (HSession);
Begin inherited; buf: = nil; try try Parseurl (fTURL, HOST_NAME, FILE_NAME, PORT_NO);
if Terminated then begin FTResult: = False; Exit; end; // establish a session hSession: = InternetOpen (pchar (FTAgent), // lpszCallerName INTERNET_OPEN_TYPE_PRECONFIG specify the application using the network function, // parameter specifies the type of access dwAccessType nil, / / server name (lpszProxyName) accesstype is nil GATEWAY_PROXY_INTERNET_ACCESS and CERN_PROXY_ACCESS, // NProxyPort CERN_PROXY_INTERNET_ACCESS port number in the parameters used to specify the number of ports provided corresponding to INTERNET_INVALID_PORT_NUMBER is the province of 0);... // set additional select. You can use the Internet_flag_async flag to indicate the future Internet function using the return clause will send status information to the callback function, and use InternetStatusCallback to make this setting // establish the connection hconnect: = InternetConnect (host_name), / (To the host name (such as http://www.mit.edu) or IP address (such as 202.102.13.141), the host name (such as 202.102.13.141), is the TCP / IP to which it is to be connected. Port number PCHAR (FTUSERNAME), // User Name PCHAR (FTPASSWORD), // Password Internet_Service_http, // Protocol 0, // Optional Tag, set to Internet_Flag_Secure, indicating completion of transaction using SSL / PCT protocol); // Application The value defined by the program, used to identify the application device field for the handle
IF ftpostQuery = '' Then RequestMethod: = 'get' else requestmethod: = 'post';
IF ftusecache the internetflag: = 0 else internetflag: = Internet_flag_reload;
AcceptType: = PCHAR ('Accept:' ftaccepttypes);
// Establish an HTTP request handler hRequest: = httpopenRequest (HTTP session handle RetuStMethod returned by httpoPopnect ", // pointing to the string of" verbs "used in the application, if set to NULL, use" get "PCHAR (File_name), point to the string of the target object name containing the verb, usually the file name, executable module, or search speciferer 'http / 1.0', and point to the string containing the HTTP version, if null, The default is "http / 1.0"; PCHAR (FTREFERER), / / Point to the string containing the document address (URL), the URL of the application must be the @accePtType obtained from the document, // pointing to the type of content received by the customer. 0); mime_Head: = 'Content-Type:' FTMimeType; if FTPostQuery = '' then FTResult: = HttpSendRequest (hRequest, nil, 0, nil, 0) else // send a request to the specified httpserver FTResult: = HttpSendRequest ( HREQUEST, PCHAR (MIME_HEAD), / / MIME head length (MIME_HEAD), // head length PCHAR (FTPOSTQUERY), // Additional data buffer, can be empty Strlen (pchar (ftpostQuery))); // Additional data buffer Length if Terminated the begin // CloseHandles; ftresult: = false;
DWINDEX: = 0; dwbufflen: = 1024; getMem (buf, dwbufflen);
/ / Receive Header Information and an HTTP Request FTRESULT: = HttpQueryInfo (HREQUEST, HTTP_QUERY_CONTENT_LENGTH, BUF, // pointing to a pointer dwbufflen, // httpqueryInfo content of a buffer of a receiving request information DwINDEX); // Read the byte number
IF Terminated the Begin FTRESULT: = FALSE; EXIT; END;
IF ftresult or not ftbinarydata the begin // If the request if ftresult kiln ftfilesize: = start (STRPAS (BUF));
BYTESREADED: = 0;
IF fttofile the begin AssignFile (f, ftfilename); ReWrite (f, 1); end else ftstringResult: = ';
While True Do Begin if Terminated the Begin ftresult: = false; EXIT; End; if not internetReadFile (HREQUEST, @Data, // Data contents SizeOf (DATA), / / Size Bytestoread // Read the number of bytes THEN BREAK else if BytesToRead = 0 then Break else begin if FTToFile then BlockWrite (f, data, BytesToRead) // read out the data written to the file else begin tempStr: = data; SetLength (tempStr, BytesToRead); FTStringResult: = FTStringResult tempStr ;
INC (BytesReaded, Bytestoread);
If Assigned (ftprogress) then // performs a callback function synchronize (UpdateProgress);
END;
IF fttofile1 ftresult: = ftfilesize = integer (bytesReaded) else begin // setlength (ftresult: = bytesReaded <> 0;
End; Except end; Finally if fttofile the closefile (f);
IF assigned (buf) THENFREMEM (BUF); CloseHandles; end;
Function THTTPGETTHREAD.GETFILENAME: String; Begin Result: = ftfilename;
Function THTTPGETTHREAD.GETFILESIZE: Integer; Begin Result: = ftfilesize;
Function THTTPGETTHREAD.GETRESULT: BOOLEAN; Begin Result: = ftresult;
Function THTTPGETTHREAD.GETSTRINGRESULT: ANSISTRING;
Function THTTPGETTHREAD.GETTOFILE: BOOLEAN; begin result: = fttofile;
Procedure httpgetthread.parseurl (URL: String; Var Hostname, FileName: String; Var portno: integer; var i: integer; begin if Pos ('http: //', lowercase (URL)) <> 0 Then Delete (URL , 1, 7);
I: = POS ('/', url); hostname: = COPY (URL, 1, I); filename: = Copy (URL, I, Length (URL) - i 1); i: = POS (': ', hostname; IF i <> 0 THEN Begin portno: = start (Hostname, i 1, length (hostname) - i - 1); hostname: = Copy (Hostname, 1, i - 1); ELSE portno: = 80;
IF (Hostname> 0) and (Hostname [Hostname)] = '/') THEN SETLENGTH (Hostname, Length (Hostname) - 1);
Procedure THTTPGETTHREAD.SETRESULT (FRESULT: BOOLT); Begin FTRESULT: = FRESULT; END;
Procedure httpgetthread.updateprogress; begin ftprogress (ftfilesize, bytesreaded);
End.
/ ** Mainly used to do interactions with threads and interfaces
* Author: Liu Kun
* Last modified Date: 2004-9-23
* The above code is free, if you directly quote the code, please tell and keep this comment
* As a programmer, there should be the most basic professional ethics * /
Unit myhttpget;
Interface
Uses httpgetthread, windows;
TYPE TONDONEFILEEVENT = procedure (filename: string; filesize: integer) of object; tondonestringevent = procedure (result: Ansistring) OF Object;
THTTPGET = Class Private f_url: string; // Target URL F_GETURLTHREAD: THTTPGETTHREAD; // Take the thread of the data
F_Accept_Types: string; F_Agent: string; F_Binary_Data: Boolean; F_Use_Cache: Boolean; // whether read cache F_File_Name: string; F_User_Name: string; // username F_Password: string; // password F_PostQuery: string; // method name F_Referer: String; f_mime_type: string;
F_wait_thread: boolean;
FRESULT: BOOLEAN;
FPROGRESS: TONPROGRESSEVENT; FDONEFILE: TONDONEFILEVENT; FDONESTRING: TONDONESTRINGEVENT
Procedure threaddone (Sender: TOBJECT);
public constructor Create (); destructor Destroy (); override; procedure getFile (); procedure GetString (); procedure Abort (); published property WaitThread: Boolean read F_Wait_Thread write F_Wait_Thread; property AcceptTypes: string read F_Accept_Types write F_Accept_Types; property Agent: string read F_Agent write F_Agent; property BinaryData: Boolean read F_Binary_Data write F_Binary_Data; property URL: string read F_URL write F_URL; property useCache: Boolean read F_Use_Cache write F_Use_Cache; property FileName: string read F_File_Name write F_File_Name; property UserName: string read F_User_Name write F_User_Name ; property Password: string read F_Password write F_Password; property PostQuery: string read F_PostQuery write F_PostQuery; property Referer: string read F_Referer write F_Referer; property MimeType: string read F_Mime_Type write F_Mime_Type; property OnDoneFile: TOnDoneFileEvent read FDoneFile write FDoneFile; property Ondonestring: Tondonestringevent Read FDONESTRING WRITE FDONESTRING; END;
IMPLEMENTATION
{THTTPGET}
PROCEDURE THTTPGET.ABORT; Begin if Assigned (f_geturlthread) THEN BEGINK F_GETURLTHREAD.TERMINATE; F_GETURLTHREAD.SETRESULT (FALSE); END;
Constructor tenpget.create; begin f_accept_types: = '* / *'; f_agent: = 'NOKIA6610 / 1.0 (5.52) Profile / MIDP-1.0 Configuration / CLDC-1.02'; END;
Destructor THTTPGET.DESTROY; Begin
END;
procedure THttpGet.getFile; var Msg: TMsg; begin if not Assigned (F_GetURLThread) then begin F_GetURLThread: = THTTPGetThread.Create (F_Accept_Types, F_Mime_Type, F_Agent, F_URL, F_File_Name, F_User_Name, F_Password, F_PostQuery, F_Referer, F_Binary_Data, F_Use_Cache, FProgress, true); F_GetURLThread.OnTerminate: = ThreadDone; if F_Wait_Thread then while Assigned (F_GetURLThread) do while PeekMessage (Msg, 0, 0, 0, PM_REMOVE) do begin TranslateMessage (Msg); DispatchMessage (Msg); end; endend; procedure THttpGet .GetString; var Msg: TMsg; begin if not Assigned (F_GetURLThread) then begin F_GetURLThread: = THTTPGetThread.Create (F_Accept_Types, F_Mime_Type, F_Agent, F_URL, F_File_Name, F_User_Name, F_Password, F_PostQuery, F_Referer, F_Binary_Data, F_Use_Cache, FProgress, False) F_geturlthread.onterminate: = threaddone; if f_wait_thread kilover (f_geturlthread) Do While PeekMessage (msg, 0, 0, 0, pm_remove) Do Be Gin TranslateMessage (MSG); DispatchMessage (MSG); end; end;
procedure THttpGet.ThreadDone (Sender: TObject); begin FResult: = F_GetURLThread.getResult; if FResult then if F_GetURLThread.getToFile then begin if Assigned (FDoneFile) then FDoneFile (F_GetURLThread.getFileName, F_GetURLThread.getFileSize) end else if Assigned (FDoneString) Then fdonestring (f_geturlthread.getstringResult);
// end else if assigned (ferr) THEN FERROR (Self); f_geturlthread: = NIL; END;
End.
/ ** Program main interface
* Author: Liu Kun
* Last modified Date: 2004-9-23
* The above code is free, if you directly quote the code, please tell and keep this comment
* As a programmer, there should be the most basic professional ethics * /
Unit mainform;
Interface
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, MyHttpGet; type TMain = class (TForm) Panel1: TPanel; Edit1: TEdit; Label1: TLabel; Panel2: TPanel; Panel3: TPanel; GroupBox1: TGroupBox; MeSend: TMemo; GroupBox2: TGroupBox; MeReceive: TMemo; Button1: TButton; CbSave: TCheckBox; Edit2: TEdit; Label2: TLabel; procedure Button1Click (Sender: TObject); private {Private declarations} procedure onGetString ( Result: ansistring; procedure ONGETFILE (FileName: String; FileSize: integer);
Public {public declarations}
Var main: tMAIN;
IMPLEMENTATION
{$ R * .dfm}
Procedure tMain.Button1Click (Sender: Tobject); VAR HG: THTTPGET; Strs: tstrings; i: integer; begin hg: = nil; strs: = nil; try strs: = tstringlist.create; hg: = trtpget.create; hg .Waitthread: = false; hg.accepttypes: = '*. *';
Hg.Agent: = 'NOKIA6610 / 1.0 (5.52) Profile / MIDP-1.0 Configuration / CLDC-1.02'; hg.binarydata: = false; hg.url: = 'http: //' edit1.text; hg.usecache : = false; hg.filename: = 'provison.xml'; hg.username: = ''; hg.password: = ';
For i: = 0 to mesend.lines.count - 1 do strs.add (Trim (mesend.lines [i]));
Hg.PostQuery: = strs.text; hg.referer: = 'http: //' edit1.text; // text / plain hg.mimetype: = edit2.text; hg.ondonestring: = OnGetString; hg.ondonefile: = ONGETFILE;
Hg.getstring; finally strs.free; hg.free; end; end;
Procedure Tmain.onGetfile (FileName: String; FileSize: Integer); Begin
END;
Procedure tMain.ongetstring (result: ansistring); begin mereceive.lines.text: = result; end; end;
