iehttp3.pas

Delphi7版飞信GreenFetion源码

    {$IFDEF tie_debug} LogStr('cp100'); {$endif}

    //if ie_thread <> nil then ie_thread.Terminate;
    //for some reason this clears the result_ms on line InternetCloseHandle(hI);
    //if flag_timeout_occured then  CleanUpConnectionMemory;

    //DONT FREE THREAD -> it has freeonterminate := true
    {if  flag_timeout_occured or flag_request_to_stop then
      //
    else
      ttimeout(ie_thread).free;}

    {try  ie_thread.Destroy or free; //does not work on timeout, it waits for thread to stop processing ie request
    except  end;}
    ie_thread := nil;

    /////////

    result_ms.Position := 0;
    CheckAndDecompress(tmemorystream(result_ms), url, unzip_method);

    result_ms.Position := 0;
    //sl_wide.text := my_unit1.Stream_To_TextW(result_ms);
    //sl_wide.text := ByteStringToWideString( Stream_To_ByteString(result_ms) );
    //result_ms.SaveToFile('c:\1.bin');
    //sl_wide.LoadFromStream( result_ms );
    //showmessagexx( sl_wide.text );

    //showmessage( response_headers.text );

    //result_ms.Position := 0;
    //result_sl.LoadFromStream(result_ms);
    s := Stream_To_ByteString(result_ms);
    result_ms.Position := 0;

//Content-Type: text/plain; charset=utf-8
//charset=utf-8
//charset=utf-16
//charset=us-ascii
//response_charset := GetResponseHeaderValue
    if pos('charset=utf-8', response_headers.text) > 0 then
      result_sl.text := _UTF8ToWideString( s )
    else
    if pos('charset=utf-16', response_headers.text) > 0 then
      result_sl.text := PWideChar( pointer(s) ) //pointer() avoids "Suspicious typecast" warning
      //[DCC Warning] IEHTTP3.pas(862): W1044 Suspicious typecast of AnsiString to PWideChar
      //warning is safe, since in utf-16 mode, "s" contains bytes that form a WideString      
    else
    //charset=us-ascii
      result_sl.text := s;
  finally
    setlength(multipartVars, 0);
    setlength(multipartBinaryVars, 0);
    working_status := 0; //finished

    if flag_timeout_occured or flag_request_to_stop then
      CleanUpConnectionMemory;
  end;
  working_status := 0; //finished
  {$IFDEF tie_debug} LogStr('cp200'); {$endif}

  //if (error in  [12030,12017]) then begin //operation canceled
    // do nothing
  //end else begin
  if error > 0 then
    raise exception.create('wininet error # '+inttostr(error) + ' : ' + GetErrorString(error));
  if error_msg <> '' then
    raise exception.create('tiehttp error: ' + error_msg);
end;

procedure TIEHTTP.SetGetStr(const Value: widestring);
begin
  if working_status <> 0 then begin
    raise exception.create('tiehttp: Cannot change parameters while processing request');
    exit;
  end;

  FGetStr := Value;
end;

procedure TIEHTTP.SetPostStr(const Value: widestring);
begin
  if working_status <> 0 then begin
    raise exception.create('tiehttp: Cannot change parameters while processing request');
    exit;
  end;

  FPostStr := Value;
end;


procedure TIEHTTP.SetMultipart(value: boolean);
begin
  if working_status <> 0 then begin
    raise exception.create('tiehttp: Cannot change parameters while processing request');
    exit;
  end;

  FMultipartPOST := value;

  if FMultipartPOST then begin
    //if fRequestMethod <> 'POST' then
    SetRequestMethod('POST');
    //content_type := 'multipart/form-data; boundary='+multipart_boundary;
  end else
    SetRequestMethod(FRequestMethod); //important if switching from multipart to non-multipart 
end;

procedure TIEHTTP.SetRequestMethod(const Value: widestring);
begin
  if working_status <> 0 then begin
    raise exception.create('Cannot change parameters while processing request');
    exit;
  end;

  if (wideuppercase(value) <> 'POST') and (wideuppercase(value) <> 'GET') then begin
    raise exception.create('Unsupported method. Allowed methods: GET, POST');
    exit;
  end;

  FRequestMethod := wideuppercase(Value);

  if RequestMethod='POST' then begin
    if multipartPost then
      content_type := 'multipart/form-data; boundary='+multipart_boundary
    else
      content_type := 'application/x-www-form-urlencoded';
  end else
  if RequestMethod='GET' then
    content_type:='';
end;

procedure TIEHTTP.ConvertToMultiPart;
var
  ar, ar2 : arStr;
  i : integer;
  s: ansistring;
begin
  s := _lpSzExtraInfo_Bytes;

  //bug fix
  //if length(s)=0 then
  //  raise exception.create('multipart error: empty post variables list');
  //exit;

  setlength(ar, 0);  //mch
  setlength(ar2, 0); //mch

  if (length(s)>0) then begin
    if s[1] = '&' then delete(s,1,1);
    ar := split(s, '&');
    for i := 0 to length(ar) - 1 do begin
      ar2 := split(ar[i], '=');
      if length(ar2) <> 2 then begin
        //raise exception.Create('could not convert ' + ar[i] + ' to multipart');
        error_msg := 'could not convert ' + ar[i] + ' to multipart';
        exit;
      end;
      AddMultipartVarW(ar2[0], ar2[1]);
    end;
  end;

  //AddMultipartVarW('X', '12345678901234567890123456789012345678901234567890');

  if (length(multipartVars) = 0) and (length(multipartBinaryVars) = 0) then begin
    error_msg := 'multipart error: no variables to post';
    exit;
    //no exceptions in thread
    //raise exception.create('multipart error: no variables to post');
  end;

  s := '';
  for i := 0 to length(multipartVars) - 1 do begin
    s := s + '--' +  multipart_boundary + #13#10
           + 'Content-Disposition: form-data; name="'+multipartVars[i].f+'"'  + #13#10
           + ''  + #13#10
           +  _WideStringToUTF8( multipartVars[i].v ) + #13#10;
  end;

  for i := 0 to length(multipartBinaryVars) - 1 do begin
    //filename is necessary for asp.net to initialize request.files
    // request.files[] index should be the field name, not the filename
    // HttpPostedFile h = Request.Files[field_name];
    s := s + '--' +  multipart_boundary + #13#10
           + 'Content-Disposition: form-data; name="'+multipartBinaryVars[i].f+'"; filename="'+multipartBinaryVars[i].f+'"'  + #13#10
    //       + 'Content-Disposition: attachment; filename="'+multipartBinaryVars[i].f+'"' + #13#10
    //       + 'Content-Type: image/gif' + #13#10
           + 'Content-Transfer-Encoding: binary'  + #13#10

           + ''  + #13#10
           + multipartBinaryVars[i].v + #13#10;
  end;

  s := s + '--' +  multipart_boundary + '--' + #13#10;

  _lpSzExtraInfo_Bytes := s;
end;

procedure TIEHTTP.SetURL(value: widestring);
begin
  furl := value;
  if furl = '' then begin //clear url
    FillChar(aURLC2, sizeOf(TURLComponents), 0);
    exit;
  end;

  if pos('://', widelowercase(furl)) = 0 then
    furl := 'http://'+furl;

  CrackURL;
end;

procedure TIEHTTP.AddMultipartVar(field: widestring; value: widestring);
begin
  AddMultipartVarW(field, value);
end;

procedure TIEHTTP.AddMultipartVarW(field: widestring; value: widestring);
var
  i : integer;
  p : integer;
begin
  if not multipartpost then begin
    //raise exception.create('tiehttp not in multipart mode');
    error_msg := 'tiehttp not in multipart mode';
    exit;
  end;


  //03apr04 - check if variable already exists and replace
  p := -1;
  for i := 0 to length(multipartVars)-1 do
    if multipartVars[i].f = field then begin
      p := i;
      break;
    end;

  if p = -1 then begin
    i := length(multipartVars)+1;
    setlength(multipartVars, i);
    p := i - 1;
  end;

  multipartVars[p].f := field;
  multipartVars[p].v := value;
end;

procedure TIEHTTP.AddMultipartVarA(field: widestring; value: ansistring);
var
  i : integer;
  p : integer;
begin
  if not multipartpost then begin
    //raise exception.create('tiehttp not in multipart mode');
    error_msg := 'tiehttp not in multipart mode';
    exit;
  end;

  //03apr04 - check if variable already exists and replace
  p := -1;
  for i := 0 to length(multipartBinaryVars)-1 do
    if multipartBinaryVars[i].f = field then begin
      p := i;
      break;
    end;

  if p = -1 then begin
    i := length(multipartBinaryVars)+1;
    setlength(multipartBinaryVars, i);
    p := i - 1;
  end;

  multipartBinaryVars[p].f := field;
  multipartBinaryVars[p].v := value;
end;

procedure TIEHTTP.AddMultipartVar_B64(field: widestring; value: bytestring);
begin
  value := B64Encode(value);
  //showmessage(s);

  value := breakuu( value );

  AddMultipartVarW(field, value);
end;

{procedure TIEHTTP.AddMultipartVar_Compressed(field: string; value: string);
var
  sl : tstringlist;
  temp_fn : string;
begin
  temp_fn := 'temp.txt';

  sl := tstringlist.create;
  sl.text:= value;
  sl.SaveToFile( temp_fn );
  ZLIB_Compress( temp_fn, true);
  iehttp1.AddMultipartFile( field, temp_fn );
  sl.free;
  deletefile(temp_fn);
end;}

procedure TIEHTTP.ReadCookiesAndHeaders(hFile:HInternet);
var
  response_lpOutBuffer : array[1..5000] of widechar;
  response_dwSize : cardinal;
  infoLevel : cardinal;
  i2 : cardinal;
begin
  //read cookies
  //or InternetGetCookie
  //infoLevel := HTTP_QUERY_CUSTOM or HTTP_QUERY_FLAG_REQUEST_HEADERS ;

  {   //HttpQueryInfo(hFile, infoLevel, @lpOutBuffer[1], dwSize, temp1);
   //lpOutBuffer, "HttpQueryInfo Output",MB_OK);
  //lpOutBuffer
  }

  infoLevel := HTTP_QUERY_SET_COOKIE;
  cookies.Clear;
  i2 := 0;
  repeat
    response_dwSize := sizeof(response_lpOutBuffer);
    if not HttpQueryInfoW(hFile, infoLevel, @response_lpOutBuffer[1], response_dwSize, i2) then
      break;
    cookies.Add(copy(response_lpOutBuffer, 1, response_dwSize));
    //fillchar(lpOutBuffer,sizeof(lpOutBuffer), 0);
  until false;

  //read all headers
  response_dwSize := sizeof(response_lpOutBuffer);
  fillchar(response_lpOutBuffer,sizeof(response_lpOutBuffer), 0);
  //HTTP_QUERY_RAW_HEADERS_CRLF
  infoLevel := HTTP_QUERY_RAW_HEADERS_CRLF;
  i2 := 0;
  if HttpQueryInfoW(hFile, infoLevel, @response_lpOutBuffer[1], response_dwSize, i2) then begin
    response_headers.Text := copy(response_lpOutBuffer, 1, response_dwSize);

//sample response headers
//HTTP/1.1 200 OK
//Server: ASP.NET Development Server/9.0.0.0
//Date: Thu, 24 Apr 2008 01:43:30 GMT
//X-AspNet-Version: 2.0.50727
//Cache-Control: private
//Content-Type: text/plain; charset=utf-8
//Content-Length: 57
//Connection: Close

  end;
end;

procedure TIEHTTP.AddMultipartFile(field, filename: widestring);
var
  ms : ttntmemorystream;
begin
  ms := ttntmemorystream.create;
  try
    ms.LoadFromFile(filename);

    AddMultipartStream(field, ms);
  finally
    ms.free;
  end;
end;

procedure TIEHTTP.AddMultipartStream(field: widestring; ms: TMemoryStream);
var
  s : bytestring;
begin
  s := Stream_To_ByteString(ms);

  //s := uuencode(s);
  s := B64Encode(s);

  s := breakuu(s);

  //AddMultipartVarW(field, s);
  AddMultipartVarW(field, s);
end;


procedure TIEHTTP.CalcTimeoutDatetime;
begin
  timeout_datetime := now + (timeout/SecsPerDay);
end;

procedure TIEHTTP.RequestCompleted;
begin
  //if mutex_handle <> 0 then
  //   CloseHandle(mutex_handle);
  //if event_handle <> 0 then
  //  CloseHandle(event_handle);