TIdHTTPのGetでエラー (ID:19551)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

久しぶりの投稿です。本題とは外れますが、HTTPのクライアントざっと作ってみました。一応や問題を避けられるデコード関数もつけました。
どうしてもIndyがいいというなら虫してください。

unit HTTPClient;

interface
uses
  Classes, Sockets, SysUtils;
type
  TMyHTTP = class(TCustomIpClient)
    property Active;
    property BlockMode;
    property Connected;
    property RemoteHost;
    property RemotePort;
    property OnCreateHandle;
    property OnDestroyHandle;
    property OnConnect;
    property OnDisconnect;
    property OnReceive;
    property OnSend;
    property OnError;
  protected
    FHeader: string;
    function SetHeaderAnswerBody(re: string): string;
  public
    property  Header: string read FHeader;
    constructor Create(AOwner: TComponent); override;
    //function  Head(url: string): string;
    function  Get(url: string): string;
    //function  Post(url: string; dat: string): string;
  end;

procedure        AnalyzeURL(const url: string; var domain: string; var path: string; var param: string; var port: string);
var
  g_LastURL : string = '';
  g_LastDomain: string = '';
  g_LastPath: string = '';
  g_LastParam: string = '';
  g_LastPort: string = '';

function euc2sjis(euc: string): string;

implementation
function euc2sjis(euc: string): string;
var
  i, len: integer;
  w: word;
  h, eucHi, k, l, m, eucLow, eucw: word;

begin
  result := '';
  len := Length(euc);
  if len = 0 then exit;
  i := 1;
  while i <= len do begin
    h := byte(euc[i]);
    case h of
      $A1..$FE: begin
//--------------------
        l := byte(euc[i + 1]);
        eucw := h shl 8 + l;
        case h of
          $F9..$FF: begin
            case eucw of
              $F9A0..$F9C3: w := eucw + $BB;
              $F9C4..$F9FF: w := eucw + $BC;
              $FAA0..$FAE2: w := eucw + $1A;
              $FAE3..$FAFE: w := eucw + $5D;
              $FAFF..$FBA0: w := eucw + $4E;
              $FBA1..$FBFF: w := eucw - $45;
              $FCA1..$FCE2: w := eucw - $E6;
              $FCF1..$FCFA: w := eucw - $2B1;
              $FCE3..$FCEE: w := eucw - $A3;
              $FCFC..$FCFF: w := eucw - $2A7;
              else begin
                w := $8145;
              end;
            end;
            result := result + char(w shr 8) + char(w and $FF);
          end;
          else begin
            case h of
              0..$DE: begin
                k := h - $A1;//3F
                eucHi := $81 + k shr 1;
              end;
              else begin
                k := h - $DF;
                eucHi := $E0 + k shr 1;
              end;
            end;
            l := (eucw and $FF) - $A0;
            m := l shr 4;
            case k mod 2 of
              0: begin
                case m of
                  0: eucLow := $3F + l and $F;
                  1: eucLow := $4F + l and $F;
                  2: eucLow := $5F + l and $F;
                  3: eucLow := $6F + l and $F;
                  4: eucLow := $80 + l and $F;
                  5: eucLow := $90 + l and $F;
                end;
              end;
              1: begin
                case m of
                  0: eucLow := $9E + l and $F;
                  1: eucLow := $AE + l and $F;
                  2: eucLow := $BE + l and $F;
                  3: eucLow := $CE + l and $F;
                  4: eucLow := $DE + l and $F;
                  5: eucLow := $EE + l and $F;
                end;
              end;
            end;
            result := result + char(eucHi) + char(eucLow);
          end;
        end;
//--------------------
        inc(i, 2);
      end;
      else begin
        case h of
          $8E: begin
            if (i + 1) <= len then begin
              result := result + euc[i + 1];
            end;
            inc(i, 2);
          end;
          else begin
            result := result + char(h);
            inc(i);
          end;
        end;

end;
    end;
  end;
end;

function  TMyHTTP.SetHeaderAnswerBody(re: string): string;
var
  idx: integer;
begin
  idx := pos(#$D#$A + #$D#$A, re);
  FHeader := Copy(re, 1, idx - 1);
  result := Copy(re, idx + 2, Length(re));
end;

procedure        AnalyzeURL(const url: string; var domain: string; var path: string; var param: string; var port: string);
var
        aurl: string;
  idx, idx2: integer;
  s, t: string;
begin
  idx := pos('://', url);
  case idx of
    2..7: begin
      s := trim(Copy(url, 1, idx - 1));
      if s = 'http' then begin
        port := '80';
      end
      else begin
        if s = 'https' then begin
          port := '443';
        end;
      end;
    end;
  end;

idx := pos(s+'://', url);
        case idx of
      0: begin
            aurl := trim(url);
    end;
         1: begin
            aurl := trim(Copy(url, idx + Length(s) + 3, Length(url)))
    end;
    else begin
      aurl := trim(url);
    end;
  end;

idx := pos('?', aurl);
  case idx of
           0: begin
            param := '';
    end;
    else begin
            param := Copy(aurl, idx + 1, Length(aurl));
      aurl := Copy(aurl, 1, idx - 1);
    end;
  end;

idx := pos('/', aurl);
  case idx of
      0: begin
            domain := aurl;
      path := '/';
    end;
    else begin
       domain := Copy(aurl, 1, idx - 1);
      path := Copy(aurl, idx, Length(aurl));
    end;
  end;
  idx := pos(':', domain);
  case idx of
    0:;
    else begin
      domain := Copy(domain, 1, idx - 1);
    end;
  end;
  s := Copy(domain, 1, 1);

if (s = '') or (s = '.') then begin
    s := StringReplace(g_LastPath, '/', '\', [rfReplaceAll]);
    t := ExtractFileName(s);
    t := Copy(s, 1, Length(s) - Length(t));
    path := StringReplace(t, '\', '/', [rfReplaceAll]) + domain + path;
    domain := g_LastDomain;
  end;

g_LastURL := url;
  g_LastDomain := domain;
  g_LastPath := path;
  g_LastParam := param;
  g_LastPort := port;
end;

constructor TMyHTTP.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  RemotePort := '80';
  BlockMode := bmBlocking;//bmNonBlocking;
end;
function  TMyHTTP.Get(url: string): string;
var
  domain, path, param: string;
  rq, re: string;
  buf: array[0..1023] of char;
  len: integer;
  port: string;
begin

AnalyzeURL(url, domain, path, param, port);
  if pos(domain + ':8080', url) > 0 then port := '8080';
  RemoteHost := domain;
  RemotePort := port;
  if param <> '' then begin
    rq := 'GET ' + path + '?' + param + ' HTTP/1.0' + #$D#$A + #$D#$A;
  end
  else begin
    rq := 'GET ' + path + ' HTTP/1.0' + #$D#$A + #$D#$A;
  end;
  re := '';
  Active := true;
  try
    SendBuf(rq[1], Length(rq));
    len := ReceiveBuf(buf, 1024);
    while len > 0 do begin
      re := re + Copy(buf, 1, len);
      len := ReceiveBuf(buf, 1024);
    end;

finally
     Active := false;
  end;
  re := euc2sjis(re);
  result := SetHeaderAnswerBody(re);
end;

end.

←解決時は質問者本人がここをチェックしてください。

戻る