Delphi中用socket获取网页源文件【转】

从扬帆Blog看到的一段代码，整理了一下，留着备用。

原文：http://www.wesoho.com/article/Delphi/2910.htm

unit UDownloadHTML;

interface

uses SysUtils, Windows, Forms, WinSock, WinInet;

function DownloadWithInet(const AUrl: string): string;
function DownloadWithSocket(const AUrl: string): string;

implementation

function DownloadWithInet(const AUrl: string): string;

  procedure Add(Buf: PChar; Count: Integer);
  var
    Len: Integer;
  begin
    Len := Length(Result);
    SetLength(Result, Len + Count);
    Move(Buf^, Result[Len + 1], Count);
  end;

  function PrepareURL: string;
  begin
    Result := UpperCase(Copy(AUrl, 1, 7));
    if Result <> 'HTTP://' then
    Result := 'http://' + AUrl
    else
    Result := AUrl;
  end;

var
  BytesRead: DWORD;
  Session, Connection: HINTERNET;
  Buffer: array[1..1024] of Char;
begin
  Result := '';
  if AUrl = '' then Exit;
    Session := InternetOpen(nil, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
  if not Assigned(Session) then
    raise Exception.Create(SysErrorMessage(GetLastError));
  try
    Connection := InternetOpenUrl(Session, PChar(PrepareURL), nil, 0,
    INTERNET_FLAG_RAW_DATA, {INTERNET_FLAG_RELOAD, }0);
    if not Assigned(Connection) then
      raise Exception.Create(SysErrorMessage(GetLastError));
    try
      repeat
        FillChar(Buffer, SizeOf(Buffer), 0);
        InternetReadFile(Connection, @Buffer, SizeOf(Buffer), BytesRead);
        if BytesRead > 0 then
          Add(@Buffer, BytesRead);
        Application.ProcessMessages;
      until BytesRead = 0;
    finally
      InternetCloseHandle(Connection);
    end;
  finally
    InternetCloseHandle(Session);
  end;
end;

function DownloadWithSocket(const AUrl: string): string;
const
  CRLF = #13#10;
  SFileContentLen = 'content-length: ';
  SUserAgent =
  'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; .NET CLR 1.0.3705)';
  SRequestFileHead =
  'HEAD %s HTTP/1.1' + CRLF +
  'Pragma: no-cache' + CRLF +
  'Cache-Control: no-cache' + CRLF +
  SUserAgent + CRLF +
  'Host: %s' + CRLF + CRLF;
  SRequestDownFile =
  'GET %s HTTP/1.1' + CRLF +
  'Accept: */*' + CRLF +
  SUserAgent + CRLF +
  'RANGE: bytes=0-' + CRLF +
  'Host: %s' + CRLF + CRLF;

  procedure ExtractHostAndFileName(const AURL: string;
    var AHost, AFileName: string; APort: PString = nil);
  const
    HttpHead = 'http://';
    HttpHeadLen = Length(HttpHead);
  var
    I: Integer;
  begin
    AHost := AURL;
    I := Pos(HttpHead, AURL);
    if I <> 0 then
    AHost := Copy(AHost, I + HttpHeadLen, MaxInt);
    I := AnsiPos('/', AHost);
    while I <> 0 do
    begin
    AHost := Copy(AHost, 1, I - 1);
    I := AnsiPos('/', AHost);
    end;
    I := Pos(AHost, AURL) + Length(AHost);
    AFileName := Copy(AURL, i, MaxInt);
    I := Pos(':', AHost);
    if I <> 0 then
    begin
    if Assigned(APort) then
    APort^ := Copy(AHost, I + 1, MaxInt);
    AHost := Copy(AHost, 1, I - 1);
    end;
  end;

  var
    Socket: TSocket;
  function WaitForSocket(Timeout: Integer): Boolean;
  var
  FDSet: TFDSet;
  TimeVal: TTimeVal;
  begin
    TimeVal.tv_sec := Timeout;
    TimeVal.tv_usec := 0;
    FD_ZERO(FDSet);
    FD_SET(Socket, FDSet);
    Result := WinSock.select(0, @FDSet, nil, nil, @TimeVal) > 0;
  end;

  procedure Add(var S: string; Buf: PChar; Count: Integer);
  var
    Len: Integer;
  begin
    Len := Length(S);
    SetLength(S, Len + Count);
    Move(Buf^, S[Len + 1], Count);
  end;

  function ReceiveLine: string;
  var
    C: Char;
    RetLen: Integer;
  begin
    Result := '';
    while Socket <> INVALID_SOCKET do
    begin
    RetLen := recv(Socket, C, 1, 0);
    if (RetLen <= 0) or (RetLen = SOCKET_ERROR) then
    break;
    Add(Result, @C, 1);
    if Pos(CRLF, Result) > 0 then break;
    end;
  end;

  function SendCommand(const Command: string): string;
  var
    P: PChar;
    Data: string;
  begin
    Result := '';
    P := PChar(Command);
    send(Socket, P^, Length(Command), 0);
    while WaitForSocket(5) do
    begin
      Data := ReceiveLine;
      if (Data = '') or (Data = CRLF) then
      break else
      Add(Result, PChar(Data), Length(Data));
    end;
  end;

  procedure InitSocket(const AHost: string);
  var
    Addr: TSockAddrIn;
    Data: TWSAData;
    HostEnt: PHostEnt;
    Timeout: Integer;
  begin
    Winsock.WSAStartup($0101, Data);
    Socket := WinSock.socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
    if Socket = INVALID_SOCKET then
      raise Exception.Create(SysErrorMessage(GetLastError));
    Timeout := 1000;
    WinSock.setsockopt(Socket, SOL_SOCKET, SO_RCVTIMEO, @Timeout, SizeOf(TimeOut));
    HostEnt := gethostbyname(PChar(AHost));
    FillChar(Addr.sin_addr, SizeOf(Addr.sin_addr), 0);
    Addr.sin_family := PF_INET;
    if HostEnt <> nil then
      Move(HostEnt^.h_addr^[0], Addr.sin_addr.S_addr, HostEnt^.h_length)
    else
    raise Exception.CreateFmt('主机没找到: %s', [AHost]);
    Addr.sin_port := htons(80);
    if connect(Socket, Addr, SizeOf(Addr)) <> 0 then
      raise Exception.Create(SysErrorMessage(GetLastError));
  end;
  procedure UnInitSocket;
  begin
    if Socket <> INVALID_SOCKET then
      closesocket(Socket);
    WSACleanup;
  end;

var
  Data, FileName, Host: string;
begin
  Socket := INVALID_SOCKET;
  ExtractHostAndFileName(AUrl, Host, FileName);
  try
    InitSocket(Host);
    if FileName = '' then
    FileName := '/';
    Data := SendCommand(Format(SRequestFileHead, [FileName, Host]));
    Data := SendCommand(Format(SRequestDownFile, [FileName, Host]));
    while True do
    begin
      Data := ReceiveLine;
      if Data = '' then break;
      Add(Result, PChar(Data), Length(Data));
      Application.ProcessMessages;
    end;
  finally
    UnInitSocket;
  end;
end;

end.