虽然只有这么点东西,但我还是做了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.