hbcomsrv.pas

Midas.dll全部源码

{*******************************************************}
{                                                       }
{         Vladimir Gaitanoff HyperBase                  }
{                                                       }
{         COM objects registration                      }
{                                                       }
{         Copyright (c) , 1997, 1999                    }
{                                                       }
{*******************************************************}

{$I HB.INC}
{$D-,L-}

unit hbCOMSrv;

interface
uses ComObj;

procedure RegisterHBClient;
procedure RegisterDBClient;
procedure RegisterMidas;
procedure RegisterOnLibName;

var
  InternalFactory: Boolean;
  NoUpdateRegistry: Boolean;

implementation
uses Windows, hbCLSID, hbConsts, hbIntf, SysUtils, hbCore, hbStream, ComServ;

type
  THBComObjectFactory = class (TComObjectFactory)
  public
    constructor Create(ComServer: TComServerObject; ComClass: TComClass;
      const ClassID: TGUID; const ClassName, Description: string;
      Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle);
    procedure UpdateRegistry(Register: Boolean); override;
  end;

constructor THBComObjectFactory.Create(ComServer: TComServerObject; ComClass: TComClass;
  const ClassID: TGUID; const ClassName, Description: string;
  Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle);
begin
  if InternalFactory or not IsLibrary then
    Instancing := ciInternal;
  inherited Create(ComServer, ComClass, ClassID, ClassName, Description, Instancing, ThreadingModel);
end;

procedure THBComObjectFactory.UpdateRegistry(Register: Boolean);
begin
  if not NoUpdateRegistry then
    inherited UpdateRegistry(Register);
end;

procedure RegisterDSClasses(const Prefix: string; const ClassDSBase, ClassDSCursor, ClassDSWriter, ClassDSReader: TGUID);
begin
  THBComObjectFactory.Create(ComServer, TDSBase, ClassDSBase,
    Prefix + '.DSBase.2', 'HBase_DSBase_class', ciMultiInstance, tmSingle);

  THBComObjectFactory.Create(ComServer, TDSCursor, ClassDSCursor,
    Prefix + 'DSCursor.2', 'HBase_DSCursor_class', ciMultiInstance, tmSingle);

  THBComObjectFactory.Create(ComServer, TDSWriter, ClassDSWriter,
    Prefix + 'DSWriter', 'HBase_DSWriter_class', ciMultiInstance, tmSingle);

  THBComObjectFactory.Create(ComServer, TDSReader, ClassDSReader,
    Prefix + 'DSReader', 'HBase_DSReader_class', ciMultiInstance, tmSingle);
end;

procedure RegisterHBClient;
begin
  RegisterDSClasses(SHBClient, CLSID_HBDSBase, CLSID_HBDSCursor, CLSID_HBDSWriter, CLSID_HBDSReader);
end;

procedure RegisterDBClient;
begin
  RegisterDSClasses(SDBClient, CLSID_DBDSBase, CLSID_DBDSCursor, CLSID_DBDSWriter, CLSID_DBDSReader);

{ Obsolete CLSIDs }

  THBComObjectFactory.Create(ComServer, TDSBase, CLSID_DBDSBase1,
    'DSBase.1', 'HBase_DSBase_class_1', ciMultiInstance, tmSingle);

  THBComObjectFactory.Create(ComServer, TDSCursor, CLSID_DBDSCursor1,
    'DSCursor.1', 'HBase_DSCursor_class_1', ciMultiInstance, tmSingle);
end;

procedure RegisterMidas;
begin
  ComServer.LoadTypeLib;
  RegisterDSClasses(SMidas, CLSID_DBDSBase5, CLSID_DBDSCursor5, CLSID_DBDSWriter5, CLSID_DBDSReader);
end;

procedure RegisterOnLibName;
var
  ModuleName: array[0..255] of Char;
  LibName: string;
begin
  GetModuleFileName(HInstance, ModuleName, SizeOf(ModuleName));

  LibName := ExtractFileName(StrPas(ModuleName));

  if CompareText(LibName, SDBClientDll) = 0 then
    RegisterDBClient
  else if CompareText(LibName, SMidasDll) = 0 then
    RegisterMidas
  else
    RegisterHBClient;
end;

function HyperBaseTerminateProc: Boolean;
begin
  ComServer := nil;
  Result := True;
end;

initialization
  AddTerminateProc(HyperBaseTerminateProc);

end.