winsocketを使用してWebサーバーからPOSTリクエストを取得するために、自分のユニットを作成しました。
これが私のユニットです：
unit uGetPost;
interface
uses
Winsock,
SysUtils,
Windows;
function GetPost(CompleteURL, PostData : String; var Results : String ; Port: Integer = 80) : Integer;
implementation
procedure RemoveCRLFFromEndAndBeginning (var s : String);
var
i : Integer;
begin
i := Length(s);
while (s[i] = #10) or (s[i] = #13) do begin
SetLength (s, i - 1);
dec (i);
end;
i := 1;
while (s[i] = #10) or (s[i] = #13) do begin
s := Copy (s, 2, Length(s));
inc (i);
end;
end;
function GetIpFromDns(HostName: string): string;
type
tAddr = array[0..100] of PInAddr;
pAddr = ^tAddr;
var
I: Integer;
WSA: TWSAData;
PHE: PHostEnt;
P: pAddr;
begin
Result := HostName;
WSAStartUp($101, WSA);
try
PHE := GetHostByName(pChar(HostName));
if (PHE <> nil) then
begin
P := pAddr(PHE^.h_addr_list);
I := 0;
while (P^[i] <> nil) do
begin
Result := (inet_nToa(P^[i]^));
Inc(I);
end;
end;
except
end;
WSACleanUp;
end;
function Parsing(Char, Str: string; Count: Integer): string;
var
i : Integer;
strResult : string;
begin
if Str[Length(Str)] <> Char then
Str := Str + Char;
for i := 1 to Count do
begin
strResult := Copy(Str, 0, Pos(Char, Str) - 1);
Str := Copy(Str, Pos(Char, Str) + 1, Length(Str));
end;
Result := strResult;
end;
function GetPost(CompleteURL, PostData : String; var Results : String ; Port: Integer = 80) : Integer;
// 1 = Complete Success
// 2 = No Content (Length found) or wrong GET/POST
// 3 = Host found but no php file
// 4 = Host not found (Total FAIL!);
var
WSA: TWSAData;
Sock: TSocket;
Addr: TSockAddrIn;
SendBuffer: String;
ReceiveBuffer: array[0..4096] of Char;
ReceivedBytes: Integer;
DNS, RemoteFilePath, FileName: string;
i: integer;
SentBytes: Integer;
ContentLength : Integer;
begin
result := 4;
DNS := Copy(CompleteURL, Pos('http://', CompleteURL) + 7, Length(CompleteURL));
RemoteFilePath := Copy(DNS, Pos('/', DNS), Length(DNS));
DNS := Copy(DNS, 1, Pos('/', DNS) - 1);
i := Length(RemoteFilePath);
while (RemoteFilePath[i] <> '/') do
begin
FileName := RemoteFilePath[i] + FileName;
Dec(i);
end;
WSAStartup($101, WSA);
Sock := Socket(AF_INET, SOCK_STREAM, 0);
Addr.sin_family := AF_INET;
if (Port < 1) or (Port > 65535) then Port := 80;
Addr.sin_port := htons(Port);
Addr.sin_addr.S_addr := inet_addr(PChar(GetIPfromDNS(PChar(DNS))));
if Connect(Sock, Addr, sizeof(Addr)) = 0 then begin
result := 3;
SendBuffer := 'POST ' + RemoteFilePath + ' HTTP/1.1' + #13#10 +
'Host: ' + DNS + #13#10 +
'User-Agent: Mozilla/5.0 (Windows NT 5.1; rv:16.0) Gecko/20100101 Firefox/16.0' + #13#10 +
'Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8' + #13#10 +
'Accept-Language: en-US,en;q=0.5' + #13#10 +
'Accept-Encoding: gzip, deflate' + #13#10 +
'Connection: close' + #13#10 +
'Cache-Control: max-age=0' + #13#10 +
'Content-Type: application/x-www-form-urlencoded' + #13#10 +
'Content-Length: ' + inttostr(Length(PostData)) + #13#10#13#10 +
PostData;
repeat
SentBytes := Send(Sock, SendBuffer[1 + SentBytes], Length(SendBuffer) - SentBytes, 0);
until SentBytes >= Length(SendBuffer);
repeat
ZeroMemory(@ReceiveBuffer, Sizeof(ReceiveBuffer));
ReceivedBytes := Recv(Sock, ReceiveBuffer, Sizeof(ReceiveBuffer), 0);
if ReceivedBytes > 0 then begin
Results := Results + ReceiveBuffer;
end;
until (ReceivedBytes <= 0);
CloseSocket(Sock);
end;
WSACleanup();
if Copy (Results, 10, 6) = '200 OK' then begin
result := 2;
if Pos ('Content-Length: ', Results) <> 0 then begin
i := 1;
while Parsing(#13, Results, i) <> '' do begin
if Pos ('Content-Length: ' , Parsing(#13, Results, i)) <> 0 then begin
ContentLength := strtoint (Copy(Parsing(#13, Results, i), 18, Length (Results)));
results := Copy (results,Length(results) - ContentLength + 1, ContentLength);
break;
end;
inc (i);
end;
if ContentLength <> 0 then begin
result := 1;
RemoveCRLFFromEndandBeginning (results);
end else begin
results := '';
end;
end;
end;
end;
end.
次のように、VCL アプリケーションで関数 GetPost を実行します。
var
Res : String;
begin
GetPost ('http://guest1320958.studio2.coderun.com/PHPTest/', 'GET=VERSION', Res);
ShowMessage (Res);
end;
結果は次のとおりです。
HTTP/1.1 400 Bad Request Content-Type: text/html Date: Fri, 26 Oct 2012 18:56:03 GMT Connection: close Content-Length: 35
不正なリクエスト (無効な動詞)
次のようなコンソール アプリケーションで SAME 関数を実行すると:
program Project2;
{$APPTYPE CONSOLE}
uses
uGetPost;
var
Res : String;
begin
GetPost ('http://guest1320958.studio2.coderun.com/PHPTest/', 'GET=VERSION', Res);
writeln (Res);
readln;
end.
それはうまく動作します。
私のPHPコードはこれです：
<?php
if (isset($_POST["GET"])) {
$funcName = $_POST["GET"];
switch($funcName) {
case "VERSION":
echo "1.0";
break;
case "SOMETHINGELSE":
echo "...";
break;
case "ANDSOSON":
echo "...";
}
}
?>
www.coderun.comを使用してPHPをテストしています。
VLCで機能しないのはなぜですか? ところで、次のように VCL のスレッドで関数 GetPost を実行すると、次のようになります。
function MyThread ( p : pointer ) : Integer;stdcall;
var
Res : String;
begin
GetPost ('http://guest1320958.studio2.coderun.com/PHPTest/', 'GET=VERSION', Res);
MessageBoxA (0, pchar(Res), '', 0);
end;
procedure StartGetPost;
var
Dummy : DWORD;
begin
CreateThread(NIL,0, @MyThread, NIL,0, Dummy);
end;
...それは突然機能します...
何故ですか？誰か助けてくれませんか？ありがとうございました。
編集: Wireshark の結果は次のとおりです: http://dl.dropbox.com/u/349314/transfer.pcapng
編集:実際の送信ヘッダーに何か問題があるようです:/