RSS订阅 | 匿名投稿
您的位置:网站首页 > 网络 > 正文

Delphi 多线程 获取网页的问题

作者:admin 来源: 日期:2016/1/19 23:30:47 人气: 标签:

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.


读完这篇文章后,您心情如何?
0
0
0
0
0
0
0
0
本文网址:
下一篇:没有资料