本文整理自网络，侵删。
unit uMain;
{
Created at 2012/01/19
微博 http://weibo.com/yinyongyou
博客 http://blog.csdn.net/MichaelJScofield
}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,WinSock, StdCtrls, IdBaseComponent, IdComponent, IdTCPConnection,
IdTCPClient, IdHTTP;
type
TfrmBaiduURLDecode = class(TForm)
lblSrcUrl: TLabel;
edtEncode: TEdit;
lblDstURL: TLabel;
edtDecode: TEdit;
btnFuck: TButton;
mmo1: TMemo;
procedure btnFuckClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
const
HttpLine = #13#10#13#10;
var
frmBaiduURLDecode: TfrmBaiduURLDecode;
WSAData: TWSAData;
implementation
{$R *.dfm}
{ 获取http返回头部 }
function GetHTTPResponseHeader(URL:String;var lpHeader:string):String;
const
BufLenth = 1024;
INTERNET_DEFAULT_HTTP_PORT = 80;
var
Buf:array[0..1023] of AnsiChar;
t: linger;
hSocket:integer;
hSend,hRet,hConnect:Integer;
iHost:Integer;
TimeOut:integer;
dwPort,dwRecv:DWORD;
HostIP:PHostEnt;
Addr:sockaddr_in;
BufSend,BufRev:PChar;
lpHttpHead,lpRecvStr:String;
szHostName,szHostPort,szFileName:String;
procedure ParseURL(URL: string; var HostName, FileName: string);
procedure ReplaceChar(c1, c2: Char; var St: string);
var
p: Integer;
begin
while True do
begin
p := Pos(c1, St);
if p = 0 then Break
else St[p] := c2;
end;
end;
var
i: Integer;
begin
if Pos(UpperCase('http://'), UpperCase(URL)) <> 0 then System.Delete(URL, 1, 7);
i := Pos('/', URL);
HostName := Copy(URL, 1, i);
FileName := Copy(URL, i, Length(URL) - i + 1);
if (Length(HostName) > 0) and (HostName[Length(HostName)] = '/') then
SetLength(HostName, Length(HostName) - 1);
end;
begin
Result:='';
ParseURL(URL, szHostName, szFileName);
iHost := Pos(':',szHostName);
if iHost <> 0 then
begin
szHostPort := Copy(szHostName, iHost+1, Length(szHostName)-iHost);
szHostName := Copy(szHostName, 1, iHost-1);
dwPort := StrToIntDef(szHostPort, INTERNET_DEFAULT_HTTP_PORT);
end
else dwPort := INTERNET_DEFAULT_HTTP_PORT;
hSocket:=Socket(AF_INET,SOCK_STREAM,IPPROTO_IP); //IPPROTO_IP IPPROTO_TCP
Try
if hSocket = INVALID_SOCKET then Exit;
HostIP:=GetHostByName(PChar(szHostName));
FillChar(Addr,SizeOf(Addr),#0);
Addr.sin_family:=AF_INET;
Addr.sin_addr.S_addr:=PDWORD(PDWORD(HostIP.h_addr)^)^;
Addr.sin_port:=htons(dwPort);
hConnect:=Connect(hSocket,Addr,SizeOf(Addr));
if WSAGetLastError() = 10060 then hConnect:=Connect(hSocket,Addr,SizeOf(Addr));
if hConnect = SOCKET_ERROR then
begin
CloseSocket(hSocket);
Exit;
end;
lpHttpHead := 'GET ' + szFileName + ' HTTP/1.1' + #13#10 +
'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*'+ #13#10+
'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)'+ #13#10 +
'Host: ' + szHostName + #13#10 +
'Referer: ' + URL + #13#10 +
'Accept-Language: zh-cn' + #13#10 +
'Cache-Control: no-cache' + #13#10 +
'Connection: close' + #13#10 +
'Cookie: ' + 'iscookies=0; ASPSESSIONIDACRQTBCS=OGALDEBDBBIGMLOHFKMOJFKO' + #13#10 +
#13#10#13#10;
GetMem(BufSend, Length(lpHttpHead) + 1);
Try
ZeroMemory(BufSend, Length(lpHttpHead) + 1);
StrPCopy(BufSend, lpHttpHead);
hSend:=Send(hSocket, BufSend^, Length(BufSend), 0);
if hSend = SOCKET_ERROR then
begin
CloseSocket(hSocket);
Exit;
end;
FillChar(Buf, SizeOf(Buf), #00);
while Recv(hSocket, Buf, SizeOf(Buf), 0) > 0 do
begin
lpRecvStr:='';
SetString(lpRecvStr, Buf, SizeOf(Buf));
Result := Result + lpRecvStr;
FillChar(Buf, SizeOf(Buf), #00);
if Pos(HttpLine,Result)>0 then break;
end;
lpHeader := Copy(Result,1,Pos(HttpLine,Result)-1);
finally
FreeMem(BufSend);
end;
t.l_onoff:=1;
t.l_linger:=0;
SetSockopt(hSocket, SOL_SOCKET, SO_LINGER, @t, SizeOf(t));
finally
CloseSocket(hSocket);
end;
end;
{ 获取真实地址 }
function GetRealURL(sUrl:string):string;
var
lpHeader: string;
begin
GetHTTPResponseHeader(sUrl,lpHeader);
frmBaiduURLDecode.mmo1.Text := lpHeader;
if (Pos('301',lpHeader)>0) or (Pos('302',lpHeader)>0) then
begin
Delete(lpHeader,1,Pos('Location:',lpHeader)+Length('Location:'));
Result := Copy(lpHeader,1,Pos(#13,lpHeader));
end;
end;
{ 提取真实地址 }
procedure TfrmBaiduURLDecode.btnFuckClick(Sender: TObject);
begin
edtDecode.Text := GetRealURL(edtEncode.Text);
end;
initialization
WSAStartUp($202, WSAData);
finalization
WSACleanup;
end.
相关阅读 >>
Delphi trestclient + trestrequest + trestresponse
更多相关阅读请进入《Delphi》频道 >>
