units/activekol/KOLComObj.pas

   1
   2 {*******************************************************}
   3 {                                                       }
   4 {       Borland Delphi Runtime Library                  }
   5 {       COM object support                              }
   6 {                                                       }
   7 {       Copyright (C) 1997,99 Inprise Corporation       }
   8 {                                                       }
   9 {*******************************************************}
  10
  11 unit KOLComObj;
  12
  13 {$I KOLDEF.INC}
  14 {$DEFINE NOWARNINGS}
  15
  16 interface
  17
  18 uses Windows, ActiveX, KOL, err {$IFDEF _D6orHigher}, Variants {$ENDIF};
  19
  20 type
  21 { Forward declarations }
  22
  23   TComObjectFactory = class;
  24
  25 { COM server abstract base class }
  26
  27   TComServerObject = class(TObject)
  28   protected
  29     function CountObject(Created: Boolean): Integer; virtual; abstract;
  30     function CountFactory(Created: Boolean): Integer; virtual; abstract;
  31     function GetHelpFileName: string; virtual; abstract;
  32     function GetServerFileName: string; virtual; abstract;
  33     function GetServerKey: string; virtual; abstract;
  34     function GetServerName: string; virtual; abstract;
  35     function GetStartSuspended: Boolean; virtual; abstract;
  36     function GetTypeLib: ITypeLib; virtual; abstract;
  37     procedure SetHelpFileName(const Value: string); virtual; abstract;
  38   public
  39     property HelpFileName: string read GetHelpFileName write SetHelpFileName;
  40     property ServerFileName: string read GetServerFileName;
  41     property ServerKey: string read GetServerKey;
  42     property ServerName: string read GetServerName;
  43     property TypeLib: ITypeLib read GetTypeLib;
  44     property StartSuspended: Boolean read GetStartSuspended;
  45   end;
  46
  47
  48 { TMultiReadExclusiveWriteSynchronizer minimizes thread serialization to gain
  49   read access to a resource shared among threads while still providing complete
  50   exclusivity to callers needing write access to the shared resource.
  51   (multithread shared reads, single thread exclusive write)
  52   Reading is allowed while owning a write lock.
  53   Read locks can be promoted to write locks.}
  54
  55   {$IFNDEF _D2orD3}
  56   TActiveThreadRecord = record
  57     ThreadID: Integer;
  58     RecursionCount: Integer;
  59   end;
  60   TActiveThreadArray = array of TActiveThreadRecord;
  61
  62   TMultiReadExclusiveWriteSynchronizer = class
  63   private
  64     FLock: TRTLCriticalSection;
  65     FReadExit: THandle;
  66     FCount: Integer;
  67     FSaveReadCount: Integer;
  68     FActiveThreads: TActiveThreadArray;
  69     FWriteRequestorID: Integer;
  70     FReallocFlag: Integer;
  71     FWriting: Boolean;
  72     function WriterIsOnlyReader: Boolean;
  73   public
  74     constructor Create;
  75     destructor Destroy; override;
  76     procedure BeginRead;
  77     procedure EndRead;
  78     procedure BeginWrite;
  79     procedure EndWrite;
  80   end;
  81   {$ENDIF}
  82
  83 { COM class manager }
  84
  85   TFactoryProc = procedure(Factory: TComObjectFactory) of object;
  86
  87   TComClassManager = class(TObject)
  88   private
  89     FFactoryList: TComObjectFactory;
  90     {$IFNDEF _D2orD3}
  91     FLock: TMultiReadExclusiveWriteSynchronizer;
  92     {$ENDIF}
  93     procedure AddObjectFactory(Factory: TComObjectFactory);
  94     procedure RemoveObjectFactory(Factory: TComObjectFactory);
  95   public
  96     constructor Create;
  97     destructor Destroy; override;
  98     procedure ForEachFactory(ComServer: TComServerObject;
  99       FactoryProc: TFactoryProc);
 100     function GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
 101     function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
 102   end;
 103
 104 { IServerExceptionHandler }
 105 { This interface allows you to report safecall exceptions that occur in a
 106   TComObject server to a third party, such as an object that logs errors into
 107   the system event log or a server monitor residing on another machine.
 108   Obtain an interface from the error logger implementation and assign it
 109   to your TComObject's ServerExceptionHandler property.  Each TComObject
 110   instance can have its own server exception handler, or all instances can
 111   share the same handler.  The server exception handler can override the
 112   TComObject's default exception handling by setting Handled to True and
 113   assigning an OLE HResult code to the HResult parameter.
 114 }
 115
 116   IServerExceptionHandler = interface
 117     ['{6A8D432B-EB81-11D1-AAB1-00C04FB16FBC}']
 118     procedure OnException(
 119       const ServerClass, ExceptionClass, ErrorMessage: WideString;
 120       ExceptAddr: Integer; const ErrorIID, ProgID: WideString;
 121       var Handled: Integer; var Result: HResult); dispid 2;
 122   end;
 123
 124 { COM object }
 125
 126   TComObject = class(TObject, IUnknown, ISupportErrorInfo)
 127   private
 128     FController: Pointer;
 129     FFactory: TComObjectFactory;
 130     FNonCountedObject: Boolean;
 131     FRefCount: Integer;
 132     FServerExceptionHandler: IServerExceptionHandler;
 133     function GetController: IUnknown;
 134   protected
 135     { IUnknown }
 136     function IUnknown.QueryInterface = ObjQueryInterface;
 137     function IUnknown._AddRef = ObjAddRef;
 138     function IUnknown._Release = ObjRelease;
 139     { IUnknown methods for other interfaces }
 140     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
 141     function _AddRef: Integer; stdcall;
 142     function _Release: Integer; stdcall;
 143     { ISupportErrorInfo }
 144     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
 145   public
 146     constructor Create;
 147     constructor CreateAggregated(const Controller: IUnknown);
 148     constructor CreateFromFactory(Factory: TComObjectFactory;
 149       const Controller: IUnknown);
 150     destructor Destroy; override;
 151     procedure Initialize; virtual;
 152     function ObjAddRef: Integer; virtual; stdcall;
 153     function ObjQueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
 154     function ObjRelease: Integer; virtual; stdcall;
 155     function SafeCallException(ExceptObject: TObject;
 156       ExceptAddr: Pointer): HResult; override;
 157     property Controller: IUnknown read GetController;
 158     property Factory: TComObjectFactory read FFactory;
 159     property RefCount: Integer read FRefCount;
 160     property ServerExceptionHandler: IServerExceptionHandler
 161       read FServerExceptionHandler write FServerExceptionHandler;
 162   end;
 163
 164 { COM class }
 165
 166   TComClass = class of TComObject;
 167
 168 { Instancing mode for COM classes }
 169
 170   TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance);
 171
 172 { Threading model supported by COM classes }
 173
 174   TThreadingModel = (tmSingle, tmApartment, tmFree, tmBoth);
 175
 176 { COM object factory }
 177
 178   {$IFDEF NOWARNINGS}
 179     {$WARNINGS OFF}
 180   {$ENDIF}
 181   TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2)
 182   private
 183     FNext: TComObjectFactory;
 184     FComServer: TComServerObject;
 185     FComClass: TClass;
 186     FClassID: TGUID;
 187     FClassName: string;
 188     FDescription: string;
 189     FErrorIID: TGUID;
 190     FInstancing: TClassInstancing;
 191     FLicString: WideString;
 192     FRegister: Longint;
 193     FShowErrors: Boolean;
 194     FSupportsLicensing: Boolean;
 195     FThreadingModel: TThreadingModel;
 196   protected
 197     function GetProgID: string; virtual;
 198     function GetLicenseString: WideString; virtual;
 199     function HasMachineLicense: Boolean; virtual;
 200     function ValidateUserLicense(const LicStr: WideString): Boolean; virtual;
 201     { IUnknown }
 202     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
 203     function _AddRef: Integer; stdcall;
 204     function _Release: Integer; stdcall;
 205     { IClassFactory }
 206     function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
 207       out Obj): HResult; stdcall;
 208     function LockServer(fLock: BOOL): HResult; stdcall;
 209     { IClassFactory2 }
 210     function GetLicInfo(var licInfo: TLicInfo): HResult; stdcall;
 211     function RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult; stdcall;
 212     function CreateInstanceLic(const unkOuter: IUnknown; const unkReserved: IUnknown;
 213       const iid: TIID; const bstrKey: WideString; out vObject): HResult; stdcall;
 214   public
 215     constructor Create(ComServer: TComServerObject; ComClass: TComClass;
 216       const ClassID: TGUID; const ClassName, Description: string;
 217       Instancing: TClassInstancing; ThreadingModel: TThreadingModel {= tmSingle} );
 218     destructor Destroy; override;
 219     function CreateComObject(const Controller: IUnknown): TComObject; virtual;
 220     procedure RegisterClassObject;
 221     procedure UpdateRegistry(Register: Boolean); virtual;
 222     property ClassID: TGUID read FClassID;
 223     property ClassName: string read FClassName;
 224     property ComClass: TClass read FComClass;
 225     property ComServer: TComServerObject read FComServer;
 226     property Description: string read FDescription;
 227     property ErrorIID: TGUID read FErrorIID write FErrorIID;
 228     property LicString: WideString read FLicString write FLicString;
 229     property ProgID: string read GetProgID;
 230     property Instancing: TClassInstancing read FInstancing;
 231     property ShowErrors: Boolean read FShowErrors write FShowErrors;
 232     property SupportsLicensing: Boolean read FSupportsLicensing write FSupportsLicensing;
 233     property ThreadingModel: TThreadingModel read FThreadingModel;
 234   end;
 235   {$IFDEF NOWARNINGS}
 236     {$WARNINGS ON}
 237   {$ENDIF}
 238
 239 { COM objects intended to be aggregated / contained }
 240
 241   TAggregatedObject = class
 242   private
 243     FController: Pointer;
 244     function GetController: IUnknown;
 245   protected
 246     { IUnknown }
 247     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
 248     function _AddRef: Integer; stdcall;
 249     function _Release: Integer; stdcall;
 250   public
 251     constructor Create(Controller: IUnknown);
 252     property Controller: IUnknown read GetController;
 253   end;
 254
 255   TContainedObject = class(TAggregatedObject, IUnknown)
 256   protected
 257     { IUnknown }
 258     function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
 259   end;
 260
 261 { COM object with type information }
 262
 263   TTypedComObject = class(TComObject, IProvideClassInfo)
 264   protected
 265     { IProvideClassInfo }
 266     function GetClassInfo(out TypeInfo: ITypeInfo): HResult; stdcall;
 267   end;
 268
 269   TTypedComClass = class of TTypedComObject;
 270
 271   {$IFDEF NOWARNINGS}
 272     {$WARNINGS OFF}
 273   {$ENDIF}
 274   TTypedComObjectFactory = class(TComObjectFactory)
 275   private
 276     FClassInfo: ITypeInfo;
 277   public
 278     constructor Create(ComServer: TComServerObject;
 279       TypedComClass: TTypedComClass; const ClassID: TGUID;
 280       Instancing: TClassInstancing; ThreadingModel: TThreadingModel {= tmSingle} );
 281     function GetInterfaceTypeInfo(TypeFlags: Integer): ITypeInfo;
 282     procedure UpdateRegistry(Register: Boolean); override;
 283     property ClassInfo: ITypeInfo read FClassInfo;
 284   end;
 285   {$IFDEF NOWARNINGS}
 286     {$WARNINGS ON}
 287   {$ENDIF}
 288
 289 { OLE Automation object }
 290
 291   TConnectEvent = procedure (const Sink: IUnknown; Connecting: Boolean) of object;
 292
 293   TAutoObjectFactory = class;
 294
 295   TAutoObject = class(TTypedComObject, IDispatch)
 296   private
 297     FEventSink: IUnknown;
 298     FAutoFactory: TAutoObjectFactory;
 299   protected
 300     { IDispatch }
 301     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
 302       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
 303     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
 304     function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
 305     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
 306       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;
 307     { Other methods }
 308     procedure EventConnect(const Sink: IUnknown; Connecting: Boolean);
 309     procedure EventSinkChanged(const EventSink: IUnknown); virtual;
 310     property AutoFactory: TAutoObjectFactory read FAutoFactory;
 311     property EventSink: IUnknown read FEventSink write FEventSink;
 312   public
 313     procedure Initialize; override;
 314   end;
 315
 316 { OLE Automation class }
 317
 318   TAutoClass = class of TAutoObject;
 319
 320 { OLE Automation object factory }
 321
 322   TAutoObjectFactory = class(TTypedComObjectFactory)
 323   private
 324     FDispTypeInfo: ITypeInfo;
 325     FDispIntfEntry: PInterfaceEntry;
 326     FEventIID: TGUID;
 327     FEventTypeInfo: ITypeInfo;
 328   public
 329     constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass;
 330       const ClassID: TGUID; Instancing: TClassInstancing;
 331       ThreadingModel: TThreadingModel {= tmSingle} );
 332     function GetIntfEntry(Guid: TGUID): PInterfaceEntry; virtual;
 333     property DispIntfEntry: PInterfaceEntry read FDispIntfEntry;
 334     property DispTypeInfo: ITypeInfo read FDispTypeInfo;
 335     property EventIID: TGUID read FEventIID;
 336     property EventTypeInfo: ITypeInfo read FEventTypeInfo;
 337   end;
 338
 339   TAutoIntfObject = class(TInterfacedObject, IDispatch, ISupportErrorInfo)
 340   private
 341     FDispTypeInfo: ITypeInfo;
 342     FDispIntfEntry: PInterfaceEntry;
 343     FDispIID: TGUID;
 344   protected
 345     { IDispatch }
 346     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
 347       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
 348     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
 349     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
 350     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
 351       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
 352     { ISupportErrorInfo }
 353     function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall;
 354   public
 355     constructor Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
 356     function SafeCallException(ExceptObject: TObject;
 357       ExceptAddr: Pointer): HResult; override;
 358     property DispIntfEntry: PInterfaceEntry read FDispIntfEntry;
 359     property DispTypeInfo: ITypeInfo read FDispTypeInfo;
 360     property DispIID: TGUID read FDispIID;
 361   end;
 362
 363 { OLE exception classes }
 364
 365   EOleError = Exception; // class(Exception);
 366
 367   EOleSysError = EOleError; { class(EOleError)
 368   private
 369     FErrorCode: HRESULT;
 370   public
 371     constructor Create(const Message: string; ErrorCode: HRESULT;
 372       HelpContext: Integer);
 373     property ErrorCode: HRESULT read FErrorCode write FErrorCode;
 374   end;}
 375
 376   EOleException = EOleSysError; { class(EOleSysError)
 377   private
 378     FSource: string;
 379     FHelpFile: string;
 380   public
 381     constructor Create(const Message: string; ErrorCode: HRESULT;
 382       const Source, HelpFile: string; HelpContext: Integer);
 383     property HelpFile: string read FHelpFile write FHelpFile;
 384     property Source: string read FSource write FSource;
 385   end;}
 386
 387   EOleRegistrationError = EOleError; { class(EOleError);}
 388
 389   { Dispatch call descriptor }
 390
 391   PCallDesc = ^TCallDesc;
 392   TCallDesc = packed record
 393     CallType: Byte;
 394     ArgCount: Byte;
 395     NamedArgCount: Byte;
 396     ArgTypes: array[0..255] of Byte;
 397   end;
 398
 399   PDispDesc = ^TDispDesc;
 400   TDispDesc = packed record
 401     DispID: Integer;
 402     ResType: Byte;
 403     CallDesc: TCallDesc;
 404   end;
 405
 406 procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
 407   DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
 408 procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
 409
 410 {function HandleSafeCallException(ExceptObject: TObject;
 411   ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
 412   HelpFileName: WideString): HResult;}
 413
 414 function CreateComObject(const ClassID: TGUID): IUnknown;
 415 function CreateRemoteComObject(const MachineName: WideString; const ClassID: TGUID): IUnknown;
 416 function CreateOleObject(const ClassName: string): IDispatch;
 417 function GetActiveOleObject(const ClassName: string): IDispatch;
 418
 419 procedure OleError(ErrorCode: HResult);
 420 procedure OleCheck(Result: HResult);
 421
 422 function StringToGUID(const S: string): TGUID;
 423 function GUIDToString(const ClassID: TGUID): string;
 424
 425 function ProgIDToClassID(const ProgID: string): TGUID;
 426 function ClassIDToProgID(const ClassID: TGUID): string;
 427
 428 procedure CreateRegKey(const Key, ValueName, Value: string);
 429 procedure DeleteRegKey(const Key: string);
 430 function GetRegStringValue(const Key, ValueName: string): string;
 431
 432 function StringToLPOLESTR(const Source: string): POleStr;
 433
 434 procedure RegisterComServer(const DLLName: string);
 435 procedure RegisterAsService(const ClassID, ServiceName: string);
 436
 437 function CreateClassID: string;
 438
 439 procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;
 440   const Sink: IUnknown; var Connection: Longint);
 441 procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;
 442   var Connection: Longint);
 443
 444 type
 445   TCoCreateInstanceExProc = function (const clsid: TCLSID;
 446     unkOuter: IUnknown; dwClsCtx: Longint; ServerInfo: PCoServerInfo;
 447     dwCount: Longint; rgmqResults: PMultiQIArray): HResult stdcall;
 448   TCoInitializeExProc = function (pvReserved: Pointer;
 449     coInit: Longint): HResult; stdcall;
 450   TCoAddRefServerProcessProc = function :Longint; stdcall;
 451   TCoReleaseServerProcessProc = function :Longint; stdcall;
 452   TCoResumeClassObjectsProc = function :HResult; stdcall;
 453   TCoSuspendClassObjectsProc = function :HResult; stdcall;
 454
 455 // COM functions that are only available on DCOM updated OSs
 456 // These pointers may be nil on Win95 or Win NT 3.51 systems
 457 var
 458   CoCreateInstanceEx: TCoCreateInstanceExProc = nil;
 459   CoInitializeEx: TCoInitializeExProc = nil;
 460   CoAddRefServerProcess: TCoAddRefServerProcessProc = nil;
 461   CoReleaseServerProcess: TCoReleaseServerProcessProc = nil;
 462   CoResumeClassObjects: TCoResumeClassObjectsProc = nil;
 463   CoSuspendClassObjects: TCoSuspendClassObjectsProc = nil;
 464
 465
 466 { CoInitFlags determines the COM threading model of the application or current
 467   thread. This bitflag value is passed to CoInitializeEx in ComServ initialization.
 468   Assign COINIT_APARTMENTTHREADED or COINIT_MULTITHREADED to this variable before
 469   Application.Initialize is called by the project source file to select a
 470   threading model.  Other CoInitializeEx flags (such as COINIT_SPEED_OVER_MEMORY)
 471   can be OR'd in also.  }
 472 var
 473   CoInitFlags: Integer = -1;  // defaults to no threading model, call CoInitialize()
 474
 475 function ComClassManager: TComClassManager;
 476
 477 implementation
 478
 479 resourcestring
 480   SCreateRegKeyError = 'Error creating system registry entry';
 481   SOleError = 'OLE error %.8x';
 482   SObjectFactoryMissing = 'Object factory for class %s missing';
 483   STypeInfoMissing = 'Type information missing for class %s';
 484   SBadTypeInfo = 'Incorrect type information for class %s';
 485   SDispIntfMissing = 'Dispatch interface missing from class %s';
 486   SNoMethod = 'Method ''%s'' not supported by automation object';
 487   SVarNotObject = 'Variant does not reference an automation object';
 488   SDCOMNotInstalled = 'DCOM not installed';
 489   SDAXError = 'DAX Error';
 490
 491   SAutomationWarning = 'COM Server Warning';
 492   SNoCloseActiveServer1 = 'There are still active COM objects in this ' +
 493     'application.  One or more clients may have references to these objects, ' +
 494     'so manually closing ';
 495   SNoCloseActiveServer2 = 'this application may cause those client ' +
 496     'application(s) to fail.'#13#10#13#10'Are you sure you want to close this ' +
 497     'application?';
 498
 499 var
 500   OleUninitializing: Boolean;
 501
 502 { Handle a safe call exception }
 503
 504 {function HandleSafeCallException(ExceptObject: TObject;
 505   ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID,
 506   HelpFileName: WideString): HResult;
 507 var
 508   E: TObject;
 509   CreateError: ICreateErrorInfo;
 510   ErrorInfo: IErrorInfo;
 511 begin
 512   Result := E_UNEXPECTED;
 513   E := ExceptObject;
 514   if Succeeded(CreateErrorInfo(CreateError)) then
 515   begin
 516     CreateError.SetGUID(ErrorIID);
 517     if ProgID <> '' then CreateError.SetSource(PWideChar(ProgID));
 518     if HelpFileName <> '' then CreateError.SetHelpFile(PWideChar(HelpFileName));
 519     if E is Exception then
 520     begin
 521       CreateError.SetDescription(PWideChar(WideString(Exception(E).Message)));
 522       CreateError.SetHelpContext(Exception(E).HelpContext);
 523       if (E is EOleSysError) and (EOleSysError(E).ErrorCode < 0) then
 524         Result := EOleSysError(E).ErrorCode;
 525     end;
 526     if CreateError.QueryInterface(IErrorInfo, ErrorInfo) = S_OK then
 527       SetErrorInfo(0, ErrorInfo);
 528   end;
 529 end;}
 530
 531 { TDispatchSilencer }
 532
 533 type
 534   TDispatchSilencer = class(TInterfacedObject, IUnknown, IDispatch)
 535   private
 536     Dispatch: IDispatch;
 537     DispIntfIID: TGUID;
 538   public
 539     constructor Create(ADispatch: IUnknown; const ADispIntfIID: TGUID);
 540     { IUnknown }
 541     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
 542     { IDispatch }
 543     function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
 544     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
 545     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
 546       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
 547     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
 548       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
 549   end;
 550
 551 constructor TDispatchSilencer.Create(ADispatch: IUnknown;
 552   const ADispIntfIID: TGUID);
 553 begin
 554   inherited Create;
 555   DispIntfIID := ADispIntfIID;
 556   OleCheck(ADispatch.QueryInterface(ADispIntfIID, Dispatch));
 557 end;
 558
 559 function TDispatchSilencer.QueryInterface(const IID: TGUID; out Obj): HResult;
 560 begin
 561   Result := inherited QueryInterface(IID, Obj);
 562   if Result = E_NOINTERFACE then
 563     if IsEqualGUID(IID, DispIntfIID) then
 564     begin
 565       IDispatch(Obj) := Self;
 566       Result := S_OK;
 567     end
 568     else
 569       Result := Dispatch.QueryInterface(IID, Obj);
 570 end;
 571
 572 function TDispatchSilencer.GetTypeInfoCount(out Count: Integer): HResult;
 573 begin
 574   Result := Dispatch.GetTypeInfoCount(Count);
 575 end;
 576
 577 function TDispatchSilencer.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
 578 begin
 579   Result := Dispatch.GetTypeInfo(Index, LocaleID, TypeInfo);
 580 end;
 581
 582 function TDispatchSilencer.GetIDsOfNames(const IID: TGUID; Names: Pointer;
 583   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
 584 begin
 585   Result := Dispatch.GetIDsOfNames(IID, Names, NameCount, LocaleID, DispIDs);
 586 end;
 587
 588 function TDispatchSilencer.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
 589   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
 590 begin
 591   { Ignore error since some containers, such as Internet Explorer 3.0x, will
 592     return error when the method was not handled, or scripting errors occur }
 593   Dispatch.Invoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo,
 594     ArgErr);
 595   Result := S_OK;
 596 end;
 597
 598 {$IFNDEF _D2orD3}
 599 { TMultiReadExclusiveWriteSynchronizer }
 600
 601 constructor TMultiReadExclusiveWriteSynchronizer.Create;
 602 begin
 603   inherited Create;
 604   InitializeCriticalSection(FLock);
 605   FReadExit := CreateEvent(nil, True, True, nil);  // manual reset, start signaled
 606   SetLength(FActiveThreads, 4);
 607 end;
 608
 609 destructor TMultiReadExclusiveWriteSynchronizer.Destroy;
 610 begin
 611   BeginWrite;
 612   inherited Destroy;
 613   CloseHandle(FReadExit);
 614   DeleteCriticalSection(FLock);
 615 end;
 616
 617 function TMultiReadExclusiveWriteSynchronizer.WriterIsOnlyReader: Boolean;
 618 var
 619   I, Len: Integer;
 620 begin
 621   Result := False;
 622   if FWriteRequestorID = 0 then Exit;
 623   // We know a writer is waiting for entry with the FLock locked,
 624   // so FActiveThreads is stable - no BeginRead could be resizing it now
 625   I := 0;
 626   Len := High(FActiveThreads);
 627   while (I < Len) and
 628     ((FActiveThreads[I].ThreadID = 0) or (FActiveThreads[I].ThreadID = FWriteRequestorID)) do
 629     Inc(I);
 630   Result := I >= Len;
 631 end;
 632
 633 procedure TMultiReadExclusiveWriteSynchronizer.BeginWrite;
 634 begin
 635   EnterCriticalSection(FLock);  // Block new read or write ops from starting
 636   if not FWriting then
 637   begin
 638     FWriteRequestorID := GetCurrentThreadID;   // Indicate that writer is waiting for entry
 639     if not WriterIsOnlyReader then              // See if any other thread is reading
 640       WaitForSingleObject(FReadExit, INFINITE); // Wait for current readers to finish
 641     FSaveReadCount := FCount;  // record prior read recursions for this thread
 642     FCount := 0;
 643     FWriteRequestorID := 0;
 644     FWriting := True;
 645   end;
 646   Inc(FCount);  // allow read recursions during write without signalling FReadExit event
 647 end;
 648
 649 procedure TMultiReadExclusiveWriteSynchronizer.EndWrite;
 650 begin
 651   Dec(FCount);
 652   if FCount = 0 then
 653   begin
 654     FCount := FSaveReadCount;  // restore read recursion count
 655     FSaveReadCount := 0;
 656     FWriting := False;
 657   end;
 658   LeaveCriticalSection(FLock);
 659 end;
 660
 661 procedure TMultiReadExclusiveWriteSynchronizer.BeginRead;
 662 var
 663   I: Integer;
 664   ThreadID: Integer;
 665   ZeroSlot: Integer;
 666   AlreadyInRead: Boolean;
 667 begin
 668   ThreadID := GetCurrentThreadID;
 669   // First, do a lightweight check to see if this thread already has a read lock
 670   while InterlockedExchange(FReallocFlag, ThreadID) <> 0 do  Sleep(0);
 671   try    // FActiveThreads array is now stable
 672     I := 0;
 673     while (I < High(FActiveThreads)) and (FActiveThreads[I].ThreadID <> ThreadID) do
 674       Inc(I);
 675     AlreadyInRead := I < High(FActiveThreads);
 676     if AlreadyInRead then  // This thread already has a read lock
 677     begin                   // Don't grab FLock, since that could deadlock with
 678       if not FWriting then  // a waiting BeginWrite
 679       begin                 // Bump up ref counts and exit
 680         InterlockedIncrement(FCount);
 681         Inc(FActiveThreads[I].RecursionCount); // thread safe = unique to threadid
 682       end;
 683     end
 684   finally
 685     FReallocFlag := 0;
 686   end;
 687   if not AlreadyInRead then
 688   begin   // Ok, we don't already have a lock, so do the hard work of making one
 689     EnterCriticalSection(FLock);
 690     try
 691       if not FWriting then
 692       begin
 693         // This will call ResetEvent more than necessary on win95, but still work
 694         if InterlockedIncrement(FCount) = 1 then
 695           ResetEvent(FReadExit); // Make writer wait until all readers are finished.
 696         I := 0;  // scan for empty slot in activethreads list
 697         ZeroSlot := -1;
 698         while (I < High(FActiveThreads)) and (FActiveThreads[I].ThreadID <> ThreadID) do
 699         begin
 700           if (FActiveThreads[I].ThreadID = 0) and (ZeroSlot < 0) then ZeroSlot := I;
 701           Inc(I);
 702         end;
 703         if I >= High(FActiveThreads) then  // didn't find our threadid slot
 704         begin
 705           if ZeroSlot < 0 then  // no slots available.  Grow array to make room
 706           begin   // spin loop.  wait for EndRead to put zero back into FReallocFlag
 707             while InterlockedExchange(FReallocFlag, ThreadID) <> 0 do  Sleep(0);
 708             try
 709               SetLength(FActiveThreads, High(FActiveThreads) + 3);
 710             finally
 711               FReallocFlag := 0;
 712             end;
 713           end
 714           else  // use an empty slot
 715             I := ZeroSlot;
 716           // no concurrency issue here.  We're the only thread interested in this record.
 717           FActiveThreads[I].ThreadID := ThreadID;
 718           FActiveThreads[I].RecursionCount := 1;
 719         end
 720         else  // found our threadid slot.
 721           Inc(FActiveThreads[I].RecursionCount); // thread safe = unique to threadid
 722       end;
 723     finally
 724       LeaveCriticalSection(FLock);
 725     end;
 726   end;
 727 end;
 728
 729 procedure TMultiReadExclusiveWriteSynchronizer.EndRead;
 730 var
 731   I, ThreadID, Len: Integer;
 732 begin
 733   if not FWriting then
 734   begin
 735     // Remove our threadid from the list of active threads
 736     I := 0;
 737     ThreadID := GetCurrentThreadID;
 738     // wait for BeginRead to finish any pending realloc of FActiveThreads
 739     while InterlockedExchange(FReallocFlag, ThreadID) <> 0 do  Sleep(0);
 740     try
 741       Len := High(FActiveThreads);
 742       while (I < Len) and (FActiveThreads[I].ThreadID <> ThreadID) do Inc(I);
 743       assert(I < Len);
 744       // no concurrency issues here.  We're the only thread interested in this record.
 745       Dec(FActiveThreads[I].RecursionCount); // threadsafe = unique to threadid
 746       if FActiveThreads[I].RecursionCount = 0 then
 747         FActiveThreads[I].ThreadID := 0; // must do this last!
 748     finally
 749       FReallocFlag := 0;
 750     end;
 751     if (InterlockedDecrement(FCount) = 0) or WriterIsOnlyReader then
 752       SetEvent(FReadExit);     // release next writer
 753   end;
 754 end;
 755
 756 procedure FreeAndNil(var Obj);
 757 var
 758   P: TObject;
 759 begin
 760   P := TObject(Obj);
 761   TObject(Obj) := nil;  // clear the reference before destroying the object
 762   P.Free;
 763 end;
 764 {$ENDIF}
 765
 766 { TComClassManager }
 767 constructor TComClassManager.Create;
 768 begin
 769   inherited Create;
 770   {$IFNDEF _D2orD3}
 771   FLock := TMultiReadExclusiveWriteSynchronizer.Create;
 772   {$ENDIF}
 773 end;
 774
 775 destructor TComClassManager.Destroy;
 776 begin
 777   {$IFNDEF _D2orD3}
 778   FLock.Free;
 779   {$ENDIF}
 780   inherited Destroy;
 781 end;
 782
 783 procedure TComClassManager.AddObjectFactory(Factory: TComObjectFactory);
 784 begin
 785   {$IFNDEF _D2orD3}
 786   FLock.BeginWrite;
 787   try
 788   {$ENDIF}
 789     Factory.FNext := FFactoryList;
 790     FFactoryList := Factory;
 791   {$IFNDEF _D2orD3}
 792   finally
 793     FLock.EndWrite;
 794   end;
 795   {$ENDIF}
 796 end;
 797
 798 procedure TComClassManager.ForEachFactory(ComServer: TComServerObject;
 799   FactoryProc: TFactoryProc);
 800 var
 801   Factory, Next: TComObjectFactory;
 802 begin
 803   {$IFNDEF _D2orD3}
 804   FLock.BeginWrite;  // FactoryProc could add or delete factories from list
 805   try
 806   {$ENDIF}
 807     Factory := FFactoryList;
 808     while Factory <> nil do
 809     begin
 810       Next := Factory.FNext;
 811       if Factory.ComServer = ComServer then FactoryProc(Factory);
 812       Factory := Next;
 813     end;
 814   {$IFNDEF _D2orD3}
 815   finally
 816     FLock.EndWrite;
 817   end;
 818   {$ENDIF}
 819 end;
 820
 821 function TComClassManager.GetFactoryFromClass(ComClass: TClass): TComObjectFactory;
 822 begin
 823   {$IFNDEF _D2orD3}
 824   FLock.BeginRead;
 825   try
 826   {$ENDIF}
 827     Result := FFactoryList;
 828     while Result <> nil do
 829     begin
 830       if Result.ComClass = ComClass then Exit;
 831       Result := Result.FNext;
 832     end;
 833     raise EOleError.CreateResFmt(e_Ole, Integer( @SObjectFactoryMissing ), [ComClass.ClassName]);
 834   {$IFNDEF _D2orD3}
 835   finally
 836     FLock.EndRead;
 837   end;
 838   {$ENDIF}
 839 end;
 840
 841 function TComClassManager.GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory;
 842 begin
 843   {$IFNDEF _D2orD3}
 844   FLock.BeginRead;
 845   try
 846   {$ENDIF}
 847     Result := FFactoryList;
 848     while Result <> nil do
 849     begin
 850       if IsEqualGUID(Result.ClassID, ClassID) then Exit;
 851       Result := Result.FNext;
 852     end;
 853   {$IFNDEF _D2orD3}
 854   finally
 855     FLock.EndRead;
 856   end;
 857   {$ENDIF}
 858 end;
 859
 860 procedure TComClassManager.RemoveObjectFactory(Factory: TComObjectFactory);
 861 var
 862   F, P: TComObjectFactory;
 863 begin
 864   {$IFNDEF _D2orD3}
 865   FLock.BeginWrite;
 866   try
 867   {$ENDIF}
 868     P := nil;
 869     F := FFactoryList;
 870     while F <> nil do
 871     begin
 872       if F = Factory then
 873       begin
 874         if P <> nil then P.FNext := F.FNext else FFactoryList := F.FNext;
 875         Exit;
 876       end;
 877       P := F;
 878       F := F.FNext;
 879     end;
 880   {$IFNDEF _D2orD3}
 881   finally
 882     FLock.EndWrite;
 883   end;
 884   {$ENDIF}
 885 end;
 886
 887 { TComObject }
 888
 889 constructor TComObject.Create;
 890 begin
 891   FNonCountedObject := True;
 892   CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType), nil);
 893 end;
 894
 895 constructor TComObject.CreateAggregated(const Controller: IUnknown);
 896 begin
 897   FNonCountedObject := True;
 898   CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType), Controller);
 899 end;
 900
 901 constructor TComObject.CreateFromFactory(Factory: TComObjectFactory;
 902   const Controller: IUnknown);
 903 begin
 904   FRefCount := 1;
 905   FFactory := Factory;
 906   FController := Pointer(Controller);
 907   if not FNonCountedObject then FFactory.ComServer.CountObject(True);
 908   Initialize;
 909   Dec(FRefCount);
 910 end;
 911
 912 destructor TComObject.Destroy;
 913 begin
 914   if not OleUninitializing then
 915   begin
 916     if (FFactory <> nil) and not FNonCountedObject then
 917       FFactory.ComServer.CountObject(False);
 918     if FRefCount > 0 then CoDisconnectObject(Self, 0);
 919   end;
 920 end;
 921
 922 function TComObject.GetController: IUnknown;
 923 begin
 924   Result := IUnknown(FController);
 925 end;
 926
 927 procedure TComObject.Initialize;
 928 begin
 929 end;
 930
 931 function TComObject.SafeCallException(ExceptObject: TObject;
 932   ExceptAddr: Pointer): HResult;
 933 var
 934   Msg: string;
 935   Handled: Integer;
 936 begin
 937   Handled := 0;
 938   if ServerExceptionHandler <> nil then
 939   begin
 940     if ExceptObject is Exception then
 941       Msg := Exception(ExceptObject).Message;
 942     Result := 0;
 943     ServerExceptionHandler.OnException(ClassName,
 944       ExceptObject.ClassName, Msg, Integer(ExceptAddr),
 945       WideString(GUIDToString(FFactory.ErrorIID)),
 946       FFactory.ProgID, Handled, Result);
 947   end;
 948   if Handled = 0 then
 949     {Result := HandleSafeCallException(ExceptObject, ExceptAddr,
 950       FFactory.ErrorIID, FFactory.ProgID, FFactory.ComServer.HelpFileName);}
 951 end;
 952
 953 { TComObject.IUnknown }
 954
 955 function TComObject.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
 956 begin
 957   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
 958 end;
 959
 960 function TComObject.ObjAddRef: Integer;
 961 begin
 962   Result := InterlockedIncrement(FRefCount);
 963 end;
 964
 965 function TComObject.ObjRelease: Integer;
 966 begin
 967   // InterlockedDecrement returns only 0 or 1 on Win95 and NT 3.51
 968   // returns actual result on NT 4.0
 969   Result := InterlockedDecrement(FRefCount);
 970   if Result = 0 then Destroy;
 971 end;
 972
 973 { TComObject.IUnknown for other interfaces }
 974
 975 function TComObject.QueryInterface(const IID: TGUID; out Obj): HResult;
 976 begin
 977   if FController <> nil then
 978     Result := IUnknown(FController).QueryInterface(IID, Obj) else
 979     Result := ObjQueryInterface(IID, Obj);
 980 end;
 981
 982 function TComObject._AddRef: Integer;
 983 begin
 984   if FController <> nil then
 985     Result := IUnknown(FController)._AddRef else
 986     Result := ObjAddRef;
 987 end;
 988
 989 function TComObject._Release: Integer;
 990 begin
 991   if FController <> nil then
 992     Result := IUnknown(FController)._Release else
 993     Result := ObjRelease;
 994 end;
 995
 996 { TComObject.ISupportErrorInfo }
 997
 998 function TComObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
 999 begin
1000   if GetInterfaceEntry(iid) <> nil then
1001     Result := S_OK else
1002     Result := S_FALSE;
1003 end;
1004
1005 { TComObjectFactory }
1006
1007 constructor TComObjectFactory.Create(ComServer: TComServerObject;
1008   ComClass: TComClass; const ClassID: TGUID; const ClassName,
1009   Description: string; Instancing: TClassInstancing;
1010   ThreadingModel: TThreadingModel);
1011 begin
1012   IsMultiThread := IsMultiThread or (ThreadingModel <> tmSingle);
1013   if ThreadingModel in [tmFree, tmBoth] then
1014     CoInitFlags := COINIT_MULTITHREADED else
1015   if (ThreadingModel = tmApartment) and (CoInitFlags <> COINIT_MULTITHREADED) then
1016     CoInitFlags := COINIT_APARTMENTTHREADED;
1017   ComClassManager.AddObjectFactory(Self);
1018   FComServer := ComServer;
1019   FComClass := ComClass;
1020   FClassID := ClassID;
1021   FClassName := ClassName;
1022   FDescription := Description;
1023   FInstancing := Instancing;
1024   FErrorIID := IUnknown;
1025   FShowErrors := True;
1026   FThreadingModel := ThreadingModel;
1027   FRegister := -1;
1028 end;
1029
1030 destructor TComObjectFactory.Destroy;
1031 begin
1032   if FRegister <> -1 then CoRevokeClassObject(FRegister);
1033   ComClassManager.RemoveObjectFactory(Self);
1034 end;
1035
1036 function TComObjectFactory.CreateComObject(const Controller: IUnknown): TComObject;
1037 begin
1038   Result := TComClass(FComClass).CreateFromFactory(Self, Controller);
1039 end;
1040
1041 function TComObjectFactory.GetProgID: string;
1042 begin
1043   if FClassName <> '' then
1044     Result := FComServer.ServerName + '.' + FClassName else
1045     Result := '';
1046 end;
1047
1048 procedure TComObjectFactory.RegisterClassObject;
1049 const
1050   RegFlags: array[ciSingleInstance..ciMultiInstance] of Integer = (
1051     REGCLS_SINGLEUSE, REGCLS_MULTIPLEUSE);
1052   SuspendedFlag: array[Boolean] of Integer = (0, REGCLS_SUSPENDED);
1053 begin
1054   if FInstancing <> ciInternal then
1055     OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER,
1056       RegFlags[FInstancing] or SuspendedFlag[FComServer.StartSuspended], FRegister));
1057 end;
1058
1059 procedure TComObjectFactory.UpdateRegistry(Register: Boolean);
1060 const
1061   ThreadStrs: array[TThreadingModel] of string =
1062     ('', 'Apartment', 'Free', 'Both');
1063 var
1064   ClassID, ProgID, ServerKeyName, ShortFileName: string;
1065 begin
1066   if FInstancing = ciInternal then Exit;
1067   ClassID := GUIDToString(FClassID);
1068   ProgID := GetProgID;
1069   ServerKeyName := 'CLSID\' + ClassID + '\' + FComServer.ServerKey;
1070   if Register then
1071   begin
1072     CreateRegKey('CLSID\' + ClassID, '', Description);
1073     ShortFileName := FComServer.ServerFileName;
1074     if {Ansi}Pos(' ', ShortFileName) <> 0 then
1075       ShortFileName := ExtractShortPathName(ShortFileName);
1076     CreateRegKey(ServerKeyName, '', ShortFileName);
1077     if (FThreadingModel <> tmSingle) and IsLibrary then
1078       CreateRegKey(ServerKeyName, 'ThreadingModel', ThreadStrs[FThreadingModel]);
1079     if ProgID <> '' then
1080     begin
1081       CreateRegKey(ProgID, '', Description);
1082       CreateRegKey(ProgID + '\Clsid', '', ClassID);
1083       CreateRegKey('CLSID\' + ClassID + '\ProgID', '', ProgID);
1084     end;
1085   end else
1086   begin
1087     if ProgID <> '' then
1088     begin
1089       DeleteRegKey('CLSID\' + ClassID + '\ProgID');
1090       DeleteRegKey(ProgID + '\Clsid');
1091       DeleteRegKey(ProgID);
1092     end;
1093     DeleteRegKey(ServerKeyName);
1094     DeleteRegKey('CLSID\' + ClassID);
1095   end;
1096 end;
1097
1098 function TComObjectFactory.GetLicenseString: WideString;
1099 begin
1100   if FSupportsLicensing then Result := FLicString
1101   else Result := '';
1102 end;
1103
1104 function TComObjectFactory.HasMachineLicense: Boolean;
1105 begin
1106   Result := True;
1107 end;
1108
1109 function TComObjectFactory.ValidateUserLicense(const LicStr: WideString): Boolean;
1110 begin
1111   Result := AnsiCompareText(LicStr, FLicString) = 0;
1112 end;
1113
1114 { TComObjectFactory.IUnknown }
1115
1116 function TComObjectFactory.QueryInterface(const IID: TGUID; out Obj): HResult;
1117 begin
1118   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
1119 end;
1120
1121 function TComObjectFactory._AddRef: Integer;
1122 begin
1123   Result := ComServer.CountFactory(True);
1124 end;
1125
1126 function TComObjectFactory._Release: Integer;
1127 begin
1128   Result := ComServer.CountFactory(False);
1129 end;
1130
1131 { TComObjectFactory.IClassFactory }
1132
1133 function TComObjectFactory.CreateInstance(const UnkOuter: IUnknown;
1134   const IID: TGUID; out Obj): HResult;
1135 begin
1136   Result := CreateInstanceLic(UnkOuter, nil, IID, '', Obj);
1137 end;
1138
1139 function TComObjectFactory.LockServer(fLock: BOOL): HResult;
1140 begin
1141   Result := CoLockObjectExternal(Self, fLock, True);
1142   // Keep com server alive until this class factory is unlocked
1143   ComServer.CountObject(fLock);
1144 end;
1145
1146 { TComObjectFactory.IClassFactory2 }
1147
1148 function TComObjectFactory.GetLicInfo(var licInfo: TLicInfo): HResult;
1149 begin
1150   Result := S_OK;
1151   try
1152     with licInfo do
1153     begin
1154       cbLicInfo := SizeOf(licInfo);
1155       fRuntimeKeyAvail := (not FSupportsLicensing) or (GetLicenseString <> '');
1156       fLicVerified := (not FSupportsLicensing) or HasMachineLicense;
1157     end;
1158   except
1159     Result := E_UNEXPECTED;
1160   end;
1161 end;
1162
1163 function TComObjectFactory.RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult;
1164 begin
1165   // Can't give away a license key on an unlicensed machine
1166   if not HasMachineLicense then
1167   begin
1168     Result := CLASS_E_NOTLICENSED;
1169     Exit;
1170   end;
1171   bstrKey := FLicString;
1172   Result := NOERROR;
1173 end;
1174
1175 function TComObjectFactory.CreateInstanceLic(const unkOuter: IUnknown;
1176   const unkReserved: IUnknown; const iid: TIID; const bstrKey: WideString;
1177   out vObject): HResult; stdcall;
1178 var
1179   ComObject: TComObject;
1180 begin
1181   // We can't write to a nil pointer.  Duh.
1182   if @vObject = nil then
1183   begin
1184     Result := E_POINTER;
1185     Exit;
1186   end;
1187   // In case of failure, make sure we return at least a nil interface.
1188   Pointer(vObject) := nil;
1189   // Check for licensing.
1190   if FSupportsLicensing and
1191     ((bstrKey <> '') and (not ValidateUserLicense(bstrKey))) or
1192     ((bstrKey = '') and (not HasMachineLicense)) then
1193   begin
1194     Result := CLASS_E_NOTLICENSED;
1195     Exit;
1196   end;
1197   // We can only aggregate if they are requesting our IUnknown.
1198   if (unkOuter <> nil) and not (IsEqualIID(iid, IUnknown)) then
1199   begin
1200     Result := CLASS_E_NOAGGREGATION;
1201     Exit;
1202   end;
1203   try
1204     ComObject := CreateComObject(UnkOuter);
1205   except
1206     if FShowErrors and (ExceptObject is Exception) then
1207       with Exception(ExceptObject) do
1208       begin
1209         {if (Message <> '') and (AnsiLastChar(Message) > '.') then
1210           Message := Message + '.';}
1211         MessageBox(0, PChar(Message), PChar(SDAXError), MB_OK or MB_ICONSTOP or
1212           MB_SETFOREGROUND);
1213       end;
1214     Result := E_UNEXPECTED;
1215     Exit;
1216   end;
1217   Result := ComObject.ObjQueryInterface(IID, vObject);
1218   if ComObject.RefCount = 0 then ComObject.Free;
1219 end;
1220
1221 { TAggregatedObject }
1222
1223 constructor TAggregatedObject.Create(Controller: IUnknown);
1224 begin
1225   FController := Pointer(Controller);
1226 end;
1227
1228 function TAggregatedObject.GetController: IUnknown;
1229 begin
1230   Result := IUnknown(FController);
1231 end;
1232
1233 { TAggregatedObject.IUnknown }
1234
1235 function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
1236 begin
1237   Result := IUnknown(FController).QueryInterface(IID, Obj);
1238 end;
1239
1240 function TAggregatedObject._AddRef: Integer;
1241 begin
1242   Result := IUnknown(FController)._AddRef;
1243 end;
1244
1245 function TAggregatedObject._Release: Integer; stdcall;
1246 begin
1247   Result := IUnknown(FController)._Release;
1248 end;
1249
1250 { TContainedObject.IUnknown }
1251
1252 function TContainedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
1253 begin
1254   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
1255 end;
1256
1257 { TTypedComObject.IProvideClassInfo }
1258
1259 function TTypedComObject.GetClassInfo(out TypeInfo: ITypeInfo): HResult;
1260 begin
1261   TypeInfo := TTypedComObjectFactory(FFactory).FClassInfo;
1262   Result := S_OK;
1263 end;
1264
1265 { TTypedComObjectFactory }
1266
1267 constructor TTypedComObjectFactory.Create(ComServer: TComServerObject;
1268   TypedComClass: TTypedComClass; const ClassID: TGUID;
1269   Instancing: TClassInstancing; ThreadingModel: TThreadingModel);
1270 var
1271   ClassName, Description: WideString;
1272 begin
1273   if ComServer.TypeLib.GetTypeInfoOfGUID(ClassID, FClassInfo) <> S_OK then
1274     raise EOleError.CreateResFmt(e_Ole, Integer(@STypeInfoMissing), [TypedComClass.ClassName]);
1275   OleCheck(FClassInfo.GetDocumentation(MEMBERID_NIL, @ClassName,
1276     @Description, nil, nil));
1277   inherited Create(ComServer, TypedComClass, ClassID,
1278     ClassName, Description, Instancing, ThreadingModel);
1279 end;
1280
1281 function TTypedComObjectFactory.GetInterfaceTypeInfo(
1282   TypeFlags: Integer): ITypeInfo;
1283 const
1284   FlagsMask = IMPLTYPEFLAG_FDEFAULT or IMPLTYPEFLAG_FSOURCE;
1285 var
1286   ClassAttr: PTypeAttr;
1287   I, TypeInfoCount, Flags: Integer;
1288   RefType: HRefType;
1289 begin
1290   OleCheck(FClassInfo.GetTypeAttr(ClassAttr));
1291   TypeInfoCount := ClassAttr^.cImplTypes;
1292   ClassInfo.ReleaseTypeAttr(ClassAttr);
1293   for I := 0 to TypeInfoCount - 1 do
1294   begin
1295     OleCheck(ClassInfo.GetImplTypeFlags(I, Flags));
1296     if Flags and FlagsMask = TypeFlags then
1297     begin
1298       OleCheck(ClassInfo.GetRefTypeOfImplType(I, RefType));
1299       OleCheck(ClassInfo.GetRefTypeInfo(RefType, Result));
1300       Exit;
1301     end;
1302   end;
1303   Result := nil;
1304 end;
1305
1306 procedure TTypedComObjectFactory.UpdateRegistry(Register: Boolean);
1307 var
1308   ClassKey: string;
1309   TypeLib: ITypeLib;
1310   TLibAttr: PTLibAttr;
1311 begin
1312   ClassKey := 'CLSID\' + GUIDToString(FClassID);
1313   if Register then
1314   begin
1315     inherited UpdateRegistry(Register);
1316     TypeLib := FComServer.TypeLib;
1317     OleCheck(TypeLib.GetLibAttr(TLibAttr));
1318     try
1319       CreateRegKey(ClassKey + '\Version', '', Format('%d.%d',
1320         [TLibAttr.wMajorVerNum, TLibAttr.wMinorVerNum]));
1321       CreateRegKey(ClassKey + '\TypeLib', '', GUIDToString(TLibAttr.guid));
1322     finally
1323       TypeLib.ReleaseTLibAttr(TLibAttr);
1324     end;
1325   end else
1326   begin
1327     DeleteRegKey(ClassKey + '\TypeLib');
1328     DeleteRegKey(ClassKey + '\Version');
1329     inherited UpdateRegistry(Register);
1330   end;
1331 end;
1332
1333 { TAutoObject }
1334
1335 procedure TAutoObject.EventConnect(const Sink: IUnknown;
1336   Connecting: Boolean);
1337 begin
1338   if Connecting then
1339   begin
1340     OleCheck(Sink.QueryInterface(FAutoFactory.FEventIID, FEventSink));
1341     EventSinkChanged(TDispatchSilencer.Create(Sink, FAutoFactory.FEventIID));
1342   end
1343   else
1344   begin
1345     FEventSink := nil;
1346     EventSinkChanged(nil);
1347   end;
1348 end;
1349
1350 procedure TAutoObject.EventSinkChanged(const EventSink: IUnknown);
1351 begin
1352 end;
1353
1354 procedure TAutoObject.Initialize;
1355 begin
1356   FAutoFactory := Factory as TAutoObjectFactory;
1357   inherited Initialize;
1358 end;
1359
1360 { TAutoObject.IDispatch }
1361
1362 function TAutoObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
1363   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
1364 begin
1365   Result := DispGetIDsOfNames(FAutoFactory.DispTypeInfo,
1366     Names, NameCount, DispIDs);
1367 end;
1368
1369 function TAutoObject.GetTypeInfo(Index, LocaleID: Integer;
1370   out TypeInfo): HResult;
1371 begin
1372   Pointer(TypeInfo) := nil;
1373   if Index <> 0 then
1374   begin
1375     Result := DISP_E_BADINDEX;
1376     Exit;
1377   end;
1378   ITypeInfo(TypeInfo) := TAutoObjectFactory(Factory).DispTypeInfo;
1379   Result := S_OK;
1380 end;
1381
1382 function TAutoObject.GetTypeInfoCount(out Count: Integer): HResult;
1383 begin
1384   Count := 1;
1385   Result := S_OK;
1386 end;
1387
1388 function TAutoObject.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
1389   Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
1390 const
1391   INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
1392 begin
1393   if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
1394   Result := TAutoObjectFactory(Factory).DispTypeInfo.Invoke(Pointer(
1395     Integer(Self) + TAutoObjectFactory(Factory).DispIntfEntry.IOffset),
1396     DispID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr);
1397 end;
1398
1399 { TAutoObjectFactory }
1400
1401 constructor TAutoObjectFactory.Create(ComServer: TComServerObject;
1402   AutoClass: TAutoClass; const ClassID: TGUID;
1403   Instancing: TClassInstancing; ThreadingModel: TThreadingModel);
1404 var
1405   TypeAttr: PTypeAttr;
1406 begin
1407   inherited Create(ComServer, AutoClass, ClassID, Instancing, ThreadingModel);
1408   FDispTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT);
1409   if FDispTypeInfo = nil then
1410     raise EOleError.CreateResFmt(e_Ole, Integer(@SBadTypeInfo), [AutoClass.ClassName]);
1411   OleCheck(FDispTypeInfo.GetTypeAttr(TypeAttr));
1412   FDispIntfEntry := GetIntfEntry(TypeAttr^.guid);
1413   FDispTypeInfo.ReleaseTypeAttr(TypeAttr);
1414   if FDispIntfEntry = nil then
1415     raise EOleError.CreateResFmt(e_Ole, Integer(@SDispIntfMissing),
1416           [AutoClass.ClassName]);
1417   FErrorIID := FDispIntfEntry^.IID;
1418   FEventTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT or
1419     IMPLTYPEFLAG_FSOURCE);
1420   if FEventTypeInfo <> nil then
1421   begin
1422     OleCheck(FEventTypeInfo.GetTypeAttr(TypeAttr));
1423     FEventIID := TypeAttr.guid;
1424     FEventTypeInfo.ReleaseTypeAttr(TypeAttr);
1425   end;
1426 end;
1427
1428 function TAutoObjectFactory.GetIntfEntry(Guid: TGUID): PInterfaceEntry;
1429 begin
1430   Result := FComClass.GetInterfaceEntry(Guid);
1431 end;
1432
1433 { TAutoIntfObject }
1434
1435 constructor TAutoIntfObject.Create(const TypeLib: ITypeLib; const DispIntf: TGUID);
1436 begin
1437   inherited Create;
1438   OleCheck(TypeLib.GetTypeInfoOfGuid(DispIntf, FDispTypeInfo));
1439   FDispIntfEntry := GetInterfaceEntry(DispIntf);
1440 end;
1441
1442 { TAutoIntfObject.IDispatch }
1443
1444 function TAutoIntfObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
1445   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
1446 begin
1447   Result := DispGetIDsOfNames(FDispTypeInfo, Names, NameCount, DispIDs);
1448 end;
1449
1450 function TAutoIntfObject.GetTypeInfo(Index, LocaleID: Integer;
1451   out TypeInfo): HResult;
1452 begin
1453   Pointer(TypeInfo) := nil;
1454   if Index <> 0 then
1455   begin
1456     Result := DISP_E_BADINDEX;
1457     Exit;
1458   end;
1459   ITypeInfo(TypeInfo) := FDispTypeInfo;
1460   Result := S_OK;
1461 end;
1462
1463 function TAutoIntfObject.GetTypeInfoCount(out Count: Integer): HResult;
1464 begin
1465   Count := 1;
1466   Result := S_OK;
1467 end;
1468
1469 function TAutoIntfObject.Invoke(DispID: Integer; const IID: TGUID;
1470   LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
1471   ArgErr: Pointer): HResult;
1472 const
1473   INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
1474 begin
1475   if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
1476   Result := FDispTypeInfo.Invoke(Pointer(Integer(Self) +
1477     FDispIntfEntry.IOffset), DispID, Flags, TDispParams(Params), VarResult,
1478     ExcepInfo, ArgErr);
1479 end;
1480
1481 function TAutoIntfObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult;
1482 begin
1483   if IsEqualGUID(DispIID, iid) then
1484     Result := S_OK else
1485     Result := S_FALSE;
1486 end;
1487
1488 function TAutoIntfObject.SafeCallException(ExceptObject: TObject;
1489   ExceptAddr: Pointer): HResult;
1490 begin
1491   Result := 0; { HandleSafeCallException(ExceptObject, ExceptAddr, DispIID, '', ''); }
1492 end;
1493
1494 const
1495 { Maximum number of dispatch arguments }
1496
1497   MaxDispArgs = 64; {!!!}
1498
1499 { Special variant type codes }
1500
1501   varStrArg = $0048;
1502
1503 { Parameter type masks }
1504
1505   atVarMask  = $3F;
1506   atTypeMask = $7F;
1507   atByRef    = $80;
1508
1509 {function TrimPunctuation(const S: string): string;
1510 var
1511   P: PChar;
1512 begin
1513   Result := S;
1514   P := AnsiLastChar(Result);
1515   while (Length(Result) > 0) and (P^ in [#0..#32, '.']) do
1516   begin
1517     SetLength(Result, P - PChar(Result));
1518     P := AnsiLastChar(Result);
1519   end;
1520 end;}
1521
1522 { EOleSysError }
1523
1524 {constructor EOleSysError.Create(const Message: string;
1525   ErrorCode: HRESULT; HelpContext: Integer);
1526 var
1527   S: string;
1528 begin
1529   S := Message;
1530   if S = '' then
1531   begin
1532     S := SysErrorMessage(ErrorCode);
1533     if S = '' then FmtStr(S, SOleError, [ErrorCode]);
1534   end;
1535   inherited CreateHelp(S, HelpContext);
1536   FErrorCode := ErrorCode;
1537 end;}
1538
1539 { EOleException }
1540
1541 {constructor EOleException.Create(const Message: string; ErrorCode: HRESULT;
1542   const Source, HelpFile: string; HelpContext: Integer);
1543 begin
1544   inherited Create(TrimPunctuation(Message), ErrorCode, HelpContext);
1545   FSource := Source;
1546   FHelpFile := HelpFile;
1547 end;}
1548
1549
1550 { Raise EOleSysError exception from an error code }
1551
1552 procedure OleError(ErrorCode: HResult);
1553 begin
1554   raise EOleSysError.Create(e_Ole, 'OLE error: ' + Int2Str( ErrorCode ) );
1555 end;
1556
1557 { Raise EOleSysError exception if result code indicates an error }
1558
1559 procedure OleCheck(Result: HResult);
1560 begin
1561   if not Succeeded(Result) then OleError(Result);
1562 end;
1563
1564 { Convert a string to a GUID }
1565
1566 function StringToGUID(const S: string): TGUID;
1567 begin
1568   OleCheck(CLSIDFromString(PWideChar(WideString(S)), Result));
1569 end;
1570
1571 { Convert a GUID to a string }
1572
1573 function GUIDToString(const ClassID: TGUID): string;
1574 var
1575   P: PWideChar;
1576 begin
1577   OleCheck(StringFromCLSID(ClassID, P));
1578   Result := P;
1579   CoTaskMemFree(P);
1580 end;
1581
1582 { Convert a programmatic ID to a class ID }
1583
1584 function ProgIDToClassID(const ProgID: string): TGUID;
1585 begin
1586   OleCheck(CLSIDFromProgID(PWideChar(WideString(ProgID)), Result));
1587 end;
1588
1589 { Convert a class ID to a programmatic ID }
1590
1591 function ClassIDToProgID(const ClassID: TGUID): string;
1592 var
1593   P: PWideChar;
1594 begin
1595   OleCheck(ProgIDFromCLSID(ClassID, P));
1596   Result := P;
1597   CoTaskMemFree(P);
1598 end;
1599
1600 { Create registry key }
1601
1602 procedure CreateRegKey(const Key, ValueName, Value: string);
1603 var
1604   Handle: HKey;
1605   Status, Disposition: Integer;
1606 begin
1607   Status := RegCreateKeyEx(HKEY_CLASSES_ROOT, PChar(Key), 0, '',
1608     REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE, nil, Handle,
1609     @Disposition);
1610   if Status = 0 then
1611   begin
1612     Status := RegSetValueEx(Handle, PChar(ValueName), 0, REG_SZ,
1613       PChar(Value), Length(Value) + 1);
1614     RegCloseKey(Handle);
1615   end;
1616   if Status <> 0 then raise EOleRegistrationError.CreateResFmt(e_Registry,
1617                             Integer(@SCreateRegKeyError), [ nil ] );
1618 end;
1619
1620 { Delete registry key }
1621
1622 procedure DeleteRegKey(const Key: string);
1623 begin
1624   RegDeleteKey(HKEY_CLASSES_ROOT, PChar(Key));
1625 end;
1626
1627 { Get registry value }
1628
1629 function GetRegStringValue(const Key, ValueName: string): string;
1630 var
1631   Size: DWord;
1632   RegKey: HKEY;
1633 begin
1634   Result := '';
1635   if RegOpenKey(HKEY_CLASSES_ROOT, PChar(Key), RegKey) = ERROR_SUCCESS then
1636   try
1637     Size := 256;
1638     SetLength(Result, Size);
1639     if RegQueryValueEx(RegKey, PChar(ValueName), nil, nil, PByte(PChar(Result)), @Size) = ERROR_SUCCESS then
1640       SetLength(Result, Size - 1) else
1641       Result := '';
1642   finally
1643     RegCloseKey(RegKey);
1644   end;
1645 end;
1646
1647 function CreateComObject(const ClassID: TGUID): IUnknown;
1648 begin
1649   OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
1650     CLSCTX_LOCAL_SERVER, IUnknown, Result));
1651 end;
1652
1653 function CreateRemoteComObject(const MachineName: WideString;
1654   const ClassID: TGUID): IUnknown;
1655 const
1656   LocalFlags = CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER or CLSCTX_INPROC_SERVER;
1657   RemoteFlags = CLSCTX_REMOTE_SERVER;
1658 var
1659   MQI: TMultiQI;
1660   ServerInfo: TCoServerInfo;
1661   IID_IUnknown: TGuid;
1662   Flags, Size: DWORD;
1663   LocalMachine: array [0..MAX_COMPUTERNAME_LENGTH] of char;
1664 begin
1665   if @CoCreateInstanceEx = nil then
1666     raise Exception.CreateResFmt(e_Com, Integer(@SDCOMNotInstalled), [nil]);
1667   FillChar(ServerInfo, sizeof(ServerInfo), 0);
1668   ServerInfo.pwszName := PWideChar(MachineName);
1669   IID_IUnknown := IUnknown;
1670   MQI.IID := @IID_IUnknown;
1671   MQI.itf := nil;
1672   MQI.hr := 0;
1673   { If a MachineName is specified check to see if it the local machine.
1674     If it isn't, do not allow LocalServers to be used. }
1675   if Length(MachineName) > 0 then
1676   begin
1677     Size := Sizeof(LocalMachine);  // Win95 is hypersensitive to size
1678     if GetComputerName(LocalMachine, Size) and
1679        (AnsiCompareText(LocalMachine, MachineName) = 0) then
1680       Flags := LocalFlags else
1681       Flags := RemoteFlags;
1682   end else
1683     Flags := LocalFlags;
1684   OleCheck(CoCreateInstanceEx(ClassID, nil, Flags, @ServerInfo, 1, @MQI));
1685   OleCheck(MQI.HR);
1686   Result := MQI.itf;
1687 end;
1688
1689 function CreateOleObject(const ClassName: string): IDispatch;
1690 var
1691   ClassID: TCLSID;
1692 begin
1693   ClassID := ProgIDToClassID(ClassName);
1694   OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
1695     CLSCTX_LOCAL_SERVER, IDispatch, Result));
1696 end;
1697
1698 function GetActiveOleObject(const ClassName: string): IDispatch;
1699 var
1700   ClassID: TCLSID;
1701   Unknown: IUnknown;
1702 begin
1703   ClassID := ProgIDToClassID(ClassName);
1704   OleCheck(GetActiveObject(ClassID, nil, Unknown));
1705   OleCheck(Unknown.QueryInterface(IDispatch, Result));
1706 end;
1707
1708 function StringToLPOLESTR(const Source: string): POleStr;
1709 var
1710   SourceLen: Integer;
1711   Buffer: PWideChar;
1712 begin
1713   SourceLen := Length(Source);
1714   Buffer  := CoTaskMemAlloc((SourceLen+1) * sizeof(WideChar));
1715   StringToWideChar( Source, Buffer, SourceLen+1 );
1716   Result := POleStr( Buffer );
1717 end;
1718
1719 function CreateClassID: string;
1720 var
1721   ClassID: TCLSID;
1722   P: PWideChar;
1723 begin
1724   CoCreateGuid(ClassID);
1725   StringFromCLSID(ClassID, P);
1726   Result := P;
1727   CoTaskMemFree(P);
1728 end;
1729
1730 procedure RegisterComServer(const DLLName: string);
1731 type
1732   TRegProc = function: HResult; stdcall;
1733 const
1734   RegProcName = 'DllRegisterServer'; { Do not localize }
1735 var
1736   Handle: THandle;
1737   RegProc: TRegProc;
1738 begin
1739   {$IFDEF _D2orD3}
1740   Handle := LoadLibrary( PChar( DLLName ) );
1741   {$ELSE}
1742   Handle := SafeLoadLibrary(DLLName);
1743   {$ENDIF}
1744   if Handle <= HINSTANCE_ERROR then
1745     raise Exception.CreateFmt( e_Com, '%s: %s', [SysErrorMessage(GetLastError), DLLName]);
1746   try
1747     RegProc := GetProcAddress(Handle, RegProcName);
1748     if Assigned(RegProc) then OleCheck(RegProc) else RaiseLastWin32Error;
1749   finally
1750     FreeLibrary(Handle);
1751   end;
1752 end;
1753
1754 procedure RegisterAsService(const ClassID, ServiceName: string);
1755 begin
1756   CreateRegKey('AppID\' + ClassID, 'LocalService', ServiceName);
1757   CreateRegKey('CLSID\' + ClassID, 'AppID', ClassID);
1758 end;
1759
1760 { Connect an IConnectionPoint interface }
1761
1762 procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;
1763   const Sink: IUnknown; var Connection: Longint);
1764 var
1765   CPC: IConnectionPointContainer;
1766   CP: IConnectionPoint;
1767 begin
1768   Connection := 0;
1769   if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
1770     if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
1771       CP.Advise(Sink, Connection);
1772 end;
1773
1774 { Disconnect an IConnectionPoint interface }
1775
1776 procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;
1777   var Connection: Longint);
1778 var
1779   CPC: IConnectionPointContainer;
1780   CP: IConnectionPoint;
1781 begin
1782   if Connection <> 0 then
1783     if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
1784       if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
1785         if Succeeded(CP.Unadvise(Connection)) then Connection := 0;
1786 end;
1787
1788 procedure LoadComExProcs;
1789 var
1790   Ole32: HModule;
1791 begin
1792   Ole32 := GetModuleHandle('ole32.dll');
1793   if Ole32 <> 0 then
1794   begin
1795     @CoCreateInstanceEx := GetProcAddress(Ole32, 'CoCreateInstanceEx');
1796     @CoInitializeEx := GetProcAddress(Ole32, 'CoInitializeEx');
1797     @CoAddRefServerProcess := GetProcAddress(Ole32, 'CoAddRefServerProcess');
1798     @CoReleaseServerProcess := GetProcAddress(Ole32, 'CoReleaseServerProcess');
1799     @CoResumeClassObjects := GetProcAddress(Ole32, 'CoResumeClassObjects');
1800     @CoSuspendClassObjects := GetProcAddress(Ole32, 'CoSuspendClassObjects');
1801   end;
1802 end;
1803
1804 procedure SafeCallError(ErrorCode: Integer; ErrorAddr: Pointer);
1805 var
1806   ErrorInfo: IErrorInfo;
1807   Source, Description, HelpFile: WideString;
1808   HelpContext: Longint;
1809 begin
1810   HelpContext := 0;
1811   if GetErrorInfo(0, ErrorInfo) = S_OK then
1812   begin
1813     ErrorInfo.GetSource(Source);
1814     ErrorInfo.GetDescription(Description);
1815     ErrorInfo.GetHelpFile(HelpFile);
1816     ErrorInfo.GetHelpContext(HelpContext);
1817   end;
1818   raise EOleException.Create(e_Ole, Description + Int2Str( ErrorCode ) {, Source,
1819     HelpFile, HelpContext} ) at ErrorAddr;
1820 end;
1821
1822 { Call Invoke method on the given IDispatch interface using the given
1823   call descriptor, dispatch IDs, parameters, and result }
1824
1825 procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc;
1826   DispIDs: PDispIDList; Params: Pointer; Result: PVariant);
1827 type
1828   PVarArg = ^TVarArg;
1829   TVarArg = array[0..3] of DWORD;
1830   TStringDesc = record
1831     BStr: PWideChar;
1832     PStr: PString;
1833   end;
1834 var
1835   I, J, K, ArgType, ArgCount, StrCount, DispID, InvKind, Status: Integer;
1836   VarFlag: Byte;
1837   ParamPtr: ^Integer;
1838   ArgPtr, VarPtr: PVarArg;
1839   DispParams: TDispParams;
1840   ExcepInfo: TExcepInfo;
1841   Strings: array[0..MaxDispArgs - 1] of TStringDesc;
1842   Args: array[0..MaxDispArgs - 1] of TVarArg;
1843 begin
1844   StrCount := 0;
1845   try
1846     ArgCount := CallDesc^.ArgCount;
1847     if ArgCount <> 0 then
1848     begin
1849       ParamPtr := Params;
1850       ArgPtr := @Args[ArgCount];
1851       I := 0;
1852       repeat
1853         Dec(Integer(ArgPtr), SizeOf(TVarData));
1854         ArgType := CallDesc^.ArgTypes[I] and atTypeMask;
1855         VarFlag := CallDesc^.ArgTypes[I] and atByRef;
1856         if ArgType = varError then
1857         begin
1858           ArgPtr^[0] := varError;
1859           ArgPtr^[2] := DWORD(DISP_E_PARAMNOTFOUND);
1860         end else
1861         begin
1862           if ArgType = varStrArg then
1863           begin
1864             with Strings[StrCount] do
1865               if VarFlag <> 0 then
1866               begin
1867                 BStr := StringToOleStr(PString(ParamPtr^)^);
1868                 PStr := PString(ParamPtr^);
1869                 ArgPtr^[0] := varOleStr or varByRef;
1870                 ArgPtr^[2] := Integer(@BStr);
1871               end else
1872               begin
1873                 BStr := StringToOleStr(PString(ParamPtr)^);
1874                 PStr := nil;
1875                 ArgPtr^[0] := varOleStr;
1876                 ArgPtr^[2] := Integer(BStr);
1877               end;
1878             Inc(StrCount);
1879           end else
1880           if VarFlag <> 0 then
1881           begin
1882             if (ArgType = varVariant) and
1883               (PVarData(ParamPtr^)^.VType = varString) then
1884               VarCast(PVariant(ParamPtr^)^, PVariant(ParamPtr^)^, varOleStr);
1885             ArgPtr^[0] := ArgType or varByRef;
1886             ArgPtr^[2] := ParamPtr^;
1887           end else
1888           if ArgType = varVariant then
1889           begin
1890             if PVarData(ParamPtr)^.VType = varString then
1891             begin
1892               with Strings[StrCount] do
1893               begin
1894                 BStr := StringToOleStr(string(PVarData(ParamPtr^)^.VString));
1895                 PStr := nil;
1896                 ArgPtr^[0] := varOleStr;
1897                 ArgPtr^[2] := Integer(BStr);
1898               end;
1899               Inc(StrCount);
1900             end else
1901             begin
1902               VarPtr := PVarArg(ParamPtr);
1903               ArgPtr^[0] := VarPtr^[0];
1904               ArgPtr^[1] := VarPtr^[1];
1905               ArgPtr^[2] := VarPtr^[2];
1906               ArgPtr^[3] := VarPtr^[3];
1907               Inc(Integer(ParamPtr), 12);
1908             end;
1909           end else
1910           begin
1911             ArgPtr^[0] := ArgType;
1912             ArgPtr^[2] := ParamPtr^;
1913             if (ArgType >= varDouble) and (ArgType <= varDate) then
1914             begin
1915               Inc(Integer(ParamPtr), 4);
1916               ArgPtr^[3] := ParamPtr^;
1917             end;
1918           end;
1919           Inc(Integer(ParamPtr), 4);
1920         end;
1921         Inc(I);
1922       until I = ArgCount;
1923     end;
1924     DispParams.rgvarg := @Args;
1925     DispParams.rgdispidNamedArgs := @DispIDs[1];
1926     DispParams.cArgs := ArgCount;
1927     DispParams.cNamedArgs := CallDesc^.NamedArgCount;
1928     DispID := DispIDs[0];
1929     InvKind := CallDesc^.CallType;
1930     if InvKind = DISPATCH_PROPERTYPUT then
1931     begin
1932       if Args[0][0] and varTypeMask = varDispatch then
1933         InvKind := DISPATCH_PROPERTYPUTREF;
1934       DispIDs[0] := DISPID_PROPERTYPUT;
1935       Dec(Integer(DispParams.rgdispidNamedArgs), SizeOf(Integer));
1936       Inc(DispParams.cNamedArgs);
1937     end else
1938       if (InvKind = DISPATCH_METHOD) and (ArgCount = 0) and (Result <> nil) then
1939         InvKind := DISPATCH_METHOD or DISPATCH_PROPERTYGET;
1940     Status := Dispatch.Invoke(DispID, GUID_NULL, 0, InvKind, DispParams,
1941       Result, @ExcepInfo, nil);
1942     if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
1943     J := StrCount;
1944     while J <> 0 do
1945     begin
1946       Dec(J);
1947       with Strings[J] do
1948         if PStr <> nil then OleStrToStrVar(BStr, PStr^);
1949     end;
1950   finally
1951     K := StrCount;
1952     while K <> 0 do
1953     begin
1954       Dec(K);
1955       SysFreeString(Strings[K].BStr);
1956     end;
1957   end;
1958 end;
1959
1960 { Call GetIDsOfNames method on the given IDispatch interface }
1961
1962 procedure GetIDsOfNames(const Dispatch: IDispatch; Names: PChar;
1963   NameCount: Integer; DispIDs: PDispIDList);
1964
1965   procedure RaiseNameException;
1966   begin
1967     raise EOleError.CreateResFmt(e_Com, Integer( @SNoMethod ), [Names]);
1968   end;
1969
1970 type
1971   PNamesArray = ^TNamesArray;
1972   TNamesArray = array[0..0] of PWideChar;
1973 var
1974   N, SrcLen, DestLen: Integer;
1975   Src: PChar;
1976   Dest: PWideChar;
1977   NameRefs: PNamesArray;
1978   StackTop: Pointer;
1979   Temp: Integer;
1980 begin
1981   Src := Names;
1982   N := 0;
1983   asm
1984     MOV  StackTop, ESP
1985     MOV  EAX, NameCount
1986     INC  EAX
1987     SHL  EAX, 2  // sizeof pointer = 4
1988     SUB  ESP, EAX
1989     LEA  EAX, NameRefs
1990     MOV  [EAX], ESP
1991   end;
1992   repeat
1993     SrcLen := StrLen(Src);
1994     DestLen := MultiByteToWideChar(0, 0, Src, SrcLen, nil, 0) + 1;
1995     asm
1996       MOV  EAX, DestLen
1997       ADD  EAX, EAX
1998       ADD  EAX, 3      // round up to 4 byte boundary
1999       AND  EAX, not 3
2000       SUB  ESP, EAX
2001       LEA  EAX, Dest
2002       MOV  [EAX], ESP
2003     end;
2004     if N = 0 then NameRefs[0] := Dest else NameRefs[NameCount - N] := Dest;
2005     MultiByteToWideChar(0, 0, Src, SrcLen, Dest, DestLen);
2006     Dest[DestLen-1] := #0;
2007     Inc(Src, SrcLen+1);
2008     Inc(N);
2009   until N = NameCount;
2010   Temp := Dispatch.GetIDsOfNames(GUID_NULL, NameRefs, NameCount,
2011     GetThreadLocale, DispIDs);
2012   if Temp = Integer(DISP_E_UNKNOWNNAME) then RaiseNameException else OleCheck(Temp);
2013   asm
2014     MOV  ESP, StackTop
2015   end;
2016 end;
2017
2018 { Central call dispatcher }
2019
2020 procedure VarDispInvoke(Result: PVariant; const Instance: Variant;
2021   CallDesc: PCallDesc; Params: Pointer); cdecl;
2022
2023   procedure RaiseException;
2024   begin
2025     raise EOleError.CreateResFmt(e_Com, Integer( @SVarNotObject ), [ nil ] );
2026   end;
2027
2028 var
2029   Dispatch: Pointer;
2030   DispIDs: array[0..MaxDispArgs - 1] of Integer;
2031 begin
2032   if TVarData(Instance).VType = varDispatch then
2033     Dispatch := TVarData(Instance).VDispatch
2034   else if TVarData(Instance).VType = (varDispatch or varByRef) then
2035     Dispatch := Pointer(TVarData(Instance).VPointer^)
2036   else RaiseException;
2037   GetIDsOfNames(IDispatch(Dispatch), @CallDesc^.ArgTypes[CallDesc^.ArgCount],
2038     CallDesc^.NamedArgCount + 1, @DispIDs);
2039   if Result <> nil then VarClear(Result^);
2040   DispatchInvoke(IDispatch(Dispatch), CallDesc, @DispIDs, @Params, Result);
2041 end;
2042
2043 { Raise exception given an OLE return code and TExcepInfo structure }
2044
2045 procedure DispCallError(Status: Integer; var ExcepInfo: TExcepInfo;
2046   ErrorAddr: Pointer; FinalizeExcepInfo: Boolean);
2047 var
2048   E: Exception;
2049 begin
2050   if Status = Integer(DISP_E_EXCEPTION) then
2051   begin
2052     with ExcepInfo do
2053       E := EOleException.Create(e_Com, bstrDescription {, scode, bstrSource,
2054         bstrHelpFile, dwHelpContext } );
2055     if FinalizeExcepInfo then
2056       Finalize(ExcepInfo);
2057   end else
2058     E := EOleSysError.Create(e_com, '' {, Status, 0});
2059   if ErrorAddr <> nil then
2060     raise E at ErrorAddr
2061   else
2062     raise E;
2063 end;
2064
2065 { Raise exception given an OLE return code and TExcepInfo structure }
2066
2067 procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo);
2068 begin
2069   DispCallError(Status, PExcepInfo(@ExcepInfo)^, nil, False);
2070 end;
2071
2072 procedure ClearExcepInfo(var ExcepInfo: TExcepInfo);
2073 begin
2074   FillChar(ExcepInfo, SizeOf(ExcepInfo), 0);
2075 end;
2076
2077 procedure DispCall(const Dispatch: IDispatch; CallDesc: PCallDesc;
2078   DispID: Integer; NamedArgDispIDs, Params, Result: Pointer); stdcall;
2079 type
2080   TExcepInfoRec = record  // mock type to avoid auto init and cleanup code
2081     wCode: Word;
2082     wReserved: Word;
2083     bstrSource: PWideChar;
2084     bstrDescription: PWideChar;
2085     bstrHelpFile: PWideChar;
2086     dwHelpContext: Longint;
2087     pvReserved: Pointer;
2088     pfnDeferredFillIn: Pointer;
2089     scode: HResult;
2090   end;
2091 var
2092   DispParams: TDispParams;
2093   ExcepInfo: TExcepInfoRec;
2094 asm
2095         PUSH    EBX
2096         PUSH    ESI
2097         PUSH    EDI
2098         MOV     EBX,CallDesc
2099         XOR     EDX,EDX
2100         MOV     EDI,ESP
2101         MOVZX   ECX,[EBX].TCallDesc.ArgCount
2102         MOV     DispParams.cArgs,ECX
2103         TEST    ECX,ECX
2104         JE      @@10
2105         ADD     EBX,OFFSET TCallDesc.ArgTypes
2106         MOV     ESI,Params
2107 @@1:    MOVZX   EAX,[EBX].Byte
2108         TEST    AL,atByRef
2109         JNE     @@3
2110         CMP     AL,varVariant
2111         JE      @@2
2112         CMP     AL,varDouble
2113         JB      @@4
2114         CMP     AL,varDate
2115         JA      @@4
2116         PUSH    [ESI].Integer[4]
2117         PUSH    [ESI].Integer[0]
2118         PUSH    EDX
2119         PUSH    EAX
2120         ADD     ESI,8
2121         JMP     @@5
2122 @@2:    PUSH    [ESI].Integer[12]
2123         PUSH    [ESI].Integer[8]
2124         PUSH    [ESI].Integer[4]
2125         PUSH    [ESI].Integer[0]
2126         ADD     ESI,16
2127         JMP     @@5
2128 @@3:    AND     AL,atTypeMask
2129         OR      EAX,varByRef
2130 @@4:    PUSH    EDX
2131         PUSH    [ESI].Integer[0]
2132         PUSH    EDX
2133         PUSH    EAX
2134         ADD     ESI,4
2135 @@5:    INC     EBX
2136         DEC     ECX
2137         JNE     @@1
2138         MOV     EBX,CallDesc
2139 @@10:   MOV     DispParams.rgvarg,ESP
2140         MOVZX   EAX,[EBX].TCallDesc.NamedArgCount
2141         MOV     DispParams.cNamedArgs,EAX
2142         TEST    EAX,EAX
2143         JE      @@12
2144         MOV     ESI,NamedArgDispIDs
2145 @@11:   PUSH    [ESI].Integer[EAX*4-4]
2146         DEC     EAX
2147         JNE     @@11
2148 @@12:   MOVZX   ECX,[EBX].TCallDesc.CallType
2149         CMP     ECX,DISPATCH_PROPERTYPUT
2150         JNE     @@20
2151         PUSH    DISPID_PROPERTYPUT
2152         INC     DispParams.cNamedArgs
2153         CMP     [EBX].TCallDesc.ArgTypes.Byte[0],varDispatch
2154         JE      @@13
2155         CMP     [EBX].TCallDesc.ArgTypes.Byte[0],varUnknown
2156         JNE     @@20
2157 @@13:   MOV     ECX,DISPATCH_PROPERTYPUTREF
2158 @@20:   MOV     DispParams.rgdispidNamedArgs,ESP
2159         PUSH    EDX                     { ArgErr }
2160         LEA     EAX,ExcepInfo
2161         PUSH    EAX                     { ExcepInfo }
2162         PUSH    ECX
2163         PUSH    EDX
2164         CALL    ClearExcepInfo
2165         POP     EDX
2166         POP     ECX
2167         PUSH    Result                  { VarResult }
2168         LEA     EAX,DispParams
2169         PUSH    EAX                     { Params }
2170         PUSH    ECX                     { Flags }
2171         PUSH    EDX                     { LocaleID }
2172         PUSH    OFFSET GUID_NULL        { IID }
2173         PUSH    DispID                  { DispID }
2174         MOV     EAX,Dispatch
2175         PUSH    EAX
2176         MOV     EAX,[EAX]
2177         CALL    [EAX].Pointer[24]
2178         TEST    EAX,EAX
2179         JE      @@30
2180         LEA     EDX,ExcepInfo
2181         MOV     CL, 1
2182         PUSH    ECX
2183         MOV     ECX,[EBP+4]
2184         JMP     DispCallError
2185 @@30:   MOV     ESP,EDI
2186         POP     EDI
2187         POP     ESI
2188         POP     EBX
2189 end;
2190
2191 procedure DispCallByID(Result: Pointer; const Dispatch: IDispatch;
2192   DispDesc: PDispDesc; Params: Pointer); cdecl;
2193 asm
2194         PUSH    EBX
2195         MOV     EBX,DispDesc
2196         XOR     EAX,EAX
2197         PUSH    EAX
2198         PUSH    EAX
2199         PUSH    EAX
2200         PUSH    EAX
2201         MOV     EAX,ESP
2202         PUSH    EAX
2203         LEA     EAX,Params
2204         PUSH    EAX
2205         PUSH    EAX
2206         PUSH    [EBX].TDispDesc.DispID
2207         LEA     EAX,[EBX].TDispDesc.CallDesc
2208         PUSH    EAX
2209         PUSH    Dispatch
2210         CALL    DispCall
2211         MOVZX   EAX,[EBX].TDispDesc.ResType
2212         MOV     EBX,Result
2213         JMP     @ResultTable.Pointer[EAX*4]
2214
2215 @ResultTable:
2216         DD      @ResEmpty
2217         DD      @ResNull
2218         DD      @ResSmallint
2219         DD      @ResInteger
2220         DD      @ResSingle
2221         DD      @ResDouble
2222         DD      @ResCurrency
2223         DD      @ResDate
2224         DD      @ResString
2225         DD      @ResDispatch
2226         DD      @ResError
2227         DD      @ResBoolean
2228         DD      @ResVariant
2229         DD      @ResUnknown
2230         DD      @ResDecimal
2231         DD      @ResError
2232         DD      @ResByte
2233
2234 @ResSingle:
2235         FLD     [ESP+8].Single
2236         JMP     @ResDone
2237
2238 @ResDouble:
2239 @ResDate:
2240         FLD     [ESP+8].Double
2241         JMP     @ResDone
2242
2243 @ResCurrency:
2244         FILD    [ESP+8].Currency
2245         JMP     @ResDone
2246
2247 @ResString:
2248         MOV     EAX,[EBX]
2249         TEST    EAX,EAX
2250         JE      @@1
2251         PUSH    EAX
2252         CALL    SysFreeString
2253 @@1:    MOV     EAX,[ESP+8]
2254         MOV     [EBX],EAX
2255         JMP     @ResDone
2256
2257 @ResDispatch:
2258 @ResUnknown:
2259         MOV     EAX,[EBX]
2260         TEST    EAX,EAX
2261         JE      @@2
2262         PUSH    EAX
2263         MOV     EAX,[EAX]
2264         CALL    [EAX].Pointer[8]
2265 @@2:    MOV     EAX,[ESP+8]
2266         MOV     [EBX],EAX
2267         JMP     @ResDone
2268
2269 @ResVariant:
2270         MOV     EAX,EBX
2271         CALL    System.@VarClear
2272         MOV     EAX,[ESP]
2273         MOV     [EBX],EAX
2274         MOV     EAX,[ESP+4]
2275         MOV     [EBX+4],EAX
2276         MOV     EAX,[ESP+8]
2277         MOV     [EBX+8],EAX
2278         MOV     EAX,[ESP+12]
2279         MOV     [EBX+12],EAX
2280         JMP     @ResDone
2281
2282 @ResSmallint:
2283 @ResInteger:
2284 @ResBoolean:
2285 @ResByte:
2286         MOV     EAX,[ESP+8]
2287
2288 @ResDecimal:
2289 @ResEmpty:
2290 @ResNull:
2291 @ResError:
2292 @ResDone:
2293         ADD     ESP,16
2294         POP     EBX
2295 end;
2296
2297 var
2298   ComClassManagerVar: TObject;
2299   SaveInitProc: Pointer;
2300   NeedToUninitialize: Boolean;
2301
2302 function ComClassManager: TComClassManager;
2303 begin
2304   if ComClassManagerVar = nil then
2305     ComClassManagerVar := TComClassManager.Create;
2306   Result := TComClassManager(ComClassManagerVar);
2307 end;
2308
2309 procedure InitComObj;
2310 begin
2311   if SaveInitProc <> nil then TProcedure(SaveInitProc);
2312   if (CoInitFlags <> -1) and Assigned(KOLComObj.CoInitializeEx) then
2313   begin
2314     NeedToUninitialize := Succeeded(KOLComObj.CoInitializeEx(nil, CoInitFlags));
2315     IsMultiThread := IsMultiThread or
2316       ((CoInitFlags and COINIT_APARTMENTTHREADED) <> 0) or
2317       (CoInitFlags = COINIT_MULTITHREADED);  // this flag has value zero
2318   end
2319   else
2320     NeedToUninitialize := Succeeded(CoInitialize(nil));
2321 end;
2322
2323
2324 initialization
2325 begin
2326   LoadComExProcs;
2327   VarDispProc := @VarDispInvoke;
2328   DispCallByIDProc := @DispCallByID;
2329   SafeCallErrorProc := @SafeCallError;
2330   if not IsLibrary then
2331   begin
2332     SaveInitProc := InitProc;
2333     InitProc := @InitComObj;
2334   end;
2335 end;
2336
2337 finalization
2338 begin
2339   OleUninitializing := True;
2340   ComClassManagerVar.Free;
2341   SafeCallErrorProc := nil;
2342   DispCallByIDProc := nil;
2343   VarDispProc := nil;
2344   if NeedToUninitialize then CoUninitialize;
2345 end;
2346
2347 end.