qisocketc.pas

QiMidas组件全代码版支持d2006 QiMidas组件全代码版支持d2006

unit QiSocketC;

interface

uses
  VarUtils, Variants, Windows, Messages, Classes, SysUtils, MConnect, Contnrs,
  ScktComp, WinSock, WinInet, ComObj, SConnect, Math, DB, DBClient, Midas, Dialogs;

type
  TQiCustomDataBlockInterpreter = class;
  TQiRemoteServer = class;
  TNetProgressEvent=procedure(Sender: TObject;Position,Max:Integer) of object;

  { TQiSocketTransport }
  IQiNetEvents=interface
    function GetSupportCallbacks:Boolean;
    procedure DoReceiveProgress(Sender: TObject;Position,Max:Integer);
  end;
  TQiSocketTransport = class(TInterfacedObject, ITransport)
  private
    FEvent: THandle;
    FAddress: string;
    FHost: string;
    FPort: Integer;
    FClientSocket: TClientSocket;
    FSocket: TCustomWinSocket;
    FInterceptGUID: string;
    FInterceptor: IDataIntercept;
    FNetEventsOwner: IQiNetEvents;
    procedure SetNetEventsOwner(const Value: IQiNetEvents);
    (*
    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;
    property InterceptGUID: string read FInterceptGUID write FInterceptGUID;

  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 NetEventsOwner: IQiNetEvents read FNetEventsOwner write SetNetEventsOwner;
  end;

  { TQiTransportThread }

  TQiTransportThread = 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;

  { TQiDataDispatch }

  TQiDataDispatch = class(TInterfacedObject, IDispatch)
  private
    FDispatchIndex: Integer;
    FInterpreter: TQiCustomDataBlockInterpreter;
  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: TQiCustomDataBlockInterpreter; DispatchIndex: Integer);
    destructor Destroy; override;
  end;

  { TQiCustomDataBlockInterpreter }

  TQiCustomDataBlockInterpreter = class
  protected
    procedure AddDispatch(Value: TQiDataDispatch); virtual; abstract;
    procedure RemoveDispatch(Value: TQiDataDispatch); 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;

  { TQiDataBlockInterpreter }

  TQiDataBlockInterpreter = class(TQiCustomDataBlockInterpreter)
  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: TQiDataDispatch); override;
    procedure RemoveDispatch(Value: TQiDataDispatch); 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;

  { TQiStreamedConnection }

  TQiStreamedConnection = class(TDispatchConnection, ISendDataBlock)
  private
    FRefCount: Integer;
    FHandle: THandle;
    FTransport: TQiTransportThread;
    FTransIntf: ITransport;
    FInterpreter: TQiCustomDataBlockInterpreter;
    FSupportCallbacks: Boolean;
    FInterceptGUID: TGUID;
    FInterceptName: string;
    FLastActiveTime: TDateTime;
    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: TQiCustomDataBlockInterpreter; virtual;

    property Interpreter: TQiCustomDataBlockInterpreter 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;
    property LastActiveTime: TDateTime read FLastActiveTime;
  end;

  { TQiSocketConnection }

  TQiSocketConnection = class(TQiStreamedConnection, IQiNetEvents)
  private
    FAddress: string;
    FHost: string;
    FPort: Integer;
    FReceiveProgress: TNetProgressEvent;
    procedure SetAddress(Value: string);
    procedure SetHost(Value: string);
    function IsHostStored: Boolean;
    function IsAddressStored: Boolean;
    procedure SetReceiveProgress(const Value: TNetProgressEvent);
  protected
    function CreateTransport: ITransport; override;
    procedure DoConnect; override;
    property InterceptGUID;
    property InterceptName;
    procedure DoReceiveProgress(Sender: TObject;Position,Max:Integer);    
  public
    constructor Create(AOwner: TComponent); override;
    function GetSupportCallbacks:Boolean;    
  published
    property Address: string read FAddress write SetAddress stored IsAddressStored;
    property Host: string read FHost write SetHost stored IsHostStored;
    property Port: Integer read FPort write FPort default 211;
    property SupportCallbacks;
    property ObjectBroker;
    property ReceiveProgress: TNetProgressEvent read FReceiveProgress write SetReceiveProgress;
  end;

  { TQiSocketTransConnection }

  TQiSocketTransConnection = class(TComponent, ISendDataBlock, IQiNetEvents)
  private
    FAddress: string;
    FHost: string;
    FPort: Integer;
    FHandle: THandle;
    FTransport: TQiTransportThread;
    FTransIntf: ITransport;
    FInterpreter: TQiCustomDataBlockInterpreter;
    FReceiveProgress: TNetProgressEvent;
    FSupportCallbacks: Boolean;
    FRefCount: Integer;
    FLastActiveTime: TDateTime;
    FOnConnection: TNotifyEvent;
    FOnDisconnection: TNotifyEvent;
    FRemoteServers: TObjectList;

    procedure SetAddress(Value: string);
    procedure SetHost(Value: string);
    function IsHostStored: Boolean;
    function IsAddressStored: Boolean;
    procedure SetReceiveProgress(const Value: TNetProgressEvent);
    procedure SetSupportCallbacks(const Value: Boolean);
    procedure TransportTerminated(Sender: TObject);

    function GetHandle: THandle;
    function GetConnected: Boolean;
    procedure SetConnected(const Value: Boolean);
    function GetInterpreter: TQiCustomDataBlockInterpreter;
    procedure SetOnConnection(const Value: TNotifyEvent);
    procedure SetOnDisconnection(const Value: TNotifyEvent);
  protected
    function CreateTransport: ITransport;
    procedure InternalOpen;
    procedure InternalClose;
    procedure DoConnect;
    procedure DoDisconnect;
    procedure AddRemoteServer(RServer:TQiRemoteServer);
    procedure RemoveRemoteServer(RServer:TQiRemoteServer);    

    procedure DoReceiveProgress(Sender: TObject;Position,Max:Integer);
    procedure WndProc(var Message: TMessage);

    property Interpreter: TQiCustomDataBlockInterpreter read GetInterpreter;
    { 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 DoError(E: Exception); virtual;

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function GetServerList: OleVariant;
    function GetSupportCallbacks:Boolean;    

    property LastActiveTime: TDateTime read FLastActiveTime;
  published
    property SupportCallbacks: Boolean read FSupportCallbacks write SetSupportCallbacks default True;
    property Handle: THandle read GetHandle;

    property Address: string read FAddress write SetAddress stored IsAddressStored;
    property Host: string read FHost write SetHost stored IsHostStored;
    property Port: Integer read FPort write FPort default 211;
    property Connected: Boolean read GetConnected write SetConnected default False;
    property ReceiveProgress: TNetProgressEvent read FReceiveProgress write SetReceiveProgress;
    property OnConnection:TNotifyEvent read FOnConnection write SetOnConnection;
    property OnDisconnection:TNotifyEvent read FOnDisconnection write SetOnDisconnection;    
  end;

  TQiRemoteServer = class(TCustomRemoteServer)
  private
    FServerGUID: TGUID;
    FServerName: string;
    FObjectBroker: TCustomObjectBroker;
    FQiSocketTransConnection: TQiSocketTransConnection;
    function GetServerGUID: string;
    procedure SetServerGUID(const Value: string);
    procedure SetServerName(const Value: string);
    procedure SetObjectBroker(Value: TCustomObjectBroker);
    procedure SetQiSocketTransConnection(
      const Value: TQiSocketTransConnection);
  protected
    function GetServerList: OleVariant; override;
    procedure DoDisconnect; override;
    procedure DoConnect; override;

    function GetConnected: Boolean; override;
    procedure SetConnected(Value: Boolean); override;
    function GetServerCLSID: TGUID;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    property ObjectBroker: TCustomObjectBroker read FObjectBroker write SetObjectBroker;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetServer: IAppServer; override;
  published
    property Connected;
    property LoginPrompt default False;
    property ServerGUID: string read GetServerGUID write SetServerGUID;
    property ServerName: string read FServerName write SetServerName;
    property AfterConnect;
    property AfterDisconnect;
    property BeforeConnect;
    property BeforeDisconnect;
    property OnGetUsername;
    property OnLogin;
    property QiSocketTransConnection:TQiSocketTransConnection read FQiSocketTransConnection write SetQiSocketTransConnection;
  end;

implementation
uses
  ActiveX, MidConst, RTLConsts, ZLIBEX;

procedure CheckSignature(Sig: Integer);
begin
  if (Sig and $FF00 <> CallSig) and
     (Sig and $FF00 <> ResultSig) then
    raise Exception.CreateRes(@SInvalidDataPacket);
end;
procedure GetDataBrokerList(List: TStringList; const RegCheck: string);

  function OpenRegKey(Key: HKey; const SubKey: string): HKey;
  begin
    if Windows.RegOpenKey(Key, PChar(SubKey), Result) <> 0 then Result := 0;
  end;

  function EnumRegKey(Key: HKey; Index: Integer; var Value: string): Boolean;
  var
    Buffer: array[0..255] of Char;
  begin
    Result := False;
    if Windows.RegEnumKey(Key, Index, Buffer, SizeOf(Buffer)) = 0 then
    begin
      Value := Buffer;
      Result := True;
    end;
  end;

  function QueryRegKey(Key: HKey; const SubKey: string;
    var Value: string): Boolean;
  var
    BufSize: Longint;
    Buffer: array[0..255] of Char;
  begin
    Result := False;
    BufSize := SizeOf(Buffer);
    if Windows.RegQueryValue(Key, PChar(SubKey), Buffer, BufSize) = 0 then
    begin
      Value := Buffer;
      Result := True;
    end;
  end;

  procedure CloseRegKey(Key: HKey);
  begin
    RegCloseKey(Key);
  end;

var
  I: Integer;
  ClassIDKey: HKey;
  ClassID, S: string;