unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Winapi.WinInet, Vcl.StdCtrls, System.Math;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Button2: TButton;
Button3: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
Type
THTTPHead = (nHead, nGet, nPost);
PWebHead = ^TWebHead;
TWebHead = Record
uCode :Word;
szSer :Array [0..64] Of AnsiChar;
End;
PDomain = ^TDomain;
TDomain = Record
szUrl :Array [0..255] Of AnsiChar;
szHost :Array [0..255] Of AnsiChar;
szFile :Array [0..255] Of AnsiChar;
bSSL :Boolean;
nPort :Word;
End;
Const
HTTPHeadStr :Array [0..2] of PAnsiChar = ('HEAD', 'GET', 'POST');
UserAgent:PAnsiChar = 'Mozilla/5.0 (Windows NT 6.1; WOW64; Trident/7.0; rv:11.0) like Gecko';
Header :PAnsiChar = 'Content-Type: application/x-www-form-urlencoded'#13#10#$0;
Function StrStrIA(lpFirst, lpSrch: PAnsiChar): PAnsiChar; stdcall; external 'shlwapi.dll' name 'StrStrIA';
Function StrNCatA(lpFirst, lpSrch:PAnsiChar; cchMax:Integer): PAnsiChar; stdcall; external 'shlwapi.dll' name 'StrNCatA';
Function StrToIntA(lpSrch: PAnsiChar): Integer; stdcall; external 'shlwapi.dll' name 'StrToIntA';
Procedure RtlZeroMemory(Destination:Pointer; Length:DWORD); stdcall; external kernel32 name 'RtlZeroMemory';
Procedure RtlMoveMemory(Destination:Pointer; Const Source:Pointer; Length:DWORD); stdcall; external kernel32 name 'RtlMoveMemory';
Function AllocMemory(dwSize:DWORD):Pointer;
begin
Result := VirtualAlloc(Nil, dwSize, MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE);
end;
Function GetMemory(dwSize:DWORD):Pointer;
begin
Result := AllocMemory(dwSize);
end;
Procedure FreeMemory(lpMemory :Pointer);
begin
VirtualFree(lpMemory, 0, MEM_RELEASE);
end;
Function CheckMemory(pMemory:Pointer; dwSize:DWORD):Boolean;
begin
Result := (Not IsBadReadPtr(pMemory, dwSize)) And (Not IsBadWritePtr(pMemory, dwSize));
end;
Function StrPosA(lpSrch, lpFirst:PAnsiChar):Integer;
Var
Cmp :PAnsiChar;
begin
Result := 0;
if (lpSrch = Nil) Or (lpFirst = Nil) then Exit;
if DWORD(lpSrch) = DWORD(lpFirst) then
begin
Result := 1;
Exit;
end;
Cmp := StrStrIA(lpFirst, lpSrch);
if Cmp <> Nil then
begin
Result := DWORD(Cmp) - DWORD(lpFirst) + 1;
end;
end;
Procedure DeleteA(lpszStr:PAnsiChar; Index, Count:Integer);
Var
uSize :Integer;
begin
uSize := lstrlenA(lpszStr);
if uSize = Count then
begin
lstrcpyA(@lpszStr[index - 1], @lpszStr[Index + Count -1]);
ZeroMemory(@lpszStr[index -1], Index + Count);
end else begin
lpszStr[Index - 1] := #0;
StrNCatA(lpszStr, @lpszStr[Index + Count - 1], uSize);
end;
end;
Function CopyA(lpszStr:PAnsiChar; Index, Count:Integer):PAnsiChar;
begin
Result := GetMemory(Count - Index + 1);
lstrcpynA(Result, @lpszStr[Index -1], Count);
end;
Procedure ParseURL(szUrl:PAnsiChar; Var Domain:TDomain);
Var
nSize :DWORD;
szSeek :PAnsiChar;
szCmp :PAnsiChar;
begin
ZeroMemory(@Domain, SizeOf(TDomain));
if StrStrIA(szUrl, 's://') <> Nil then Domain.bSSL := True;
nSize := StrPosA('://', szUrl);
if nSize > 0 then
begin
szSeek := @szUrl[nSize + 2];
lstrcpyA(@Domain.szUrl, szUrl);
end else
begin
szSeek := szUrl;
lstrcpyA(@Domain.szUrl, 'http://');
lstrcatA(@Domain.szUrl, szUrl);
end;
nSize := StrPosA(':', szSeek);
if nSize > 0 then
begin
lstrcpynA(@Domain.szHost, szSeek, nSize);
szSeek := @szSeek[nSize];
nSize := StrPosA('/', szSeek);
if nSize > 0 then
begin
lstrcpynA(@Domain.szFile, szSeek, nSize);
Domain.nPort := StrToIntA(Domain.szFile);
ZeroMemory(@Domain.szFile, 256);
szSeek := @szSeek[nSize - 1];
end;
end Else
begin
nSize := StrPosA('/', szSeek);
if nSize > 0 then lstrcpynA(@Domain.szHost, szSeek, nSize) Else lstrcpyA(@Domain.szHost, szSeek);
szCmp := StrStrIA(szUrl, 's://');
if szCmp <> Nil then
begin
nSize := DWORD(szCmp) - DWORD(szUrl);
if nSize > 0 then Domain.nPort := 443;
End Else Domain.nPort := 80;
end;
nSize := StrPosA('/', szSeek);
if nSize > 0 then lstrcpynA(@Domain.szFile, @szSeek[nSize], 255);
if lstrlenA(@Domain.szFile) = 0 then lstrcpyA(@Domain.szFile, '/');
end;
Function GetCode(szHead:PAnsiChar):Integer;
Var
szSeek :PAnsiChar;
uRet :Integer;
begin
Result := 0;
szSeek := szHead;
uRet := StrPosA(' ', szSeek);
if uRet > 0 then
begin
Inc(szSeek, uRet);
uRet := StrPosA(' ', szSeek);
if uRet > 0 then
begin
szSeek[uRet-1] := #$0;
Result := StrToIntA(szSeek);
szSeek[uRet-1] := ' ';
end;
end;
end;
Function GetWebSer(szHead:PAnsiChar):PAnsiChar;
Var
szSeek :PAnsiChar;
uRet :Integer;
begin
Result := Nil;
szSeek := szHead;
uRet := StrPosA('Server:', szSeek);
if uRet > 0 then
begin
Inc(szSeek, uRet + 7);
uRet := StrPosA(#13, szSeek)-1;
if uRet > 0 then
begin
szSeek[uRet] := #$0;
Result := GetMemory(lstrlenA(szSeek) + 6);
lstrcpyA(Result, szSeek);
szSeek[uRet] := #13;
end;
end;
end;
Function GetPowered(szHead:PAnsiChar):PAnsiChar;
Var
szSeek :PAnsiChar;
uRet :Integer;
begin
Result := Nil;
szSeek := szHead;
uRet := StrPosA('x-powered-by:', szSeek);
if uRet > 0 then
begin
Inc(szSeek, uRet + 13);
uRet := StrPosA(#13, szSeek)-1;
if uRet > 0 then
begin
szSeek[uRet] := #$0;
Result := GetMemory(lstrlenA(szSeek) + 6);
lstrcpyA(Result, szSeek);
szSeek[uRet] := #13;
end;
end;
end;
Function HexToInt(Const HexValue: String):Int64;
Var
Code :Integer;
begin
Val('$' + HexValue, Result, Code);
end;
Function HTTPExec(Head:THTTPHead; szURI:PAnsiChar; szCookies:PAnsiChar; pData:Pointer; dwLen:DWORD; Var StatuCode:DWORD):PAnsiChar;
const
BufMax = 1024 *32;
Var
Buffer :Array [0..8191] of AnsiChar;
hSession :HINTERNET;
hConnect :HINTERNET;
hRequest :HINTERNET;
Domain :TDomain;
pSeek :PAnsiChar;
dwMax :DWORD;
dwFlags :DWORD;
dwSize :DWORD;
dwRecv :DWORD;
dwStatus :DWORD;
dwHLen :DWORD;
begin
Result := Nil;
dwSize := 0;
dwRecv := 0;
ParseURL(szURI, Domain);
if Domain.bSSL then dwFlags := INTERNET_FLAG_SECURE Else dwFlags := 0;
if szCookies <> Nil then InternetSetCookieA(szURI, Nil, szCookies);
hSession := InternetOpenA(UserAgent, INTERNET_OPEN_TYPE_PRECONFIG, Nil, Nil, 0);
if hSession <> Nil then
begin
hConnect := InternetConnectA(hSession, Domain.szHost, Domain.nPort, Nil, Nil, INTERNET_SERVICE_HTTP, 0, 0);
if hConnect <> Nil then
begin
hRequest := HttpOpenRequestA(hConnect, HTTPHeadStr[Integer(Head)], Domain.szFile, Nil, Nil, Nil, dwFlags Or INTERNET_FLAG_NO_CACHE_WRITE Or INTERNET_FLAG_RELOAD, 0);
if hRequest <> Nil then
begin
if Head = nPost then HttpAddRequestHeadersA(hRequest, Header, lstrlenA(Header), dwFlags Or HTTP_ADDREQ_FLAG_ADD Or HTTP_ADDREQ_FLAG_REPLACE);
if HttpSendRequestA(hRequest, Nil, 0, pData, dwLen) then
begin
StatuCode := 0;
HttpQueryInfoA(hRequest, HTTP_QUERY_STATUS_CODE Or HTTP_QUERY_FLAG_NUMBER, @StatuCode, dwStatus, dwRecv);
if Head = nHead then
begin
HttpQueryInfoA(hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Nil, dwSize, dwRecv);
if dwSize > 0 then
begin
Result := GetMemory(dwSize);
HttpQueryInfoA(hRequest, HTTP_QUERY_RAW_HEADERS_CRLF, Result, dwSize, dwRecv);
end;
end else
begin
dwSize := 0;
HttpQueryInfoA(hRequest, HTTP_QUERY_CONTENT_LENGTH Or HTTP_QUERY_FLAG_NUMBER, @dwSize, dwStatus, dwRecv);
if dwSize > 0 then
begin
Result := GetMemory(dwSize);
pSeek := Result;
Repeat
if InternetReadFile(hRequest, pSeek, dwSize, dwRecv) then
begin
Dec(dwSize, dwRecv);
Inc(PByte(pSeek), dwRecv);
end;
Until dwSize = 0;
end else
begin
dwMax := 1024 * 32;
dwHLen := 0;
Result := GetMemory(dwMax);
pSeek := Result;
RtlZeroMemory(Result, dwMax);
Repeat
RtlZeroMemory(@Buffer, SizeOf(Buffer));
if InternetReadFile(hRequest, @Buffer, SizeOf(Buffer), dwRecv) And (dwRecv > 0) then
begin
if (dwMax - dwHLen) < 1024 then
begin
pSeek := Result;
Result := GetMemory(dwMax + BufMax);
if dwHLen > 0 then RtlMoveMemory(Result, pSeek, dwHLen);
FreeMemory(pSeek);
pSeek := Result;
Inc(PByte(pSeek), dwHLen);
Inc(dwMax, BufMax);
end;
if dwRecv > 0 then
begin
RtlMoveMemory(pSeek, @Buffer, dwRecv);
Inc(PByte(pSeek), dwRecv);
Inc(dwHLen, dwRecv);
end;
end;
Sleep(30);
Until dwRecv = 0;
end;
end;
end;
InternetCloseHandle(hRequest);
end;
InternetCloseHandle(hConnect);
end;
InternetCloseHandle(hSession);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Buffer :PAnsiChar;
Status :DWORD;
begin
Buffer := HTTPExec(nHead, 'http://www.baidu.com/', Nil, Nil, 0, Status);
Memo1.Text := String(AnsiString(Buffer));
FreeMemory(Buffer);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Buffer :PAnsiChar;
Status :DWORD;
begin
Buffer := HTTPExec(nGet, 'http://www.baidu.com/', Nil, Nil, 0, Status);
Memo1.Text := String(AnsiString(Buffer));
FreeMemory(Buffer);
end;
procedure TForm1.Button3Click(Sender: TObject);
var
Buffer :PAnsiChar;
Status :DWORD;
pSend :PAnsiChar;
begin
pSend := GetMemory(MAX_PATH);
lstrcpyA(pSend, 's=delphi');
Buffer := HTTPExec(nPost, 'http://7xcode.com/', Nil, pSend, lstrlenA(pSend), Status);
Memo1.Text := String(AnsiString(Buffer));
FreeMemory(Buffer);
FreeMemory(pSend);
end;
end.
With thanks! Lots of content!