iehttp3.pas

Delphi版飞信源代码 用Delphi实现飞信功能

unit IEHTTP3;

{.$DEFINE TIE_USE_TNT}//enable this to use TTNTStringList instead of TWideStringList
                       //In Delphi 7, you will need to enable this to handle unicode responses
{.$define tie_debug}

// TIEHTTP
// WinInet HTTP/HTTPS component (supports GET/POST/multipart variables)
// Author: Kyriacos Michael ( to contact me please use the support url below )
//         parts of the code were obtained from usenet.
//         Base64 encoding/decoding by David Barton ([e-mail])
// Support URL: http://www.myfxboard.com/tiehttp/
// Released: 1 Apr 2003
// Source code released: 28 Mar 2004
//
// This component was released as Freeware with source,
// after many requests from people wanting to extent it
// or simply have a look at it.
// You are free to use the source code for any kind of use, even commercial.
// You are not allowed to sell parts or the whole of the code.
// Please send any modifications of the code, or any additions
// back to the author.
//
// to do list:
// ------------------------------
// investigate InternetSetStatusCallback
// investigate InternetReadFile - > InternetReadFileEx + W
// upload progress
//
//change history
//
// 1.3.0.40 17may2004: blocking / non-blocking mode
//                     cancel requests
//                     request timeout
// 1.3.0.42 17may2004: fixed bug that avoids you to reuse the component after a timeout or a cancel request
// 1.3.0.46 14nov2005: fixed onpacketread in non-blocking mode
//                     added onTimer event and timerIntervalSeconds property
// 1.3.0.44 03sep2004: fixed some bugs in the timeout/onpacketread mechanism
//                     basic proxy authentication support
//                     request_header property e.g. if you want to set "Referer:"
// 1.3.0.47 18feb2006: added gzip decompression (iis) (i had only deflate)
// 1.5.0.48 02jan2007: supports Custom-Content-Length for aspx files
// 1.5.0.60 24apr2008: using xxxW() windows wide functions e.g. InternetOpenW
// 1.5.0.61 24apr2008: full unicode, ditched ansi char operations, pchar operations e.g. strcopy, strcat
// 1.5.0.62 24apr2008: automatic conversion from charset=utf-8, charset=utf-16, charset=us-ascii
// 1.5.0.65 30apr2008: twidestringlist: added option for d7 users to use the default TStringList (ansi) or the TTNTStringList (->DEFINE TIE_USE_TNT)

{$IFDEF VER80}unsupported{$ENDIF}
{$IFDEF VER90}{$DEFINE D7_AND_LOWER}{$ENDIF} // D2
{$IFDEF VER93}{$DEFINE D7_AND_LOWER}{$ENDIF} // CPPB 1
{$IFDEF VER100}{$DEFINE D7_AND_LOWER}{$ENDIF} // D3
{$IFDEF VER110}{$DEFINE D7_AND_LOWER}{$ENDIF} // CPPB 3
{$IFDEF VER120}{$DEFINE D7_AND_LOWER}{$ENDIF} // D4
{$IFDEF VER130}{$DEFINE D7_AND_LOWER}{$ENDIF} // D5
{$IFDEF VER140}{$DEFINE D7_AND_LOWER}{$ENDIF} // D6
{$IFDEF VER150}{$DEFINE D7_AND_LOWER}{$ENDIF} // D7

interface

uses
  SysUtils, Classes, wininet, windows,
{$IFDEF D7_AND_LOWER}
    //no widestrings in D5, D6 or D7
{$ELSE}
    //D2005, D2006, D2007...
  WideStrings,
{$ENDIF}
{$IFDEF TIE_USE_TNT}
  tntclasses,
{$ELSE}
  tntlite, //allows MemoryStream and FileStream to load and save unicode files
{$ENDIF}
  WinInet_Ex, //must be after wininet; defines the wide version of TURLComponents
  forms; //forms unit is necessary for application.processmessages (non blocking mode)

{$IFDEF D7_AND_LOWER} //D5, D6 or D7
type
{$IFDEF TIE_USE_TNT}
  TWideStringList = TTNTStringList;
{$ELSE}
  TWideStringList = TStringList; //fake TWideStringList
{$ENDIF}
{$ENDIF}

const
  multipart_boundary = '-----------------------------7cf87224d2020a';

//type
//  TRequestMethods = (rm_GET, rm_POST, rm_POST_multipart);

type
  bytestring = ansistring;

type
  TIEHTTP = class(TComponent)
  private
    extraHeaders: widestring;
    hSession, hConnect, hFile: HInternet;
    buffer: TByteArray; //TByteArray = array[0..32767] of Byte;

    _lpSzExtraInfo_Bytes: ByteString;

    is_ie6_and_below: boolean;

    fTimeout: Integer; //value is in milliseconds
    fTimerIntervalSeconds: Integer;
    //ie_thread : TTimeout;

    flag_request_to_stop: boolean;
    flag_timeout_occured: boolean;

    flag_cleanup_completed: boolean;
    fBlockingMode: boolean;

    last_packet_read_dt: TDateTime;
    last_packet_processed_dt: TDateTime;
    last_timer_procesed_dt: TDateTime;

    timeout_datetime: tdatetime; //the calculated time to timeout

    //procedure ReadUrl(hSession: HInternet; const UrlAddr: string; Dest: TStream);
    procedure CrackURL; //step2 : uncompressed, no sl, will also perform crackurl
    //procedure ProcessReadRequest; //step3 : actual reading

    procedure SetGetStr(const Value: widestring);
    procedure SetPostStr(const Value: widestring);
    procedure SetRequestMethod(const Value: widestring);
    procedure SetMultipart(value: boolean);
    procedure SetURL(value: widestring);
    procedure ConvertToMultiPart;
    procedure ReadCookiesAndHeaders(hFile: HInternet);
    procedure CalcTimeoutDatetime;
    procedure SetTimeout(const Value: integer); //value is in milliseconds
    procedure PrepareHeaders1;
    procedure PrepareHeaders2;
    procedure ReadResponse;
    procedure SetBlockingMode(const Value: boolean);
    procedure CleanUpConnectionMemory;
    function GetErrorString(error_code: integer): widestring;
    procedure AddHeader(s: widestring);
    procedure SetTimeInterval(const Value: Integer);
  protected
    FpostStr: widestring;
    FgetStr: widestring;
    FRequestMethod: widestring;
    FMultipartPOST: boolean;
    FUrl: widestring;
    FOnPacketRead: TNotifyEvent;
    FOnTimer: TNotifyEvent;
  public
    //flag_WaitForSingleObject : boolean;
    ie_thread: TThread; //ttimeout not known here
    //ie_thread_ready : boolean;
    ie_thread_finished: boolean;
    //headers : string; //deprecated: see request_headers
    error: integer;
    error_msg: widestring;
    http_agent_string: widestring;

    result_sl: TWideStringList; //text response
    sl: TWideStringList; //alias to result_sl
    result_ms: TTNTMemoryStream; //binary response, tnt is to allow saving to unicode filename, nothing to do with content
    //result_ms : TMemoryStream; //binary response
    cookies: TWideStringlist;
    request_headers: TWideStringList; //additional request headers, e.g.
    response_headers: TWideStringList;
    error_code: integer; //100: timeout
                          //101: canceled
    working_status: integer;

    bytes_read_total: integer;
    event_handle: THandle;

    content_type: widestring;
    ContentSize: DWORD;
    multipartVars: array of record f: widestring; v: widestring end; //v will be converted to utf8
    multipartBinaryVars: array of record f: widestring; v: bytestring end;

    aURLC2: TURLComponents;
    username: widestring;
    password: widestring;
    proxy_username: widestring;
    proxy_password: widestring;
    debug_total_packets: integer;
    debug_total_packet_events: integer;
    debug_total_timer_events: Integer;
    unzip_method: ansichar; //G: iis Z: php
    procedure ProcessReadRequest; //step3 : actual reading

    procedure Execute; //step1 : execute default url
    procedure ExecuteURL(url: widestring); //step1 : execute given url

    constructor Create(AOwner: TComponent); override; //reintroduce;
    destructor Destroy; override;
    function GetStringPercentage: widestring; //example on how to read download status
    procedure RequestCompleted;
    procedure StopRequest(wait: boolean = false);
    function GetProgress: single;
    function GetProgressPercentage: single;
    function CheckIEOnline: boolean;
    function GetResponseHeaderValue(header_name: widestring): widestring;
    function GetResponseHeaderIdx(header_name: widestring): integer;
    procedure AddRequestHeader(header_name, value: widestring);
    procedure DeleteRequestHeader(header_name: widestring);
    function GetRequestHeaderIdx(header_name: widestring): integer;
    function GetRequestHeaderValue(header_name: widestring): widestring;
    function Canceled: boolean; //us-spelling
    function FileToB64String(filename: widestring): bytestring;
  published
    property postStr: widestring read FPostStr write SetPostStr;
    property getStr: widestring read FGetStr write SetGetStr;
    property URL: widestring read FUrl write SetURL;
    property Timeout: integer read fTimeout write SetTimeout;
    property TimerIntervalSeconds: Integer read fTimerIntervalSeconds write SetTimeInterval;
    property BlockingMode: boolean read fBlockingMode write SetBlockingMode;
    //property username : string read FUsername write FUsername;
    //property password : string read FPassword write FPassword;
    //property content_type : string read Fcontent_type write Fcontent_type;
    property RequestMethod: widestring read FRequestMethod write SetRequestMethod;
    property MultipartPOST: boolean read FMultipartPOST write SetMultipart;
    property OnPacketRead: TNotifyEvent read FOnPacketRead write FOnPacketRead;
    property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
    procedure AddMultipartVar(field: widestring; value: widestring);
    procedure AddMultipartVarW(field: widestring; value: widestring);
    procedure AddMultipartVarA(field: widestring; value: ansistring);
    procedure AddMultipartVar_B64(field: widestring; value: bytestring);
    procedure AddMultipartFile(field: widestring; filename: widestring);
    procedure AddMultipartStream(field: widestring; ms: TMemoryStream);
    //procedure AddMultipartVar_Compressed(field: string; value: string);
  end;

procedure Register;

implementation

uses
{$IFDEF tie_debug}my_unit1, {$ENDIF}
  ZLib, iiehttp3_funcs, iehttp4_thread,
  Dialogs, Controls; //for MessageDlg and mrOK;

procedure Register;
begin
  RegisterComponents('Internet', [TIEHTTP]);
end;

{$IFDEF tie_debug}

procedure LogStr(s: widestring);
begin
  AppendToFileLNA('c:\iehttp1.log', datetimetostr(now) + ' : ' + s);
end;
{$ENDIF}

{ TIEHTTP }

constructor TIEHTTP.Create;
var
  lStructSize: Cardinal;
  wininet_receive_timeout: LongInt;
begin
  inherited Create(AOwner);

  setRequestMethod('GET');
  multipartPOST := false;

  result_sl := TWideStringList.Create;
  sl := result_sl; //alias
  result_ms := TTNTMemoryStream.Create;
  result_ms.Position := 0;
  response_headers := TWideStringList.create;
  request_headers := TWideStringList.create;
  request_headers.Add('Accept-Encoding: gzip, deflate');
  cookies := tWideStringlist.create;

  http_agent_string := 'tiehttp';

  fBlockingMode := true; //if you will not be allowed to cancel requests
                         //except from other threads
  fTimeout := 90; // timeout if no reply for X seconds between reads
                 // this will not affect a long connection as long
                 // as the delay between reads does not exceed X seconds

  working_status := 0; //0: working=off, 1: working=on

  lStructSize := sizeof(wininet_receive_timeout);
  InternetQueryOptionW(nil, INTERNET_OPTION_RECEIVE_TIMEOUT, @wininet_receive_timeout, lStructSize);

  //ie7 introduced a default receive timeout of 30seconds
  //in ie6 and below the timeout was 0 (infinite)
  is_ie6_and_below := wininet_receive_timeout <> 30000;

  if not is_ie6_and_below then begin
    wininet_receive_timeout := 0;
    InternetSetOptionW(nil, INTERNET_OPTION_RECEIVE_TIMEOUT, @wininet_receive_timeout, sizeof(wininet_receive_timeout));
  end;
end;

destructor TIEHTTP.Destroy;
begin
  result_sl.Free;
  result_ms.free;
  cookies.free;
  response_headers.Free;
  request_headers.free;

  inherited Destroy;
end;

//==============================================================================
// sample: how to get download progress
//==============================================================================

function TIEHTTP.GetStringPercentage: widestring;
var
  percent_done: widestring;
begin
  if contentSize > 0 then
    percent_done := format('%.0n%%', [GetProgress * 100])
  else
    percent_done := '[]';

  //example on how to read download status
  result := format('Bytes Read: %.0n '#13'Total File Size: %.0n'#13'Status: %s done'
    , [bytes_read_total * 1.0, contentSize * 1.0, percent_done]);
end;

function TIEHTTP.GetProgress: single;
//percentage progress: 0.00 - 1.00
begin
  if contentSize = 0 then begin
    result := 0;
    exit;
  end;

  result := (bytes_read_total / contentSize);
end;

function TIEHTTP.GetProgressPercentage: single;
//percentage progress: 0 - 100%
begin
  result := GetProgress * 100;
end;

procedure TIEHTTP.ProcessReadRequest;
//this is used from HTTPS -POST/GET
//                  HTTP  -POST
//                  for HTTP/GET use geturl
var
  dwFlags: DWord;
  lpdwBufferLength: DWORD;
  dwError: DWord;
var
  context: DWORD;
var
  dwBufLen: DWORD;
  dwIndex: Cardinal;
  //error_msg : string;
  //wininet_receive_timeout : ULONG;
  //lStructSize : cardinal;
  ContentSize_custom: widestring;
begin
  // Initialization, fall-through
  hSession := nil;
  hConnect := nil;
  hFile := nil;
  //size3_multipart := 0;
  dwError := 0;

  debug_total_packets := 0;
  debug_total_packet_events := 0;
  debug_total_timer_events := 0;

  hSession := InternetOpenW(pwidechar(http_agent_string), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  try
    if (hSession = nil) then begin
      //raise exception.create('Could not open Internet');
      error_msg := 'Could not open Internet';
      exit;
    end;

    // Set options for the internet handle
    //InternetSetOption(aHi, INTERNET_OPTION_CONNECT_TIMEOUT, @timeOutMS, sizeOf(timeOutMS));

    //InternetSetOption(hI, INTERNET_OPTION_CONNECT_TIMEOUT,5*60*1000,0);
    //session.SetOption(hI, INTERNET_OPTION_CONNECT_RETRIES,15,0);
    //session.SetOption(hI, INTERNET_OPTION_DATA_SEND_TIMEOUT,5*60*1000,0);
    //session.SetOption(hI, INTERNET_OPTION_RECEIVE_TIMEOUT,5*60*1000,0);

    //in ie receive_timeout returns 30000 ms
    //dwBufLen := sizeof(wininet_receive_timeout);
    //InternetQueryOption(nil, INTERNET_OPTION_RECEIVE_TIMEOUT, @wininet_receive_timeout, dwBufLen);

    //http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wceinternet5/html/wce50lrfoptionflags.asp