Httpsock.pas

Материал из DRKB



unit HttpSock;

{
  CrtSocket for Delphi 32
  Copyright (C) 1999-2001  Paul Toth <tothpaul@free.fr>
  http://tothpaul.free.fr

This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

}

interface

function URLEncode(s: string): string;
function URLDecode(s: string): string;

function HttpGet(server, url: string; var header: string): string;
function HttpPost(server, url, Data: string; var header: string): string;

implementation

uses
  crtsock, SysUtils;

function URLEncode(s: string): string;
  // http://www.cis.ohio-state.edu/cgi-bin/rfc/rfc1738.html
var
  i: Integer;
  c: Char;
begin
  Result := '';
  for i := 1 to Length(s) do
  begin
    c := s[i];
    case c of
      // non-ASCII
      #$00..#$1F, #$7F, #$80..#$FF,
      // unsafe
      {' ',}'<', '>', '"', '#', '%', '}', '|', '\', '^', '~', '[', ']', '`',
      // reserved
      ';', '/', '?', ':', '@', '=', '&',
      '$', '-', '_', '.', '+', '!', '*', '''', '(', ')':
        Result := Result + '%' + IntToHex(Ord(c), 2);
      ' ': Result := Result + '+';
      else
        Result := Result + c;
    end;
  end;
end;

function URLDecode(s: string): string;
var
  i: Integer;
begin
  Result := '';
  i := 1;
  while i <= Length(s) do
  begin
    case s[i] of
      '+': Result := Result + ' ';
      '%': begin
        s[i] := '$';
        Result := Result + Chr(StrToInt(Copy(s, i, 3)));
        Inc(i, 2);
      end;
      else
        Result := Result + s[i];
    end;
    Inc(i);
  end;
end;


function HttpGet(server, url: string; var header: string): string;
var
  handle: Integer;
  sin, sout: textfile;
  s: string;
begin
  handle := CallServer(server, 80);
  if handle <= 0 then
  begin
    Result := '';
    exit;
  end;
  AssignCrtSock(handle, sin, sout);
  WriteLn(sout, 'GET ', url, ' HTTP/1.0');
  WriteLn(sout, 'Accept: */*');
  WriteLn(sout, 'Accept-Language: fr');
  WriteLn(sout, 'User-Agent: Mozilla/4.0 (compatible; MSIE 5.5; Windows 98; FREE)');
  //  writeln(sout,'User-Agent: MySoft/1.0 (Delphi)');
  WriteLn(sout, 'Connection: Keep-Alive');
  if header <> '' then WriteLn(sout, header);
  WriteLn(sout);

  header := '';
  Result := '';

  ReadLn(sin, s);
  while s <> '' do
  begin
    header := header + s;
    ReadLn(sin, s);
  end;

  while not EOF(sin) do
  begin
    ReadLn(sin, s);
    Result := Result + s;
  end;

  Disconnect(handle);
end;

function HttpPost(server, url, Data: string; var header: string): string;
var
  handle: Integer;
  sin, sout: textfile;
  s: string;
begin
  handle := CallServer(server, 80);
  if handle <= 0 then
  begin
    Result := '';
    exit;
  end;
  AssignCrtSock(handle, sin, sout);
  WriteLn(sout, 'POST ', url, ' HTTP/1.0');
  WriteLn(sout, 'Accept: */*');
  WriteLn(sout, 'Accept-Language: fr');
  WriteLn(sout, 'User-Agent: Mozilla/4.0 (compatible; MSIE 5.5; Windows 98; FREE)');
  //  writeln(sout,'User-Agent: MySoft/1.0 (Delphi)');
  WriteLn(sout, 'Content-length: ', Length(Data));
  WriteLn(sout, 'Connection: Keep-Alive');
  if header <> '' then WriteLn(sout, header);
  WriteLn(sout);
  Write(sout, Data);

  header := '';
  Result := '';

  ReadLn(sin, s);
  while s <> '' do
  begin
    header := header + s;
    ReadLn(sin, s);
  end;

  while not EOF(sin) do
  begin
    ReadLn(sin, s);
    Result := Result + s;
  end;

  Disconnect(handle);
end;

end.