delphi 多线程 获取网页的问题
unit WinHttp;
interface
uses
WinSock, Sockets, Windows, SysUtils, Classes;
const
HTTP_OK = 1;
HTTP_TIMEOUT = 2;
HTTP_FAIL = 3;
HTTP_STATECODE_ERR = 4;
type THttpData = record
WSAData:TWSAData;
Host, Path:string;
sockfd:Integer; //套接字
hostEnt:PHostEnt;
addr:sockaddr_in;
SocketHost:TSocketHost;
IsCon:Boolean;
end;
PHttpData = ^THttpData;
type
TWinHttp = class( TObject )
private
FHttpData:THttpData;
FTimeOut:Integer;
FCookie:string;
FHttpHead:string;
FStateCode:Integer;
FLocation:string;
FUrl:string;
FReferer:string;
private
procedure ParseURL( const Url:string; var Host, Path:string);
function Conn( var HttpData:THttpData ):Boolean;
public
property TimeOut: Integer read FTimeOut write FTimeOut;
property Cookie: string read FCookie write FCookie;
property Referer: string read FReferer write FReferer;
function Get( Url:string ):string;
procedure Head( Url:string );
function Post( Url:string; PostData:string ):string;
function HttpHead:string;
function StateCode:Integer;
function Location:string;
constructor Create;overload;
end;
implementation
type
TRecvThread = class( TThread )
private
FHttpData:THttpData;
protected
procedure Execute; override;
public
HtmlSource:string;
HttpHead:string;
StateCode:Integer;
ResultValue:Integer;
public
constructor Create( HttpData:THttpData );overload;
end;
constructor TRecvThread.Create( HttpData:THttpData );
begin
FHttpData := HttpData;
inherited Create( False );
end;
procedure TRecvThread.Execute;
var
Buf:array[0..1024] of char;
nPos,nRecv:Integer;
HeadFine:Boolean;
begin
//FreeOnTerminate := True;
HtmlSource := '';
HttpHead := '';
StateCode := 0;
ResultValue := 1;
HeadFine := False;
while True do
begin
FillChar( Buf, 1024, 0 );
nRecv := recv( FHttpData.sockfd, Buf, 1024, 0 );
if nRecv > 0 then
begin
HtmlSource := HtmlSource + Buf;
if not HeadFine then
begin
nPos := Pos( #13#10#13#10, HtmlSource );
if nPos <> 0 then
begin
HttpHead := Copy( HtmlSource, 1, nPos );
StateCode := StrToInt( Copy( HttpHead, 10, 3 ) );
HeadFine := True;
end;
end;
end
else if nRecv = -1 then
begin
ResultValue := -1;
HtmlSource := '';
Break;
end
else
begin
ResultValue := 0;
Break;
end;
end;
end;
constructor TWinHttp.Create;
begin
FTimeOut := 30;
FHttpData.IsCon := False;
end;
procedure TWinHttp.Head( Url:string );
var
SendBuf:array[0..10240] of char;
RecvThread:TRecvThread;
nPos:Integer;
label start;
begin
start:
FUrl := Url;
Conn( FHttpData );
if FHttpData.IsCon then
begin
FillChar( SendBuf, 10240, 0 );
lstrcpy( SendBuf, PChar( 'HEAD ' + FHttpData.Path + ' HTTP/1.1' + #13#10 ) );
lstrcat( SendBuf, PChar( 'Host: ' + FHttpData.Host + #13#10 ) );
lstrcat( SendBuf, PChar( 'User-Agent: Mozilla/5.0' +
' (Windows; U; Windows NT 5.1; zh-CN; rv:1.9.2.15)' +
' Gecko/20110303 Firefox/3.6.15' + #13#10 ) );
lstrcat( SendBuf, PChar( 'Content-Type: ' +
'application/x-www-form-urlencoded;' + #13#10 ) );
lstrcat( SendBuf, PChar( 'Connection: Close' + #13#10 ) );
if FCookie <> '' then
lstrcat( SendBuf, PChar( 'Cookie: ' + FCookie + #13#10#13#10 ) )
else
lstrcat( SendBuf, PChar( #13#10 ) );
send( FHttpData.sockfd, SendBuf, StrLen( SendBuf ), 0 );
RecvThread := TRecvThread.Create( FHttpData );
if WaitForSingleObject( RecvThread.Handle, FTimeOut * 1000 ) = WAIT_TIMEOUT then
begin
//判断本地网络连接是否正常
if gethostbyname( PChar( FHttpData.Host ) ) <> nil then
begin
FHttpData.IsCon := False;
RecvThread.Free;
goto start;
end;
FHttpHead := '';
end;
if RecvThread.ResultValue = 0 then
begin
FHttpHead := RecvThread.HttpHead;
FStateCode := RecvThread.StateCode;
if FStateCode = 302 then
begin
nPos := Pos( 'Location: ', FHttpHead );
FLocation := Copy( FHttpHead, nPos + Length( 'Location: ' ),
Length( FHttpHead ) - nPos );
FLocation := Copy( FLocation, 1, Pos( #13#10, FLocation ) - 1 );
end;
end
else
begin
//判断本地网络连接是否正常
if gethostbyname( PChar( FHttpData.Host ) ) <> nil then
begin
FHttpData.IsCon := False;
RecvThread.Free;
goto start;
end;
FHttpHead := '';
end;
RecvThread.Free;
//Result := Recv
end
else
begin
//判断本地网络连接是否正常
if gethostbyname( PChar( FHttpData.Host ) ) <> nil then
begin
FHttpData.IsCon := False;
goto start;
end;
FHttpHead := '';
end;
end;
//获取源码
function TWinHttp.Get( Url:string ):string;
var
SendBuf:array[0..10240] of char;
RecvThread:TRecvThread;
HtmlSource:string;
i, nPos, nIndex:Integer;
CookieList:TStringList;
label start;
begin
CookieList := nil;
start:
if CookieList = nil then
CookieList := TStringList.Create
else
CookieList.Clear;
FUrl := Url;
Conn( FHttpData );
if FHttpData.IsCon then
begin
FillChar( SendBuf, 10240, 0 );
lstrcpy( SendBuf, PChar( 'GET ' + FHttpData.Path + ' HTTP/1.1' + #13#10 ) );
lstrcat( SendBuf, PChar( 'Host: ' + FHttpData.Host + #13#10 ) );
lstrcat( SendBuf, PChar( 'User-Agent: Mozilla/5.0' +
' (Windows; U; Windows NT 5.1; zh-CN; rv:1.9.2.15)' +
' Gecko/20110303 Firefox/3.6.15' + #13#10 ) );
lstrcat( SendBuf, PChar( 'Content-Type: ' +
'application/x-www-form-urlencoded;' + #13#10 ) );
lstrcat( SendBuf, PChar( 'Connection: Close' + #13#10 ) );
if FReferer <> '' then
begin
lstrcat( SendBuf, PChar( 'Referer: ' + FReferer + #13#10 ) );
end;
if FCookie <> '' then
lstrcat( SendBuf, PChar( 'Cookie: ' + FCookie + #13#10#13#10 ) )
else
lstrcat( SendBuf, PChar( #13#10 ) );
send( FHttpData.sockfd, SendBuf, StrLen( SendBuf ), 0 );
RecvThread := TRecvThread.Create( FHttpData );
if WaitForSingleObject( RecvThread.Handle, FTimeOut * 1000 ) = WAIT_TIMEOUT then
begin
//判断本地网络连接是否正常
if gethostbyname( PChar( FHttpData.Host ) ) <> nil then
begin
FHttpData.IsCon := False;
RecvThread.Free;
goto start;
end;
HtmlSource := '';
end;
if RecvThread.ResultValue = 0 then
begin
HtmlSource := RecvThread.HtmlSource;
FHttpHead := RecvThread.HttpHead;
FStateCode := RecvThread.StateCode;
if FStateCode = 302 then
begin
nPos := Pos( 'Location: ', FHttpHead );
FLocation := Copy( FHttpHead, nPos + Length( 'Location: ' ),
Length( FHttpHead ) - nPos );
FLocation := Copy( FLocation, 1, Pos( #13#10, FLocation ) - 1 );
end;
ExtractStrings( [#13], [], PChar( FHttpHead ), CookieList );
if CookieList.Count > 0 then
begin
FCookie := '';
for i := 0 to CookieList.Count - 1 do
begin
nPos := Pos( 'Set-Cookie: ', CookieList[i] );
if nPos = 1 then
begin
FCookie := FCookie +
Copy( CookieList[i], Length( 'Set-Cookie: ' ) + 1,
Length( CookieList[i] ) - Length( 'Set-Cookie: ' ) + 1 );
nIndex := Length( FCookie );
if FCookie[nIndex] <> ';' then
FCookie := FCookie + '; ';
end;
end;
end;
end
else
begin
//判断本地网络连接是否正常
if gethostbyname( PChar( FHttpData.Host ) ) <> nil then
begin
FHttpData.IsCon := False;
RecvThread.Free;
goto start;
end;
HtmlSource := '';
end;
RecvThread.Free;
end
else
begin
//判断本地网络连接是否正常
if gethostbyname( PChar( FHttpData.Host ) ) <> nil then
begin
FHttpData.IsCon := False;
goto start;
end;
HtmlSource := '';
end;
CookieList.Free;
Result := HtmlSource;
end;
function TWinHttp.Post( Url:string; PostData:string ):string;
var
SendBuf:array[0..10240] of char;
RecvThread:TRecvThread;
HtmlSource:string;
i,nPos,nIndex:Integer;
CookieList:TStringList;
label start;
begin
CookieList := nil;
start:
if CookieList = nil then
CookieList := TStringList.Create
else
CookieList.Clear;
FUrl := Url;
Conn( FHttpData );
if FHttpData.IsCon then
begin
FillChar( SendBuf, 10240, 0 );
lstrcpy( SendBuf, PChar( 'POST ' + FHttpData.Path + ' HTTP/1.1' + #13#10 ) );
lstrcat( SendBuf, PChar( 'Host: ' + FHttpData.Host + #13#10 ) );
lstrcat( SendBuf, PChar( 'User-Agent: Mozilla/5.0' +
' (Windows; U; Windows NT 5.1; zh-CN; rv:1.9.2.15)' +
' Gecko/20110303 Firefox/3.6.15' + #13#10 ) );
lstrcat( SendBuf, PChar( 'Content-Type: ' +
'application/x-www-form-urlencoded;' + #13#10 ) );
lstrcat( SendBuf, PChar( 'Content-Length: ' +
IntToStr( Length( PostData ) ) + #13#10 ) );
lstrcat( SendBuf, PChar( 'Connection: Close' + #13#10 ) );
if FReferer <> '' then
begin
lstrcat( SendBuf, PChar( 'Referer: ' + FReferer + #13#10 ) );
end;
if FCookie <> '' then
lstrcat( SendBuf, PChar( 'Cookie: ' + FCookie + #13#10#13#10 ) )
else
lstrcat( SendBuf, PChar( #13#10 ) );
lstrcat( SendBuf, PChar( PostData ) );
send( FHttpData.sockfd, SendBuf, StrLen( SendBuf ), 0 );
RecvThread := TRecvThread.Create( FHttpData );
if WaitForSingleObject( RecvThread.Handle, FTimeOut * 1000 ) = WAIT_TIMEOUT then
begin
//判断本地网络连接是否正常
if gethostbyname( PChar( FHttpData.Host ) ) <> nil then
begin
FHttpData.IsCon := False;
RecvThread.Free;
goto start;
end;
HtmlSource := '';
end;
if RecvThread.ResultValue = 0 then
begin
HtmlSource := RecvThread.HtmlSource;
FHttpHead := RecvThread.HttpHead;
FStateCode := RecvThread.StateCode;
if FStateCode = 302 then
begin
nPos := Pos( 'Location: ', FHttpHead );
FLocation := Copy( FHttpHead, nPos + Length( 'Location: ' ),
Length( FHttpHead ) - nPos );
FLocation := Copy( FLocation, 1, Pos( #13#10, FLocation ) - 1 );
end;
ExtractStrings( [#13], [], PChar( FHttpHead ), CookieList );
if CookieList.Count > 0 then
begin
FCookie := '';
for i := 0 to CookieList.Count - 1 do
begin
nPos := Pos( 'Set-Cookie: ', CookieList[i] );
if nPos = 1 then
begin
FCookie := FCookie +
Copy( CookieList[i], Length( 'Set-Cookie: ' ) + 1,
Length( CookieList[i] ) - Length( 'Set-Cookie: ' ) + 1 );
nIndex := Length( FCookie );
if FCookie[nIndex] <> ';' then
FCookie := FCookie + '; ';
end;
end;
end;
end
else
begin
//判断本地网络连接是否正常
if gethostbyname( PChar( FHttpData.Host ) ) <> nil then
begin
FHttpData.IsCon := False;
RecvThread.Free;
goto start;
end;
HtmlSource := '';
end;
RecvThread.Free;
end
else
begin
//判断本地网络连接是否正常
if gethostbyname( PChar( FHttpData.Host ) ) <> nil then
begin
FHttpData.IsCon := False;
goto start;
end;
HtmlSource := '';
end;
CookieList.Free;
Result := HtmlSource;
end;
//连接服务器
function TWinHttp.Conn( var HttpData:THttpData ):Boolean;
var
IsOk:Boolean;
i, nCon:Integer;
begin
HttpData.IsCon := False;
IsOk := False;
HttpData.sockfd := 0;
HttpData.hostEnt := nil;
HttpData.SocketHost := '';
with HttpData do
begin
if WSAStartup(MakeWord(2,2), WSAData) = 0 then
begin
ParseURL(FUrl, Host, Path);
//建立套接字
sockfd := socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
if sockfd <> INVALID_SOCKET then
begin
if Host <> '' then
begin
if Host[1] in ['0'..'9'] then
begin
if inet_addr(PChar(Host)) <> INADDR_NONE then
SocketHost := Host;
end
else
begin
hostEnt := gethostbyname(pchar(Host));
if hostEnt <> nil then
with hostEnt^ do
SocketHost := format('%d.%d.%d.%d',
[ord(h_addr^[0]), ord(h_addr^[1]),
ord(h_addr^[2]), ord(h_addr^[3])]);
end;
addr.sin_family := AF_INET;
addr.sin_port := htons(80);
addr.sin_addr.S_addr := inet_addr(PChar(SocketHost));
for i := 0 to 10 do
begin
//连接
nCon := connect(sockfd, addr, SizeOf(addr) );
if nCon <> 0 then
begin
Sleep(10);
Continue;
end
else
Break;
end;
if nCon = 0 then
begin
IsOk := True;
HttpData.IsCon := True;
end;
end;
end;
end;
end;
if IsOk then
FHttpData := HttpData;
Result := IsOk;
end;
//分隔URL
procedure TWinHttp.ParseURL( const Url:string; var Host, Path:string);
var
nIndex:Integer;
S,tmpUrl:string;
begin
tmpUrl := Url;
S := LowerCase(Url);
if ( Pos('https://', S) <> 0 ) then
begin
//删除http://
Delete(tmpUrl, 1, Length('https://'));
end
else if( Pos( 'http://', S ) <> 0 ) then
begin
//删除http://
Delete(tmpUrl, 1, Length('http://'));
end;
nIndex := Pos('/', tmpUrl);
if nIndex = 0 then
begin
Host := tmpUrl;
Path := '/';
end
else
begin
Host := Copy(tmpUrl, 1, nIndex - 1);
Path := Copy(tmpUrl, nIndex, Length(Url));
end;
end;
function TWinHttp.HttpHead:string;
begin
Result := FHttpHead;
end;
function TWinHttp.StateCode:Integer;
begin
Result := FStateCode;
end;
function TWinHttp.Location:string;
begin
Result := FLocation;
end;
initialization
finalization
end.
Copyright © 2014 DelphiW.com 开发 源码 文档 技巧 All Rights Reserved
晋ICP备14006235号-8 晋公网安备 14108102000087号
执行时间: 0.045353889465332 seconds