sconnect.pas

在Midas数据库编程中

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{       Streamed Connection classes                     }
{                                                       }
{       Copyright (c) 1997,99 Inprise Corporation       }
{                                                       }
{*******************************************************}

unit SConnect;

{$R-}

interface

uses
  Variants, Windows, Messages, Classes, SysUtils, MConnect, ScktComp, WinSock,
  WinInet, ComObj;

type

  {$HPPEMIT '#pragma link "wininet.lib"'}

  { IDataBlock }

  IDataBlock = interface(IUnknown)
  ['{CA6564C2-4683-11D1-88D4-00A0248E5091}']
    function GetBytesReserved: Integer; stdcall;
    function GetMemory: Pointer; stdcall;
    function GetSize: Integer; stdcall;
    procedure SetSize(Value: Integer); stdcall;
    function GetStream: TStream; stdcall;
    function GetSignature: Integer; stdcall;
    procedure SetSignature(Value: Integer); stdcall;
    procedure Clear; stdcall;
    function Write(const Buffer; Count: Integer): Integer; stdcall;
    function Read(var Buffer; Count: Integer): Integer; stdcall;
    procedure IgnoreStream; stdcall;
    function InitData(Data: Pointer; DataLen: Integer; CheckLen: Boolean): Integer; stdcall;
    property BytesReserved: Integer read GetBytesReserved;
    property Memory: Pointer read GetMemory;
    property Signature: Integer read GetSignature write SetSignature;
    property Size: Integer read GetSize write SetSize;
    property Stream: TStream read GetStream;
  end;

  { ISendDataBlock }

  ISendDataBlock = interface
  ['{87AD1043-470E-11D1-88D5-00A0248E5091}']
    function Send(const Data: IDataBlock; WaitForResult: Boolean): IDataBlock; stdcall;
  end;

  { ITransport }

  ITransport = interface(IUnknown)
  ['{CA6564C1-4683-11D1-88D4-00A0248E5091}']
    function GetWaitEvent: THandle; stdcall;
    function GetConnected: Boolean; stdcall;
    procedure SetConnected(Value: Boolean); stdcall;
    function Receive(WaitForInput: Boolean; Context: Integer): IDataBlock; stdcall;
    function Send(const Data: IDataBlock): Integer; stdcall;
    property Connected: Boolean read GetConnected write SetConnected;
  end;

  { IDataIntercept }

  IDataIntercept = interface
  ['{B249776B-E429-11D1-AAA4-00C04FA35CFA}']
    procedure DataIn(const Data: IDataBlock); stdcall;
    procedure DataOut(const Data: IDataBlock); stdcall;
  end;

  { TDataBlock }

  TDataBlock = class(TInterfacedObject, IDataBlock)
  private
    FStream: TMemoryStream;
    FReadPos: Integer;
    FWritePos: Integer;
    FIgnoreStream: Boolean;
  protected
    { IDataBlock }
    function GetBytesReserved: Integer; stdcall;
    function GetMemory: Pointer; stdcall;
    function GetSize: Integer; stdcall;
    procedure SetSize(Value: Integer); stdcall;
    function GetStream: TStream; stdcall;
    function GetSignature: Integer; stdcall;
    procedure SetSignature(Value: Integer); stdcall;
    procedure Clear; stdcall;
    function Write(const Buffer; Count: Integer): Integer; stdcall;
    function Read(var Buffer; Count: Integer): Integer; stdcall;
    procedure IgnoreStream; stdcall;
    function InitData(Data: Pointer; DataLen: Integer; CheckLen: Boolean): Integer; stdcall;
    property BytesReserved: Integer read GetBytesReserved;
    property Memory: Pointer read GetMemory;
    property Signature: Integer read GetSignature write SetSignature;
    property Size: Integer read GetSize write SetSize;
    property Stream: TStream read GetStream;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  { TDataBlockInterpreter }

const

  { Action Signatures }

  CallSig         = $DA00; // Call signature
  ResultSig       = $DB00; // Result signature
  asError         = $01;   // Specify an exception was raised
  asInvoke        = $02;   // Specify a call to Invoke
  asGetID         = $03;   // Specify a call to GetIdsOfNames
  asCreateObject  = $04;   // Specify a com object to create
  asFreeObject    = $05;   // Specify a dispatch to free
  asGetServers    = $10;   // Get classname list
  asGetGUID       = $11;   // Get GUID for ClassName
  asGetAppServers = $12;   // Get AppServer classname list
  asSoapCommand   = $14;   // Soap command
  asMask          = $FF;   // Mask for action

type

  PIntArray = ^TIntArray;
  TIntArray = array[0..0] of Integer;

  PVariantArray = ^TVariantArray;
  TVariantArray = array[0..0] of OleVariant;

  TVarFlag = (vfByRef, vfVariant);
  TVarFlags = set of TVarFlag;

  EInterpreterError = class(Exception);

  TDataDispatch = class;


  TCustomDataBlockInterpreter = class
  protected
    procedure AddDispatch(Value: TDataDispatch); virtual; abstract;
    procedure RemoveDispatch(Value: TDataDispatch); virtual; abstract;

    { Sending Calls }
    procedure CallFreeObject(DispatchIndex: Integer); virtual; abstract;
    function CallGetIDsOfNames(DispatchIndex: Integer; const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall; abstract;
    function CallInvoke(DispatchIndex, DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall; abstract;
    function CallGetServerList: OleVariant; virtual; abstract;

    { Receiving Calls }


    function InternalCreateObject(const ClassID: TGUID): OleVariant; virtual; abstract;
    function CreateObject(const Name: string): OleVariant; virtual; abstract;
    function StoreObject(const Value: OleVariant): Integer; virtual; abstract;
    function LockObject(ID: Integer): IDispatch; virtual; abstract;
    procedure UnlockObject(ID: Integer; const Disp: IDispatch); virtual; abstract;
    procedure ReleaseObject(ID: Integer); virtual; abstract;
    function CanCreateObject(const ClassID: TGUID): Boolean; virtual; abstract;
    function CallCreateObject(Name: string): OleVariant;  virtual;  abstract;
  public
    procedure InterpretData(const Data: IDataBlock); virtual; abstract;
  end;


  { TBinary... }
  TDataBlockInterpreter = class(TCustomDataBlockInterpreter)
  private
    FDispatchList: TList;
    FDispList: OleVariant;
    FSendDataBlock: ISendDataBlock;
    FCheckRegValue: string;
    function GetVariantPointer(const Value: OleVariant): Pointer;
    procedure CopyDataByRef(const Source: TVarData; var Dest: TVarData);
    function ReadArray(VType: Integer; const Data: IDataBlock): OleVariant;
    procedure WriteArray(const Value: OleVariant; const Data: IDataBlock);
    function ReadVariant(out Flags: TVarFlags; const Data: IDataBlock): OleVariant;
    procedure WriteVariant(const Value: OleVariant; const Data: IDataBlock);
    procedure DoException(const Data: IDataBlock);
  protected
    procedure AddDispatch(Value: TDataDispatch); override;
    procedure RemoveDispatch(Value: TDataDispatch); override;
    function InternalCreateObject(const ClassID: TGUID): OleVariant; override;
    function CreateObject(const Name: string): OleVariant; override;
    function StoreObject(const Value: OleVariant): Integer; override;
    function LockObject(ID: Integer): IDispatch; override;
    procedure UnlockObject(ID: Integer; const Disp: IDispatch); override;
    procedure ReleaseObject(ID: Integer); override;
    function CanCreateObject(const ClassID: TGUID): Boolean; override;

    {Sending Calls}
    procedure CallFreeObject(DispatchIndex: Integer); override;
    function CallGetIDsOfNames(DispatchIndex: Integer; const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; override;
    function CallInvoke(DispatchIndex, DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;  override;
    function CallGetServerList: OleVariant; override;

    {Receiving Calls}
    procedure DoCreateObject(const Data: IDataBlock);
    procedure DoFreeObject(const Data: IDataBlock);
    procedure DoGetIDsOfNames(const Data: IDataBlock);
    procedure DoInvoke(const Data: IDataBlock);
    function DoCustomAction(Action: Integer; const Data: IDataBlock): Boolean; virtual;
    procedure DoGetAppServerList(const Data: IDataBlock);
    procedure DoGetServerList(const Data: IDataBlock);

  public
    constructor Create(SendDataBlock: ISendDataBlock; CheckRegValue: string);
    destructor Destroy; override;
    function CallCreateObject(Name: string): OleVariant;  override;
    procedure InterpretData(const Data: IDataBlock); override;
  end;

{ TDataDispatch }

  TDataDispatch = class(TInterfacedObject, IDispatch)
  private
    FDispatchIndex: Integer;
    FInterpreter: TCustomDataBlockInterpreter;
  protected
    property DispatchIndex: Integer read FDispatchIndex;
    { IDispatch }
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
  public
    constructor Create(Interpreter: TCustomDataBlockInterpreter; DispatchIndex: Integer);
    destructor Destroy; override;
  end;

  { TTransportThread }

const
  THREAD_SENDSTREAM       = WM_USER + 1;
  THREAD_RECEIVEDSTREAM   = THREAD_SENDSTREAM + 1;
  THREAD_EXCEPTION        = THREAD_RECEIVEDSTREAM + 1;
  THREAD_SENDNOTIFY       = THREAD_EXCEPTION + 1;
  THREAD_REPLACETRANSPORT = THREAD_SENDNOTIFY + 1;

type

  TTransportThread = class(TThread)
  private
    FParentHandle: THandle;
    FSemaphore: THandle;
    FTransport: ITransport;
  public
    constructor Create(AHandle: THandle; Transport: ITransport); virtual;
    destructor Destroy; override;
    property Semaphore: THandle read FSemaphore;
    procedure Execute; override;
  end;

  { TStreamedConnection }

  TStreamedConnection = class(TDispatchConnection, ISendDataBlock)
  private
    FRefCount: Integer;
    FHandle: THandle;
    FTransport: TTransportThread;
    FTransIntf: ITransport;
    FInterpreter: TCustomDataBlockInterpreter;
    FSupportCallbacks: Boolean;
    FInterceptGUID: TGUID;
    FInterceptName: string;
    function GetHandle: THandle;
    procedure TransportTerminated(Sender: TObject);
    procedure SetSupportCallbacks(Value: Boolean);
    procedure SetInterceptName(const Value: string);
    function GetInterceptGUID: string;
    procedure SetInterceptGUID(const Value: string);
  protected
    { IUnknown }
    function QueryInterface(const IID: TGUID; out Obj): HResult; reintroduce; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    { ISendDataBlock }
    function Send(const Data: IDataBlock; WaitForResult: Boolean): IDataBlock; stdcall;

    procedure InternalOpen; virtual;
    procedure InternalClose; virtual;

    procedure ThreadReceivedStream(var Message: TMessage); message THREAD_RECEIVEDSTREAM;
    procedure ThreadException(var Message: TMessage); message THREAD_EXCEPTION;
    procedure WndProc(var Message: TMessage);
    function CreateTransport: ITransport; virtual;
    procedure DoConnect; override;
    procedure DoDisconnect; override;
    procedure DoError(E: Exception); virtual;

    function GetInterpreter: TCustomDataBlockInterpreter; virtual;

    property Interpreter: TCustomDataBlockInterpreter read GetInterpreter;
    property Handle: THandle read GetHandle;
    property SupportCallbacks: Boolean read FSupportCallbacks write SetSupportCallbacks default True;
    property InterceptGUID: string read GetInterceptGUID write SetInterceptGUID;
    property InterceptName: string read FInterceptName write SetInterceptName;
  public
    function GetInterceptorList: OleVariant; virtual;
    function GetServerList: OleVariant; override;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

  { TSocketTransport }

  ESocketConnectionError = class(Exception);

  TSocketTransport = class(TInterfacedObject, ITransport)
  private
    FEvent: THandle;
    FAddress: string;
    FHost: string;
    FPort: Integer;
    FClientSocket: TClientSocket;
    FSocket: TCustomWinSocket;
    FInterceptGUID: string;
    FInterceptor: IDataIntercept;
    FCreateAttempted: Boolean;
    function CheckInterceptor: Boolean;
    procedure InterceptIncoming(const Data: IDataBlock);
    procedure InterceptOutgoing(const Data: IDataBlock);
  protected
    { ITransport }
    function GetWaitEvent: THandle; stdcall;
    function GetConnected: Boolean; stdcall;
    procedure SetConnected(Value: Boolean); stdcall;
    function Receive(WaitForInput: Boolean; Context: Integer): IDataBlock; stdcall;
    function Send(const Data: IDataBlock): Integer; stdcall;
  public
    constructor Create;
    destructor Destroy; override;
    property Host: string read FHost write FHost;
    property Address: string read FAddress write FAddress;
    property Port: Integer read FPort write FPort;
    property Socket: TCustomWinSocket read FSocket write FSocket;
    property InterceptGUID: string read FInterceptGUID write FInterceptGUID;
  end;

  { TSocketConnection }

  TSocketConnection = class(TStreamedConnection)
  private
    FAddress: string;
    FHost: string;
    FPort: Integer;
    procedure SetAddress(Value: string);
    procedure SetHost(Value: string);
    function IsHostStored: Boolean;
    function IsAddressStored: Boolean;
  protected
    function CreateTransport: ITransport; override;
    procedure DoConnect; override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property Address: string read FAddress write SetAddress stored IsAddressStored;
    property Host: string read FHost write SetHost stored IsHostStored;
    property InterceptGUID;
    property InterceptName;
    property Port: Integer read FPort write FPort default 211;
    property SupportCallbacks;
    property ObjectBroker;
  end;

  { TWebConnection }

  TWebConnection = class(TStreamedConnection, ITransport)
  private
    FAgent: string;
    FUserName: string;
    FPassword: string;
    FURL: string;
    FURLHost: string;
    FURLSite: string;
    FURLPort: Integer;
    FURLScheme: Integer;
    FProxy: string;
    FProxyByPass: string;
    FInetRoot: HINTERNET;
    FInetConnect: HINTERNET;
    FInterpreter: TCustomDataBlockInterpreter;
    procedure Check(Error: Boolean);
    function IsURLStored: Boolean;
    procedure SetURL(const Value: string);
  protected
    { ITransport }
    function GetInterpreter: TCustomDataBlockInterpreter; override;
    function GetWaitEvent: THandle; stdcall;
    function Transport_GetConnected: Boolean; stdcall;
    function ITransport.GetConnected = Transport_GetConnected;
    procedure Transport_SetConnected(Value: Boolean); stdcall;
    procedure ITransport.SetConnected = Transport_SetConnected;
    function Receive(WaitForInput: Boolean; Context: Integer): IDataBlock; stdcall;
    function Send(const Data: IDataBlock): Integer; stdcall;
  protected
    function CreateTransport: ITransport; override;
    procedure DoConnect; override;
    property SupportCallbacks default False;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Agent: string read FAgent write FAgent;
    property UserName: string read FUserName write FUserName;
    property Password: string read FPassword write FPassword;
    property URL: string read FURL write SetURL stored IsURLStored;
    property Proxy: string read FProxy write FProxy;
    property ProxyByPass: string read FProxyByPass write FProxyByPass;
    property ObjectBroker;
  end;

  { TPacketInterceptFactory }

  TPacketInterceptFactory = class(TComObjectFactory)
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;
  {$EXTERNALSYM TPacketInterceptFactory}