雖然只有這么點東西,但我還是做了3天,老了
一個sp用的wap訂購關系包調試檢測工具
/** 程序的核心,一個post線程,用于提交xml數據包
* 作者:劉昆
* 最后修改日期: 2004-9-23
* 以上代碼免費,若直接引用一下代碼請告知,并保留此注釋
* 作為一名程序員應該有最基本的職業道德*/
unit HTTPGetThread;
interface
uses classes, SysUtils, wininet, windows;
type
TOnProgressEvent = procedure(TotalSize, Readed: Integer) of object;
THTTPGetThread = class(TThread)
private
FTAcceptTypes: string; //接收文件類型 *.*
FTAgent: string; //瀏覽器名 Nokia6610/1.0 (5.52) Profile/MIDP-1.0 Configuration/CLDC-1.02
FTURL: string; // url
FTFileName: string; //文件名
FTStringResult: AnsiString;
FTUserName: string; //用戶名
FTPassword: string; //密碼
FTPostQuery: string; //方法名,post或者get
FTReferer: string;
FTBinaryData: Boolean;
FTUseCache: Boolean; //是否從緩存讀數據
FTMimeType: string; //Mime類型
FTResult: Boolean;
FTFileSize: Integer;
FTToFile: Boolean; //是否文件
BytesToRead, BytesReaded: LongWord;
FTProgress: TOnProgressEvent;
procedure ParseURL(URL: string; var HostName, FileName: string; var portNO: integer); //取得url的主機名和文件名
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; aProgress: 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 := aAcceptTypes;
FTAgent := aAgent;
FTURL := aURL;
FTFileName := aFileName;
FTUserName := aUserName;
FTPassword := aPassword;
//FTPostQuery := aPostQuery;
FTPostQuery := StringReplace(aPostQuery, #13#10, '', [rfReplaceAll]);
FTReferer := aReferer;
FTProgress := aProgress;
FTBinaryData := aBinaryData;
FTUseCache := aUseCache;
FTMimeType := aMimeType;
FTToFile := aToFile;
Resume;
end;
procedure THTTPGetThread.Execute;
var
hSession: hInternet; //回話句柄
hConnect: hInternet; //連接句柄
hRequest: hInternet; //請求句柄
Host_Name: string; //主機名
File_Name: string; //文件名
port_no: integer;
RequestMethod: PChar;
InternetFlag: longWord;
AcceptType: PAnsiChar;
dwBufLen, dwIndex: longword;
Buf: Pointer; //緩沖區
f: file;
Data: array[0..$400] of Char;
TempStr: AnsiString;
mime_Head: string;
procedure CloseHandles;
begin
InternetCloseHandle(hRequest);
InternetCloseHandle(hConnect);
InternetCloseHandle(hSession);
end;
begin
inherited;
buf := nil;
try
try
ParseURL(FTURL, Host_Name, File_Name, port_no);
if Terminated then begin
FTResult := False;
Exit;
end;
//建立會話
hSession := InternetOpen(pchar(FTAgent), //lpszCallerName指定正在使用網絡函數的應用程序
INTERNET_OPEN_TYPE_PRECONFIG, //參數dwAccessType指定訪問類型
nil, //服務器名（lpszProxyName）。 accesstype為GATEWAY_PROXY_INTERNET_ACCESS和CERN_PROXY_ACCESS時
nil, //NProxyPort參數用在CERN_PROXY_INTERNET_ACCESS中用來指定使用的端口數。使用INTERNET_INVALID_PORT_NUMBER相當于提供卻省的端口數。
0); //設置額外的選擇。你可以使用INTERNET_FLAG_ASYNC標志去指示使用返回句句柄的將來的Internet函數將為回調函數發送狀態信息，使用InternetSetStatusCallback進行此項設置
//建立連接
hConnect := InternetConnect(hSession, //會話句柄
PChar(Host_Name), //指向包含Internet服務器的主機名稱（如http://www.mit.edu）或IP地址（如202.102.13.141）的字符串
port_no, //INTERNET_DEFAULT_HTTP_PORT, //是將要連結到的TCP/IP的端口號
PChar(FTUserName), //用戶名
PChar(FTPassword), //密碼
INTERNET_SERVICE_HTTP, //協議
0, // 可選標記，設置為INTERNET_FLAG_SECURE，表示使用SSL/PCT協議完成事務
0); //應用程序定義的值，用來為返回的句柄標識應用程序設備場境
if FTPostQuery = '' then RequestMethod := 'GET'
else RequestMethod := 'POST';
if FTUseCache then InternetFlag := 0
else InternetFlag := INTERNET_FLAG_RELOAD;
AcceptType := PChar('Accept: ' + FTAcceptTypes);
//建立一個http請求句柄
hRequest := HttpOpenRequest(hConnect, //InternetConnect返回的HTTP會話句柄
RequestMethod, //指向在申請中使用的"動詞"的字符串，如果設置為NULL，則使用"GET"
PChar(File_Name), //指向包含動詞的目標對象名稱的字符串，通常是文件名稱、可執行模塊或搜索說明符
'HTTP/1.0', //指向包含HTTP版本的字符串，如果為NULL，則默認為"HTTP/1.0"；
PChar(FTReferer), //指向包含文檔地址（URL）的字符串，申請的URL必須是從該文檔獲取的
@AcceptType, //指向客戶接收的內容的類型
InternetFlag,
0);
mime_Head := 'Content-Type: ' + FTMimeType;
if FTPostQuery = '' then
FTResult := HttpSendRequest(hRequest, nil, 0, nil, 0)
else
//發送一個指定請求到httpserver
FTResult := HttpSendRequest(hRequest,
pchar(mime_Head), //mime 頭
length(mime_Head), //頭長度
PChar(FTPostQuery), //附加數據緩沖區，可為空
strlen(PChar(FTPostQuery))); //附加數據緩沖區長度
if Terminated then
begin
//CloseHandles;
FTResult := False;
Exit;
end;
dwIndex := 0;
dwBufLen := 1024;
GetMem(Buf, dwBufLen);
//接收header信息和一個http請求
FTResult := HttpQueryInfo(hRequest,
HTTP_QUERY_CONTENT_LENGTH,
Buf, //指向一個接收請求信息的緩沖區的指針
dwBufLen, //HttpQueryInfo內容的大小
dwIndex); //讀取的字節數
if Terminated then begin
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
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;
end;
except
end;
finally
if FTToFile then CloseFile(f);
if assigned(Buf) then FreeMem(Buf);
CloseHandles;
end;
end;
function THTTPGetThread.getFileName: string;
begin
result := FTFileName;
end;
function THTTPGetThread.getFileSize: integer;
begin
result := FTFileSize;
end;
function THTTPGetThread.getResult: boolean;
begin
result := FTResult;
end;
function THTTPGetThread.getStringResult: AnsiString;
begin
result := FTStringResult;
end;
function THTTPGetThread.getToFile: boolean;
begin
result := FTToFile;
end;
procedure THTTPGetThread.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 := strtoint(copy(hostName, i + 1, length(hostName) - i - 1));
hostName := copy(hostName, 1, i - 1);
end else portNO := 80;
if (Length(HostName) > 0) and (HostName[Length(HostName)] = '/') then SetLength(HostName, Length(HostName) - 1);
end;
procedure THTTPGetThread.setResult(FResult: boolean);
begin
FTResult := FResult;
end;
procedure THTTPGetThread.UpdateProgress;
begin
FTProgress(FTFileSize, BytesReaded);
end;
end.
/** 主要用來做線程和界面的交互
* 作者:劉昆
* 最后修改日期: 2004-9-23
* 以上代碼免費,若直接引用一下代碼請告知,并保留此注釋
* 作為一名程序員應該有最基本的職業道德*/
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; //目標url
F_GetURLThread: THTTPGetThread; //取數據的線程
F_Accept_Types: string;
F_Agent: string;
F_Binary_Data: Boolean;
F_Use_Cache: Boolean; //是否讀緩存
F_File_Name: string;
F_User_Name: string; //用戶名
F_Password: string; //密碼
F_PostQuery: string; //方法名
F_Referer: string;
F_Mime_Type: string;
F_Wait_Thread: Boolean;
FResult: Boolean;
FProgress: TOnProgressEvent;
FDoneFile: TOnDoneFileEvent;
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
begin
F_GetURLThread.Terminate;
F_GetURLThread.setResult(false);
end;
end;
constructor THttpGet.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;
end
end;
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 then
while Assigned(F_GetURLThread) do
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
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(FError) then FError(Self);
F_GetURLThread := nil;
end;
end.
/** 程序主界面
* 作者:劉昆
* 最后修改日期: 2004-9-23
* 以上代碼免費,若直接引用一下代碼請告知,并保留此注釋
* 作為一名程序員應該有最基本的職業道德*/
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 }
end;
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 := THttpGet.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.