clconnection.pas

来自「Clever_Internet_Suite_6.2的代码 Clever_Int」· PAS 代码 · 共 990 行 · 第 1/2 页

{
  Clever Internet Suite Version 6.2
  Copyright (C) 1999 - 2006 Clever Components
  www.CleverComponents.com
}

unit clConnection;

interface

{$I clVer.inc}

uses
  Windows, SysUtils, Classes, clDCUtils, clWinInet, SyncObjs, clSyncUtils;

type
  TclInternetConnection = class;
  EclTimeoutInternetError = class(EclInternetError);

  TclInternetAction = class
  private
    FOwner: TclInternetConnection;
    FInternet: HINTERNET;
    FAccessor: TCriticalSection;
  protected
    FErrorCode: Integer;
    FErrorText: string;
    procedure NotifyTerminate(AInternet: HINTERNET); virtual;
    procedure Execute; virtual;
    procedure Terminate;
  public
    constructor Create(AOwner: TclInternetConnection; AInternet: HINTERNET);
    destructor Destroy; override;
    function FireAction(ATimeOut: Integer; AIsSilent: Boolean = False): Boolean; virtual;
    property Internet: HINTERNET read FInternet;
  end;

  TclInternetActionClass = class of TclInternetAction;

  TclActionEvent = procedure (Sender: TObject; Action: TclInternetAction) of object;
  TclStatusCallbackEvent = procedure (Sender: TObject; Action: TclInternetAction;
    AInternetStatus: Integer; AStatusInformation: PChar; AStatusInformationLength: Integer) of object;

  TclInternetConnection = class(TComponent)
  private
    FActionList: TList;
    FBeginEvent: THandle;
    FTerminateEvent: THandle;
    FWaitEvent: THandle;
    FEndEvent: THandle;
    FThread: THandle;
    FInternetAction: TclInternetAction;
    FSynchronizer: TclThreadSynchronizer;
    FEventAction: TclInternetAction;
    FEventInternetStatus: Integer;
    FEventStatusInfo: PChar;
    FEventStatusInfoLength: Integer;
    FOnActionAdded: TclActionEvent;
    FOnActionRemoved: TclActionEvent;
    FOnBeforeFireAction: TclActionEvent;
    FOnAfterFireAction: TclActionEvent;
    FOnStatusCallback: TclStatusCallbackEvent;
    procedure AssignWaitMembers;
    procedure FireInternetAction(Action: TclInternetAction; ATimeOut: Integer);
    procedure FireNotifyTerminate(AInternet: HINTERNET);
    function GetAction(Index: Integer): TclInternetAction;
    procedure AddAction(Action: TclInternetAction);
    procedure RemoveAction(Action: TclInternetAction);
    procedure SetStatusCallbackIfNeed(Action: TclInternetAction);
    procedure SyncActionAdded;
    procedure SyncActionRemoved;
    procedure SyncAfterFireAction;
    procedure SyncBeforeFireAction;
    procedure SyncStatusCallback;
    procedure InternalSynchronize(Method: TThreadMethod);
  protected
    procedure DoActionAdded(Action: TclInternetAction); dynamic;
    procedure DoActionRemoved(Action: TclInternetAction); dynamic;
    procedure DoBeforeFireAction(Action: TclInternetAction); dynamic;
    procedure DoAfterFireAction(Action: TclInternetAction); dynamic;
    procedure DoStatusCallback(Action: TclInternetAction; AInternetStatus: Integer;
      AStatusInformation: PChar; AStatusInformationLength: Integer); dynamic;
    procedure Stop;
    function GetActionByHandle(hInet: HINTERNET): TclInternetAction;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Close;
    function GetActionByClass(AClass: TclInternetActionClass): TclInternetAction;
  published
    property OnActionAdded: TclActionEvent read FOnActionAdded write FOnActionAdded;
    property OnActionRemoved: TclActionEvent read FOnActionRemoved write FOnActionRemoved;
    property OnAfterFireAction: TclActionEvent read FOnAfterFireAction write FOnAfterFireAction;
    property OnBeforeFireAction: TclActionEvent read FOnBeforeFireAction write FOnBeforeFireAction;
    property OnStatusCallback: TclStatusCallbackEvent
      read FOnStatusCallback write FOnStatusCallback;
  end;

  TclInternetResourceAction = class(TclInternetAction)
  protected
    FhResource: HINTERNET;
    procedure NotifyTerminate(AInternet: HINTERNET); override;
    procedure Execute; override;
  public
    destructor Destroy; override;
    procedure CloseResource;
    property hResource: HINTERNET read FhResource;
  end;

  TclInternetOpenAction = class(TclInternetResourceAction)
  private
    FlpszAgent: string;
    FdwAccessType: DWORD;
    FlpszProxy: string;
    FlpszProxyBypass: string;
    FdwFlags: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection; lpszAgent: string; dwAccessType: DWORD;
      lpszProxy, lpszProxyBypass: string; dwFlags: DWORD);
  end;

  TclOpenURLAction = class(TclInternetResourceAction)
  private
    FlpszUrl: string;
    FlpszHeaders: string;
    FdwFlags: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection; hInet: HINTERNET; lpszUrl,
      lpszHeaders: string; dwFlags: DWORD);
  end;

  TclConnectAction = class(TclInternetResourceAction)
  private
    FlpszServerName: string;
    FnServerPort: INTERNET_PORT;
    FlpszUsername: string;
    FlpszPassword: string;
    FdwService: DWORD;
    FdwFlags: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection; hInet: HINTERNET; lpszServerName: string;
      nServerPort: INTERNET_PORT; lpszUsername, lpszPassword: string; dwService, dwFlags: DWORD);
  end;

  TclFtpFindFirstFileAction = class(TclInternetResourceAction)
  private
    FhConnect: HINTERNET;
    FlpFindFileData: TWin32FindData;
    FlpszSearchFile: string;
    FdwFlags: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection; hInet, hConnect: HINTERNET;
      lpszSearchFile: string; dwFlags: DWORD);
    property lpFindFileData: TWin32FindData read FlpFindFileData;
  end;

  TclFtpGetFileSizeAction = class(TclInternetAction)
  private
    FhFile: HINTERNET;
    FFileSize: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection; hInet, hFile: HINTERNET);
    property FileSize: DWORD read FFileSize;
  end;

  TclFtpOpenFileAction = class(TclInternetResourceAction)
  private
    FhConnect: HINTERNET;
    FlpszFileName: string;
    FdwAccess: DWORD;
    FdwFlags: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection; hInet, hConnect: HINTERNET; lpszFileName: string;
      dwAccess: DWORD; dwFlags: DWORD);
  end;

  TclFtpCreateDirectoryAction = class(TclInternetAction)
  private
    FhConnect: HINTERNET;
    FlpszDirectory: string;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection; hInet, hConnect: HINTERNET; lpszDirectory: string);
  end;

  TclHttpOpenRequestAction = class(TclInternetResourceAction)
  private
    FhConnect: HINTERNET;
    FlpszVerb: string;
    FlpszObjectName: string;
    FlpszVersion: string;
    FlpszReferrer: string;
    FlplpszAcceptTypes: PLPSTR;
    FdwFlags: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection;
      hInet, hConnect: HINTERNET; lpszVerb, lpszObjectName, lpszVersion, lpszReferrer: string;
      lplpszAcceptTypes: PLPSTR; dwFlags: DWORD);
  end;

  TclHttpSendRequestAction = class(TclInternetAction)
  private
    FhRequest: HINTERNET;
    FlpszHeaders: string;
    FlpOptional: Pointer;
    FdwOptionalLength: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection; hInet, hRequest: HINTERNET;
      lpszHeaders: string; lpOptional: Pointer;
      dwOptionalLength: DWORD);
  end;

  TclHttpSendRequestExAction = class(TclInternetAction)
  private
    FhRequest: HINTERNET;
    FlpBuffersIn: PInternetBuffers;
    FlpBuffersOut: PInternetBuffers;
    FdwFlags: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection; hInet: HINTERNET; hRequest: HINTERNET;
      lpBuffersIn: PInternetBuffers; lpBuffersOut: PInternetBuffers;
      dwFlags: DWORD);
  end;

  TclHttpEndRequestAction = class(TclInternetAction)
  private
    FhRequest: HINTERNET;
    FlpBuffersOut: PInternetBuffers;
    FdwFlags: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection; hInet, hRequest: HINTERNET;
      lpBuffersOut: PInternetBuffers; dwFlags: DWORD);
  end;

  TclInternetReadFileAction = class(TclInternetAction)
  private
    FhFile: HINTERNET;
    FlpBuffer: Pointer;
    FdwNumberOfBytesToRead: DWORD;
    FlpdwNumberOfBytesRead: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection; hInet, hFile: HINTERNET; lpBuffer: Pointer);
    property dwNumberOfBytesToRead: DWORD read FdwNumberOfBytesToRead write FdwNumberOfBytesToRead;
    property lpdwNumberOfBytesRead: DWORD read FlpdwNumberOfBytesRead;
  end;

  TclInternetWriteFileAction = class(TclInternetAction)
  private
    FhFile: HINTERNET;
    FlpBuffer: Pointer;
    FdwNumberOfBytesToWrite: DWORD;
    FlpdwNumberOfBytesWritten: DWORD;
  protected
    procedure Execute; override;
  public
    constructor Create(AOwner: TclInternetConnection; hInet, hFile: HINTERNET);
    property lpBuffer: Pointer read FlpBuffer write FlpBuffer;
    property dwNumberOfBytesToWrite: DWORD read FdwNumberOfBytesToWrite write FdwNumberOfBytesToWrite;
    property lpdwNumberOfBytesWritten: DWORD read FlpdwNumberOfBytesWritten;
  end;

implementation

{ TclOpenURLAction }

constructor TclOpenURLAction.Create(AOwner: TclInternetConnection; hInet: HINTERNET; lpszUrl,
  lpszHeaders: string; dwFlags: DWORD);
begin
  inherited Create(AOwner, hInet);
  FlpszUrl := lpszUrl;
  FlpszHeaders := lpszHeaders;
  FdwFlags := dwFlags;
end;

procedure TclOpenURLAction.Execute;
var
  Headers: PChar;
begin
  FhResource := nil;
  Headers := nil;
  if (FlpszHeaders <> '') then
  begin
    Headers := PChar(FlpszHeaders);
  end;
  FhResource := InternetOpenUrl(Internet, PChar(FlpszUrl), Headers, Length(FlpszHeaders), FdwFlags, DWORD(FOwner));
  inherited Execute();
end;

{ TclInternetConnection }

function WaitProc(Instance: TclInternetConnection): Integer;
var
  arr: array[0..1] of THandle;
  waitevent: THandle;
begin
  arr[0] := Instance.FBeginEvent;
  arr[1] := Instance.FEndEvent;
  waitevent := Instance.FWaitEvent;
  repeat
    if (WaitForMultipleObjects(2, @arr, False, INFINITE) = WAIT_OBJECT_0) then
    begin
      if (Instance.FInternetAction <> nil) then
      begin
        try
          Instance.FInternetAction.Execute();
        except
        end;
        SetEvent(waitevent);
      end;
    end else
    begin
      Break;
    end;
  until False;
  Result := 0;
end;

procedure TclInternetConnection.AssignWaitMembers;
var
  id: DWORD;
begin
  if (FBeginEvent = 0) then
  begin
    FBeginEvent := CreateEvent(nil, False, False, nil);
    FTerminateEvent := CreateEvent(nil, False, False, nil);
    FWaitEvent := CreateEvent(nil, False, False, nil);
    FEndEvent := CreateEvent(nil, False, False, nil);
    FThread := BeginThread(nil, 0, @WaitProc, Pointer(Self), 0, id);
  end;
end;

procedure TclInternetConnection.Stop();
begin
  SetEvent(FTerminateEvent);
end;

procedure TclInternetConnection.Close;
  procedure DoneItem(var AItem: THandle);
  begin
    if (AItem <> 0) then
    begin
      CloseHandle(AItem);
      AItem := 0;
    end;
  end;

begin
  Stop();
  while ((FActionList <> nil) and (FActionList.Count > 0)) do
  begin
    GetAction(0).Free();
  end;
  SetEvent(FEndEvent);
  WaitForSingleObject(FThread, INFINITE);
  DoneItem(FThread);
  DoneItem(FTerminateEvent);
  DoneItem(FBeginEvent);
  DoneItem(FWaitEvent);
  DoneItem(FEndEvent);
end;

constructor TclInternetConnection.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSynchronizer := TclThreadSynchronizer.Create();
  FActionList := TList.Create();
  FInternetAction := nil;
end;

destructor TclInternetConnection.Destroy;
begin
  Close();
  FActionList.Free();
  FActionList := nil;
  FSynchronizer.Free();
  inherited Destroy();
end;

procedure TclInternetConnection.FireInternetAction(Action: TclInternetAction; ATimeOut: Integer);
var
  arr: array[0..1] of THandle;
begin
  if (csDestroying in ComponentState) then Exit;
  FInternetAction := Action;
  try
    DoBeforeFireAction(Action);
    AssignWaitMembers();
    SetEvent(FBeginEvent);
    arr[0] := FWaitEvent;
    arr[1] := FTerminateEvent;                      
    case WaitForMultipleObjects(2, @arr, False, DWORD(ATimeOut)) of
      WAIT_OBJECT_0 + 1:
        begin
          Action.Terminate();
          WaitForSingleObject(FWaitEvent, INFINITE);
        end;
      WAIT_TIMEOUT:
        begin
          Action.Terminate();
          WaitForSingleObject(FWaitEvent, INFINITE);
          raise EclTimeoutInternetError.Create(cRequestTimeOut, WAIT_TIMEOUT);
        end;
      else
        begin
          DoAfterFireAction(Action);
          SetStatusCallbackIfNeed(Action);
        end;
    end;
  finally
    FInternetAction := nil;
  end;
end;

procedure TclInternetConnection.FireNotifyTerminate(AInternet: HINTERNET);
var
  i: Integer;
  Item: TclInternetAction;
begin
  if (csDestroying in ComponentState) then Exit;
  for i := 0 to FActionList.Count - 1 do
  begin
    Item := GetAction(i);
    if (Item <> FInternetAction) then
    begin
      Item.NotifyTerminate(AInternet);
    end;
  end;
end;

function TclInternetConnection.GetAction(Index: Integer): TclInternetAction;
begin
  Result := TclInternetAction(FActionList[Index]);
end;

function TclInternetConnection.GetActionByClass(AClass: TclInternetActionClass): TclInternetAction;
var
  i: Integer;
begin
  if not (csDestroying in ComponentState) then
  begin
    for i := 0 to FActionList.Count - 1 do
    begin
      Result := GetAction(i);
      if Result.InheritsFrom(AClass) then Exit;
    end;
  end;
  Result := nil;
end;

procedure StatusCallbackHandler(hInet: HINTERNET; dwContext: DWORD;
  AInternetStatus: DWORD; AStatusInformation: PChar; AStatusInformationLength: DWORD); stdcall;
var
  inst: TclInternetConnection;
begin
  inst := TclInternetConnection(dwContext);
  inst.DoStatusCallback(inst.GetActionByHandle(hInet),
    AInternetStatus, AStatusInformation, AStatusInformationLength);
end;

procedure TclInternetConnection.SetStatusCallbackIfNeed(Action: TclInternetAction);
begin
  if (csDestroying in ComponentState) then Exit;
  if (Action is TclInternetOpenAction)
    and Assigned(OnStatusCallback) then
  begin
    InternetSetStatusCallback(TclInternetOpenAction(Action).hResource, @StatusCallbackHandler);
  end;
end;

procedure TclInternetConnection.AddAction(Action: TclInternetAction);
begin
  if (FActionList <> nil) then