// TThreadedClassFactory.Create (ComServer, TsvrDM, CLASS_Test, // create com thread pooling
// ciMultiInstance);
unit ThreadComLib;
{$IFDEF VER100}
{$DEFINE D3}
{$ENDIF}
interface
uses
Windows,
ActiveX,
Classes,
ComObj,
Controls,
ExtCtrls,
Grids,
Variants,
VCLCom, forms
;
{ General COM threading types }
type
{ apartment types }
TApartmentType = (atSTA, atMTA);
{ Win32 thread synchronization classes }
type
TWaitResult = (wrSignaled, wrTimeout, wrAbandoned, wrError);
TThreadSyncObject = class
protected
FHandle: THandle;
function GetLastError: longint;
public
destructor Destroy; override;
procedure Acquire; virtual;
function Lock (bLock: boolean): boolean; virtual;
procedure Release; virtual;
function WaitFor (iTimeout: dword): TWaitResult; virtual;
property Handle: THandle read FHandle;
property LastError: longint read GetLastError;
end;
TCriticalSection = class (TThreadSyncObject)
protected
FCS: TRTLCriticalSection;
public
constructor Create;
destructor Destroy; override;
procedure Enter;
function Lock (bLock: boolean): boolean; override;
procedure Leave;
end;
TEvent = class (TThreadSyncObject)
public
constructor Create (psa: PSecurityAttributes;
bManualReset, bInitState: boolean; const sName: string);
constructor CreateSimple;
function PulseEvent: boolean;
function ResetEvent: boolean;
function SetEvent: boolean;
end;
{ Message queue driven thread }
TMQThread = class (TThread)
protected
FQuitWaitTimeout: integer;
FReadyEvent: TEvent;
procedure EnsureMessageQueue; virtual;
function ProcessMessage (var rMsg: TMsg): boolean; virtual;
public
constructor Create (bSuspend: boolean);
destructor Destroy; override;
procedure Execute; override;
function Quit (bWait: boolean): boolean; virtual;
procedure SignalReady; virtual;
procedure WaitForQuit; virtual;
function WaitForReady: boolean; virtual;
property QuitWaitTimeout: integer read FQuitWaitTimeout write FQuitWaitTimeout;
end;
{ encapsulates CoMarshalInterThreadInterfaceInStream/CoGetInterfaceAndReleaseStream }
TObjectMarshaler = class
protected
FMarshalIID: TGUID;
FStream: pointer;
procedure ReleaseStream;
public
constructor CreateMarshalObject (const iid: TGUID; const pUnk: IUnknown);
constructor CreateMarshalOleObject (const vObj: olevariant);
destructor Destroy; override;
function MarshalObject (const iid: TGUID; const pUnk: IUnknown): boolean;
function MarshalOleObject (const vObj: olevariant): boolean;
function UnMarshalObject (out pObj): boolean;
function UnMarshalOleObject (out vObj: olevariant): boolean;
end;
TApartmentObjectMarshaler = TObjectMarshaler; // backward compatibility
{ server threading models }
{$IFDEF D3}
TThreadingModel = (tmSingle, tmApartment, tmFree, tmBoth);
{$ENDIF}
{ STA allocation modes }
TSTAAllocMode = (amDefault, amPooled, amDistinct);
{ abstract apartment manager classes }
{ forwards }
TApartment = class;
TApartments = class;
TApartmentThread = class;
TApartmentThreads = class;
TApartmentObject = class;
TApartmentAllocator = class;
TFuncFactoryCreateInstance = function (
OwnerApartment: TApartment; const UnkOuter: IUnknown; const iid: TGUID; out pObject
): HResult of object; stdcall;
{ abstract apartment "manager" class. allows TApartment classes to be reused! }
TApartmentManagerObject = class
protected
FAllocator: TApartmentAllocator;
function GetAllocator: TApartmentAllocator; virtual;
function GetApartments: TApartments; virtual; abstract;
function GetServerObjectCount: integer; virtual;
public
destructor Destroy; override;
function CanCreateInstance (var hr: HResult): boolean; virtual;
function CreateInstance (
cf: TComObjectFactory; pfnci: TFuncFactoryCreateInstance;
tm: TThreadingModel; am: TSTAAllocMode; pUnkOuter: IUnknown;
const iid: TGUID; out pObject): HResult; virtual;
procedure GarbageCollect (Sender: TObject); virtual; abstract;
function GetPooledSTACount: integer; virtual; abstract;
procedure LastReleased (var bShutdown: boolean); virtual;
procedure Resume; virtual;
function ServerIsShuttingDown: boolean; virtual; abstract;
property Allocator: TApartmentAllocator read GetAllocator;
property Apartments: TApartments read GetApartments;
property ServerObjectCount: integer read GetServerObjectCount;
end;
{ apartments garbage collector }
TApartmentsGC = class;
TApartmentsGCThread = class (TMQThread)
protected
FOwner: TApartmentsGC;
function GetManager: TApartmentManagerObject;
function ProcessMessage (var rMsg: TMsg): boolean; override;
public
constructor Create (Owner: TApartmentsGC; tp: TThreadPriority); virtual;
procedure GarbageCollect (Sender: TObject); virtual;
property Manager: TApartmentManagerObject read GetManager;
end;
TApartmentsGC = class
protected
FManager: TApartmentManagerObject;
FThread: TApartmentsGCThread;
procedure InitializeThread (tp: TThreadPriority); virtual;
public
constructor Create (am: TApartmentManagerObject; tp: TThreadPriority);
destructor Destroy; override;
procedure Activate (Sender: TObject); virtual;
procedure Terminate; virtual;
property Manager: TApartmentManagerObject read FManager;
property Thread: TApartmentsGCThread read FThread;
end;
{ create instance info structure }
PCreateInstanceInfo = ^TCreateInstanceInfo;
TCreateInstanceInfo = record
ApartmentObject: TApartmentObject;
ApartmentThread: TApartmentThread;
Data: pointer;
end;
{ base create instance data structure }
PCreateInstanceData = ^TCreateInstanceData;
TCreateInstanceData = record
IsThreadedComClass: boolean;
end;
{ helper class to handle marshaled creation of objects out of apartments }
TApartmentObject = class
protected
FCreateIID: TGUID;
FCreateInstanceFunc: TFuncFactoryCreateInstance;
FCreateResult: HResult;
FCreateStream: pointer;
procedure Clear; virtual;
function CreateOnThread (pciInfo: PCreateInstanceInfo): boolean; virtual;
function GetInstance (out pObject): HResult; virtual;
function MarshalInterface (const iid: TGUID; pUnk: IUnknown): HResult; virtual;
function UnmarshalInterface (const iid: TGUID; out pObject): HResult; virtual;
public
constructor Create (
pCreateInstance: TFuncFactoryCreateInstance; const iid: TGUID); virtual;
destructor Destroy; override;
function CreateInApartmentThread (pciInfo: PCreateInstanceInfo; out pObject): HResult; virtual;
end;
{ base apartment thread class, handles both STA and MTA }
TApartmentThreadClass = class of TApartmentThread;
TApartmentThread = class (TMQThread)
protected
FOwner: TApartmentThreads;
FServerWindow: HWnd;
function GetApartment: TApartment; virtual;
procedure InitServerWindow (bInit: boolean); virtual;
procedure InstanceCreated (pciInfo: PCreateInstanceInfo; pUnk: IUnknown); virtual;
function ProcessMessage (var rMsg: TMsg): boolean; override;
public
constructor Create (Owner: TApartmentThreads); virtual;
destructor Destroy; override;
function CreateInstance (pCreateInstance: TFuncFactoryCreateInstance;
const iid: TGUID; pData: pointer; out pObject): HResult; virtual;
procedure Execute; override;
function Quit (bWait: boolean): boolean; override;
property Apartment: TApartment read GetApartment;
property ServerWindow: HWnd read FServerWindow;
end;
{ collection of threads per apartment }
TApartmentThreads = class
protected
FCSThreads: TCriticalSection;
FOwner: TApartment;
FThreads: TList;
function CreateThread: TApartmentThread; virtual;
function GetItemById (iThreadId: integer): TApartmentThread;
function GetItems (i: integer): TApartmentThread;
procedure LockThreads (bLock: boolean); virtual;
public
constructor Create (Owner: TApartment); virtual;
destructor Destroy; override;
function AddThread (at: TApartmentThread): integer; virtual;
procedure Clear; virtual;
function Count: integer; virtual;
function NewThread: TApartmentThread; virtual;
function Terminate: boolean; virtual;
property Apartment: TApartment read FOwner;
property ItemById [iThreadId: integer]: TApartmentThread read GetItemById;
property Items [i: integer]: TApartmentThread read GetItems; default;
end;
{ COM apartment abstraction class }
TApartmentClass = class of TApartment;
TApartment = class
protected
FApartmentType: TApartmentType;
FAutoDelete: boolean;
FCSRefCount: TCriticalSection;
FData: pointer;
FLockCount: integer;
FMarkForDelete: boolean;
FName: string;
FOwner: TApartments;
FPooled: boolean;
FThreads: TApartmentThreads;
function CreateThreads: TApartmentThreads; virtual;
function GetLockCount: integer; virtual;
function GetManager: TApartmentManagerObject; virtual;
procedure LastReleased; virtual;
procedure SetAutoDelete (bSet: boolean); virtual;
procedure SetPooled (bSet: boolean); virtual;
public
constructor Create (Owner: TApartments; at: TApartmentType); virtual;
destructor Destroy; override;
function CreateInstance (pCreateInstance: TFuncFactoryCreateInstance;
const iid: TGUID; pData: pointer; out pObject): HResult; virtual;
function CountObject (bLock: boolean): integer; virtual;
function GarbageCollect: boolean; virtual;
procedure LockRefCount (bLock: boolean); virtual;
function TerminateThreads: boolean; virtual;
property ApartmentType: TApartmentType read FApartmentType write FApartmentType;
property AutoDelete: boolean read FAutoDelete write SetAutoDelete;
property Data: pointer read FData write FData; // any user defined object/data
property LockCount: integer read GetLockCount;
property Manager: TApartmentManagerObject read GetManager;
property MarkForDelete: boolean read FMarkForDelete write FMarkForDelete;
property Name: string read FName write FName;
property ObjectCount: integer read GetLockCount;
property Pooled: boolean read FPooled write SetPooled;
property Threads: TApartmentThreads read FThreads;
end;
{ collection of apartments per server }
TApartments = class
protected
FApartments: TList;
FCSApartments: TCriticalSection;
FManager: TApartmentManagerObject;
function CreateApartment (at: TApartmentType): TApartment; virtual;
function GetActiveApartment: TApartment; virtual;
function GetActiveApartmentName: string; virtual;
function GetItemByName (const sName: string): TApartment; virtual;
function GetItems (i: integer): TApartment;
function GetLockCount: integer; virtual;
function GetObjects (i: integer): pointer;
function GetPooledCount: integer; virtual;
procedure LockApartments (bLock: boolean);
procedure SetObjects (i: integer; pObj: pointer);
public
constructor Create (am: TApartmentManagerObject); virtual;
destructor Destroy; override;
procedure Clear; virtual;
function Count: integer; virtual;
function DeleteApartment (i: integer): boolean; virtual;
procedure DeleteEmptyApartments; virtual;
function EnsureMTA: TApartment; virtual;
function FindMTA (var mta: TApartment): boolean; virtual;
function GarbageCollect (iCount: integer): integer; virtual;
function GetCurrentApartment (var apt: TApartment; var thrd: TApartmentThread): boolean; virtual;
function HasMTA: boolean;
function IndexOfApartment (apt: TApartment): integer; virtual;
function NewApartment (const sName: string; at: TApartmentType; bCreateThread: boolean): TApartment; virtual;
function NewPooledSTA: TApartment; virtual;
function RemoveApartment (apt: TApartment): boolean; virtual;
function SafeRemoveApartment (apt: TApartment): boolean;
function TerminateThreads: boolean; virtual;
property ActiveApartment: TApartment read GetActiveApartment;
property ActiveApartmentName: string read GetActiveApartmentName;
property ItemByName [const sName: string]: TApartment read GetItemByName;
property Items [i: integer]: TApartment read GetItems; default;
property LockCount: integer read GetLockCount;
property Manager: TApartmentManagerObject read FManager;
property Objects [i: integer]: pointer read GetObjects write SetObjects; // each apartment can have a userdef object
property ObjectCount: integer read GetLockCount;
property PooledCount: integer read GetPooledCount;
end;
{ base apartment allocator for server objects }
TApartmentAllocator = class
protected
FApartmentIndex: integer;
FManager: TApartmentManagerObject;
public
constructor Create (am: TApartmentManagerObject); virtual;
destructor Destroy; override;
function AllocateApartment (am: TSTAAllocMode): TApartment; virtual;
property Manager: TApartmentManagerObject read FManager;
end;
{ apartment statistics component }
TApartmentStats = class (TComponent)
protected
FAlign: TAlign;
FApartments: TApartments;
FEnabled: boolean;
FGrid: TStringGrid;
FGridParent: TWinControl;
FTimer: TTimer;
FUpdateInterval: integer;
FVisible: boolean;
function GetGrid: TStringGrid;
function GetTimer: TTimer;
procedure Notification (cmp: TComponent; op: TOperation); override;
procedure SetAlign (al: TAlign);
procedure SetEnabled (bSet: boolean);
procedure SetGridParent (ctlParent: TWinControl);
procedure SetUpdateInterval (iValue: integer);
procedure SetVisible (bSet: boolean);
procedure TimerUpdate (Sender: TObject);
procedure UpdateGrid;
property Timer: TTimer read GetTimer;
public
constructor Create (pOwner: TComponent); override;
destructor Destroy; override;
property Apartments: TApartments read FApartments write FApartments;
property Grid: TStringGrid read GetGrid;
published
property Align: TAlign read FAlign write SetAlign default alNone;
property Enabled: boolean read FEnabled write SetEnabled default TRUE;
property GridParent: TWinControl read FGridParent write SetGridParent;
property UpdateInterval: integer
read FUpdateInterval write SetUpdateInterval default 1000;
property Visible: boolean read FVisible write SetVisible default TRUE;
end;
{ TComObjectFactory replacement, enables apartment allocation }
TThreadedComObjectFactory = class(TComObjectFactory, IClassFactory, IExternalConnection)
protected
{ IClassFactory }
function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
out Obj): HResult; virtual; stdcall;
function LockServer(fLock: BOOL): HResult; stdcall;
{ IExternalConnection }
function AddConnection (extconn: longint; reserved: longint): longint; stdcall;
function ReleaseConnection (extconn: longint; reserved: longint; fLastReleaseCloses: BOOL): longint; stdcall;
protected
FRegisterClass: longint;
FSTAAllocMode: TSTAAllocMode;
FThreadingModel: TThreadingModel; // duplication due to private FThreadingModel field
function DoCreateInstance(pApt: TApartment;
const UnkOuter: IUnknown; const IID: TGUID; out Obj): HResult; virtual; stdcall;
procedure Initialize; virtual;
public
// backward compatibility
constructor CreateThreaded (ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const ClassName, Description: string;
Instancing: TClassInstancing; tm: TThreadingModel);
constructor CreateThreadedEx (ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const ClassName, Description: string;
Instancing: TClassInstancing; tm: TThreadingModel; am: TSTAAllocMode);
{$IFDEF D3}
constructor Create (ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const ClassName, Description: string;
Instancing: TClassInstancing);
{$ELSE}
constructor Create (ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const ClassName, Description: string;
Instancing: TClassInstancing); overload;
constructor Create (ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const ClassName, Description: string;
Instancing: TClassInstancing; tm: TThreadingModel); overload;
constructor Create (ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const ClassName, Description: string;
Instancing: TClassInstancing; tm: TThreadingModel; am: TSTAAllocMode); overload;
{$ENDIF}
destructor Destroy; override;
procedure RegisterClass (bRegister: boolean);
procedure UpdateRegistry (bRegister: boolean); override;
property STAAllocMode: TSTAAllocMode read FSTAAllocMode;
property ThreadingModel: TThreadingModel read FThreadingModel;
end;
{ TAutoObjectFactory replacement, enables apartment allocation }
TThreadedAutoObjectFactory = class(TAutoObjectFactory, IClassFactory, IExternalConnection)
protected
{ IClassFactory }
function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
out Obj): HResult; virtual; stdcall;
function LockServer(fLock: BOOL): HResult; stdcall;
{ IExternalConnection }
function AddConnection (extconn: longint; reserved: longint): longint; stdcall;
function ReleaseConnection (extconn: longint; reserved: longint; fLastReleaseCloses: BOOL): longint; stdcall;
protected
FRegisterClass: longint;
FSTAAllocMode: TSTAAllocMode;
FThreadingModel: TThreadingModel; // duplication due to private FThreadingModel field
function DoCreateInstance(pApt: TApartment;
const UnkOuter: IUnknown; const IID: TGUID; out Obj): HResult; virtual; stdcall;
procedure Initialize; virtual;
public
// backward compatibility
constructor CreateThreaded (ComServer: TComServerObject; AutoClass: TAutoClass;
const ClassID: TGUID; Instancing: TClassInstancing; tm: TThreadingModel);
constructor CreateThreadedEx (ComServer: TComServerObject; AutoClass: TAutoClass;
const ClassID: TGUID; Instancing: TClassInstancing; tm: TThreadingModel; am: TSTAAllocMode);
{$IFDEF D3}
constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass;
const ClassID: TGUID; Instancing: TClassInstancing);
{$ELSE}
constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass;
const ClassID: TGUID; Instancing: TClassInstancing); overload;
constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass;
const ClassID: TGUID; Instancing: TClassInstancing;
tm: TThreadingModel); overload;
constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass;
const ClassID: TGUID; Instancing: TClassInstancing;
tm: TThreadingModel; am: TSTAAllocMode); overload;
{$ENDIF}
destructor Destroy; override;
procedure RegisterClass (bRegister: boolean);
procedure UpdateRegistry (bRegister: boolean); override;
property STAAllocMode: TSTAAllocMode read FSTAAllocMode;
property ThreadingModel: TThreadingModel read FThreadingModel;
end;
{ TClassFactory replacement, enables apartment allocation }
TThreadedClassFactory = class(TComponentFactory, IClassFactory, IExternalConnection)
protected
{ IClassFactory }
function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
out Obj): HResult; virtual; stdcall;
function LockServer(fLock: BOOL): HResult; stdcall;
{ IExternalConnection }
function AddConnection (extconn: longint; reserved: longint): longint; stdcall;
function ReleaseConnection (extconn: longint; reserved: longint; fLastReleaseCloses: BOOL): longint; stdcall;
protected
FRegisterClass: longint;
FSTAAllocMode: TSTAAllocMode;
FThreadingModel: TThreadingModel; // duplication due to private FThreadingModel field
function DoCreateInstance(pApt: TApartment;
const UnkOuter: IUnknown; const IID: TGUID; out Obj): HResult; virtual; stdcall;
procedure Initialize; virtual;
public
// backward compatibility
constructor CreateThreaded (ComServer: TComServerObject;
ComponentClass: TComponentClass; const ClassID: TGUID;
Instancing: TClassInstancing; tm: TThreadingModel);
constructor CreateThreadedEx (ComServer: TComServerObject;
ComponentClass: TComponentClass; const ClassID: TGUID;
Instancing: TClassInstancing; tm: TThreadingModel; am: TSTAAllocMode);
{$IFDEF D3}
constructor Create (ComServer: TComServerObject;
ComponentClass: TComponentClass; const ClassID: TGUID;
Instancing: TClassInstancing);
{$ELSE}
constructor Create(ComServer: TComServerObject;
ComponentClass: TComponentClass; const ClassID: TGUID;
Instancing: TClassInstancing); overload;
constructor Create(ComServer: TComServerObject;
ComponentClass: TComponentClass; const ClassID: TGUID;
Instancing: TClassInstancing; tm: TThreadingModel); overload;
constructor Create(ComServer: TComServerObject;
ComponentClass: TComponentClass; const ClassID: TGUID;
Instancing: TClassInstancing; tm: TThreadingModel; am: TSTAAllocMode); overload;
{$ENDIF}
destructor Destroy; override;
function CreateComObject (const Controller: IUnknown): TComObject; override;
procedure RegisterClass (bRegister: boolean);
procedure UpdateRegistry (bRegister: boolean); override;
property STAAllocMode: TSTAAllocMode read FSTAAllocMode;
property ThreadingModel: TThreadingModel read FThreadingModel;
end;
{ backward compatibility }
TThreadedVCLComObjectFactory = TThreadedClassFactory;
{ TComObject replacement, robust integration for both D3 and D4 }
TThreadedComObject = class (TComObject)
protected
FApartment: TApartment;
FCSRefCount: TCriticalSection;
FCSSelfLock: TCriticalSection;
FFTM: IUnknown;
FFTMSupported: boolean;
function GetFTM: IUnknown;
function GetRefCountLock: TCriticalSection;
function GetSelfLock: TCriticalSection;
property FTM: IUnknown read GetFTM;
property RefCountLock: TCriticalSection read GetRefCountLock;
property SelfLock: TCriticalSection read GetSelfLock; // convenient locking mechanism for self!
public
destructor Destroy; override;
procedure Initialize; override;
function ObjAddRef: integer; override;
function ObjRelease: integer; override;
function ObjQueryInterface (const IID: TGUID; out pObj): HResult; override;
property Apartment: TApartment read FApartment;
property FTMSupported: boolean read FFTMSupported write FFTMSupported;
end;
{ TAutoObject replacement, robust integration for both D3 and D4 }
TThreadedAutoObject = class (TAutoObject)
protected
FApartment: TApartment;
FCSRefCount: TCriticalSection;
FCSSelfLock: TCriticalSection;
FFTM: IUnknown;
FFTMSupported: boolean;
function GetFTM: IUnknown;
function GetRefCountLock: TCriticalSection;
function GetSelfLock: TCriticalSection;
property FTM: IUnknown read GetFTM;
property RefCountLock: TCriticalSection read GetRefCountLock;
property SelfLock: TCriticalSection read GetSelfLock; // convenient locking mechanism for self!
public
destructor Destroy; override;
procedure Initialize; override;
function ObjAddRef: integer; override;
function ObjRelease: integer; override;
function ObjQueryInterface (const IID: TGUID; out pObj): HResult; override;
property Apartment: TApartment read FApartment;
property FTMSupported: boolean read FFTMSupported write FFTMSupported;
end;
{ singleton com object }
TSingletonComObject = class (TThreadedComObjectFactory, IUnknown)
protected
{ IUnknown }
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
protected
function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
out Obj): HResult; override;
public
function SafeCallException(ExceptObject: TObject;
ExceptAddr: Pointer): HResult; override;
{ added for convenience }
function ObjAddRef: Integer; virtual; stdcall;
function ObjQueryInterface(const IID: TGUID; out Obj): Integer; virtual; stdcall;
function ObjRelease: Integer; virtual; stdcall;
end;
TSingletonComClass = class of TSingletonComObject;
{ singleton auto object }
TSingletonAutoObject = class (TThreadedAutoObjectFactory, IUnknown, IProvideClassInfo, IDispatch)
protected
{ IUnknown }
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
{ IProvideClassInfo }
function GetClassInfo(out TypeInfo: ITypeInfo): HResult; stdcall;
{ IDispatch }
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall;
protected
function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
out Obj): HResult; override;
public
function SafeCallException(ExceptObject: TObject;
ExceptAddr: Pointer): HResult; override;
function GetIntfEntry (Guid: TGUID): PInterfaceEntry; override;
{ added for convenience }
function ObjAddRef: Integer; virtual; stdcall;
function ObjQueryInterface(const IID: TGUID; out Obj): Integer; virtual; stdcall;
function ObjRelease: Integer; virtual; stdcall;
end;
TSingletonAutoClass = class of TSingletonAutoObject;
{ default apartment manager implementation }
TDefaultApartmentManager = class (TApartmentManagerObject)
protected
FApartments: TApartments;
FGC: TApartmentsGC;
FGCTimer: TTimer;
FShuttingDown: boolean;
function GetApartments: TApartments; override;
procedure TimerUpdate (pSender: TObject);
public
constructor Create;
destructor Destroy; override;
procedure GarbageCollect (Sender: TObject); override;
function GetPooledSTACount: integer; override;
procedure LastReleased (var bShutdown: boolean); override;
procedure Resume; override;
function ServerIsShuttingDown: boolean; override;
property GCTimer: TTimer read FGCTimer;
end;
{ returns global apartment manager }
function ApartmentManager: TApartmentManagerObject;
{ waits on a threading primitive handle }
function WaitForThreadSyncObject (iHandle: THandle; iTimeOut: dword): TWaitResult;
{ utility fn for entering/leaving apartments }
function InitializeCOM (bInit: boolean; at: TApartmentType): boolean;
{ std verify routine }
procedure Verify (bAssert: boolean; const sError: string);
{ returns delegated CreateInstanceFunc for a class factory }
function GetFactoryCreateInstanceFunc (cf: TComObjectFactory): TFuncFactoryCreateInstance;
{ proper registration for a class factory }
procedure RegisterFactory (cf: TComObjectFactory; bRegister: boolean);
{ determines if a class factory is threaded }
function IsThreadedFactory (cf: TComObjectFactory): boolean;
{ marks an implicitly revoked class factory }
function MarkRevokedFactory (cf: TComObjectFactory): boolean;
{ initializes singleton objects }
procedure InitializeSingletonComObject (ComServer: TComServerObject;
SingletonClass: TSingletonComClass; const clsid: TGUID;
const sClassName, sDescription: string);
procedure InitializeSingletonAutoObject (ComServer: TComServerObject;
SingletonClass: TSingletonAutoClass; const clsid: TGUID);
procedure Register;
type
{$IFDEF D3}
{ NT4 DCOM extended APIs }
TCoInitializeEx = function (pvReserved: Pointer; coInit: Longint): HResult; stdcall;
TCoAddRefServerProcess = function: longint; stdcall;
TCoReleaseServerProcess = function: longint; stdcall;
TCoSuspendClassObjects = function: HResult; stdcall;
TCoResumeClassObjects = function: HResult; stdcall;
{$ENDIF}
TCoCreateFreeThreadedMarshaler = function (unkOuter: IUnknown; out unkMarshal: IUnknown): HResult; stdcall;
var
cNT4DCOMSupported: boolean = FALSE; // must be READONLY!
{$IFDEF D3}
CoInitializeEx: TCoInitializeEx = NIL;
CoAddRefServerProcess: TCoAddRefServerProcess = NIL;
CoReleaseServerProcess: TCoReleaseServerProcess = NIL;
CoSuspendClassObjects: TCoSuspendClassObjects = NIL;
CoResumeClassObjects: TCoResumeClassObjects = NIL;
{$ENDIF}
CoCreateFreeThreadedMarshaler: TCoCreateFreeThreadedMarshaler = NIL;
var
{ default server threading model: all objects are apartment threaded }
cDefServerThreadingModel: TThreadingModel = tmApartment;
{ default STA allocation mode: All STA objects are allocated from a pool
of STAs whose count is cDefApartmentPoolCount
}
cDefApartmentAllocMode: TSTAAllocMode = amPooled;
{ default wait timeout to terminate message queue threads }
cDefMQThreadQuitWaitTimeout: integer = 15000; { 15 secs }
{ default apartment classes. allows user to easily use their own apartment classes }
cDefApartmentThreadClass: TApartmentThreadClass = TApartmentThread;
cDefApartmentClass: TApartmentClass = TApartment;
{ global apartment manager object }
cApartmentManager: TApartmentManagerObject = NIL;
const
{ default STA pool size }
cDefApartmentPoolCount: integer = 30;
{ default apartment garbage collector timer interval, ms }
cDefApartmentGCTimerInterval= 15000;
implementation
uses
Messages,
SysUtils
;
var
WM_CREATEOBJECTINTHREAD: UINT = WM_USER + $1234;
WM_GARBAGECOLLECTCOMSERVER: UINT = WM_USER + $1235;
const
ThreadingModelFlags: array [TThreadingModel] of string = (
'', 'Apartment', 'Free', 'Both','Neutral');
RegFlags: array [ciSingleInstance..ciMultiInstance] of integer = (
REGCLS_SINGLEUSE, REGCLS_MULTIPLEUSE
);
SuspendedFlags: array [boolean] of integer = (0, REGCLS_SUSPENDED);
procedure DeleteRegValue (const sKey, sName: string);
var
hkTemp: HKey;
begin
if (RegOpenKeyEx (HKEY_CLASSES_ROOT, PChar (sKey), 0,
KEY_ALL_ACCESS, hkTemp) = ERROR_SUCCESS)
then begin
RegDeleteValue (hkTemp, PChar (sName));
RegCloseKey (hkTemp);
end; { if }
end;
function WaitForThreadSyncObject (iHandle: THandle; iTimeOut: dword): TWaitResult;
begin
Assert (iHandle <> 0);
case WaitForSingleObject (iHandle, iTimeout) of
WAIT_OBJECT_0 :
Result := wrSignaled;
WAIT_TIMEOUT :
Result := wrTimeout;
WAIT_ABANDONED :
Result := wrAbandoned;
else
Result := wrError;
end; { case }
end;
procedure Verify (bAssert: boolean; const sError: string);
begin
if not (bAssert) then
begin
if (IsLibrary) then MessageBox (0, pchar (sError), 'Server Error', MB_ICONERROR OR MB_OK);
raise Exception.Create (sError);
end; { if }
end;
function InitializeCOM (bInit: boolean; at: TApartmentType): boolean;
const
cApartmentInitFlags: array [TApartmentType] of integer = (
COINIT_APARTMENTTHREADED,
COINIT_MULTITHREADED
);
function InitializeMTA: boolean;
begin
Verify (@CoInitializeEx <> NIL,
'Operating system does not support multithreaded apartments!'#13 +
'You will need to install the latest DCOM version for this feature to work.'
);
Result := Succeeded (CoInitializeEx (NIL, COINIT_MULTITHREADED));
end;
begin
//Result := FALSE;
if (bInit) then
begin
case at of
atSTA :
Result := Succeeded (CoInitialize (NIL));
atMTA :
Result := InitializeMTA;
else
raise Exception.Create ('Apartment type not supported!');
end; { case }
end
else begin
CoUninitialize;
Result := TRUE;
end; { else }
end;
function GetFactoryCreateInstanceFunc (cf: TComObjectFactory): TFuncFactoryCreateInstance;
begin
Assert (cf <> NIL);
Result := NIL;
if (cf.InheritsFrom (TThreadedComObjectFactory)) then
Result := TThreadedComObjectFactory (cf).DoCreateInstance
else
if (cf.InheritsFrom (TThreadedAutoObjectFactory)) then
Result := TThreadedAutoObjectFactory (cf).DoCreateInstance
else
if (cf.InheritsFrom (TThreadedClassFactory)) then
Result := TThreadedClassFactory (cf).DoCreateInstance
;
end;
procedure RegisterFactory (cf: TComObjectFactory; bRegister: boolean);
begin
Assert (cf <> NIL);
if (cf.InheritsFrom (TThreadedComObjectFactory)) then
TThreadedComObjectFactory (cf).RegisterClass (bRegister)
else
if (cf.InheritsFrom (TThreadedAutoObjectFactory)) then
TThreadedAutoObjectFactory (cf).RegisterClass (bRegister)
else
if (cf.InheritsFrom (TThreadedClassFactory)) then
TThreadedClassFactory (cf).RegisterClass (bRegister)
else
if (bRegister) then
cf.RegisterClassObject;
end;
function IsThreadedFactory (cf: TComObjectFactory): boolean;
var
clscf: TClass;
begin
Assert (cf <> NIL);
clscf := cf.ComClass;
Result := (cf.InheritsFrom (TThreadedClassFactory) or
clscf.InheritsFrom (TThreadedComObject) or
clscf.InheritsFrom (TThreadedAutoObject)
);
end;
function MarkRevokedFactory (cf: TComObjectFactory): boolean;
begin
Result := FALSE;
Assert (cf <> NIL);
if (cf.InheritsFrom (TThreadedComObjectFactory)) then
TThreadedComObjectFactory (cf).FRegisterClass := -1
else
if (cf.InheritsFrom (TThreadedAutoObjectFactory)) then
TThreadedAutoObjectFactory (cf).FRegisterClass := -1
else
if (cf.InheritsFrom (TThreadedClassFactory)) then
TThreadedClassFactory (cf).FRegisterClass := -1
;
end;
procedure RegisterClassFactory (bRegister: boolean; const clsid: TClsId;
pUnk: IUnknown; ci: TClassInstancing; var iRegister: longint);
begin
if (ci = ciInternal) then Exit;
if (bRegister) then
begin
if (iRegister <> -1) then CoRevokeClassObject (iRegister);
OleCheck (CoRegisterClassObject (clsid, pUnk, CLSCTX_LOCAL_SERVER,
RegFlags [ci] or SuspendedFlags [cNT4DCOMSupported], iRegister)
);
end
else begin
if (iRegister <> -1) then CoRevokeClassObject (iRegister);
iRegister := -1;
end; { else }
end;
function DefaultApartmentManager: TApartmentManagerObject;
begin
Result := TDefaultApartmentManager.Create;
end;
var
csApartmentManager: TCriticalSection = NIL;
cDefaultApartmentManagerUsed: boolean = FALSE;
function ApartmentManager: TApartmentManagerObject;
begin
Assert (csApartmentManager <> NIL);
csApartmentManager.Lock (TRUE);
try
if (cApartmentManager = NIL) then
begin
cDefaultApartmentManagerUsed:=TRUE;
cApartmentManager := DefaultApartmentManager;
end; { if }
Result := cApartmentManager;
finally
csApartmentManager.Lock (FALSE);
end; { finally }
end;
procedure DestroyDefaultApartmentManager;
begin
Assert (csApartmentManager <> NIL);
csApartmentManager.Lock (TRUE);
try
if not (cDefaultApartmentManagerUsed) then Exit;
if (cApartmentManager <> NIL) then cApartmentManager.Free;
cApartmentManager := NIL;
cDefaultApartmentManagerUsed := FALSE;
finally
csApartmentManager.Lock (FALSE);
end; { finally }
end;
{ TThreadSyncObject }
function TThreadSyncObject.GetLastError: longint;
begin
Result := Windows.GetLastError;
end;
destructor TThreadSyncObject.Destroy;
begin
if (FHandle <> 0) then
CloseHandle (FHandle);
inherited;
end;
procedure TThreadSyncObject.Acquire;
begin
Lock (TRUE);
end;
function TThreadSyncObject.Lock (bLock: boolean): boolean;
begin
//Result := FALSE;
raise Exception.Create ('Not implemented!');
end;
procedure TThreadSyncObject.Release;
begin
Lock (FALSE);
end;
function TThreadSyncObject.WaitFor (iTimeout: dword): TWaitResult;
begin
Result := WaitForThreadSyncObject (Handle, iTimeOut);
end;
{ TCriticalSection }
constructor TCriticalSection.Create;
begin
inherited Create;
InitializeCriticalSection (FCS);
end;
destructor TCriticalSection.Destroy;
begin
DeleteCriticalSection (FCS);
inherited;
end;
procedure TCriticalSection.Enter;
begin
Lock (TRUE);
end;
function TCriticalSection.Lock (bLock: boolean): boolean;
begin
if (bLock) then
EnterCriticalSection (FCS)
else
LeaveCriticalSection (FCS);
Result := TRUE;
end;
procedure TCriticalSection.Leave;
begin
Lock (FALSE);
end;
{ TEvent }
constructor TEvent.Create (psa: PSecurityAttributes;
bManualReset, bInitState: boolean; const sName: string);
var
pName: pchar;
begin
inherited Create;
if (sName <> '') then pName := pchar (sName) else pName := NIL;
FHandle := CreateEvent (psa, bManualReset, bInitState, pName);
end;
constructor TEvent.CreateSimple;
begin
Create (NIL, TRUE, FALSE, '');
end;
function TEvent.PulseEvent: boolean;
begin
Result := Windows.PulseEvent (Handle);
end;
function TEvent.ResetEvent: boolean;
begin
Result := Windows.ResetEvent (Handle);
end;
function TEvent.SetEvent: boolean;
begin
Result := Windows.SetEvent (Handle);
end;
{ TMQThread }
procedure TMQThread.EnsureMessageQueue;
var
rMsg: TMsg;
begin
{ signal to creating thread that we are ready! }
PeekMessage (rMsg, 0, 0, 0, PM_NOREMOVE); // force thread message queue!
SignalReady; // notify requesting thread we're open for business
end;
function TMQThread.ProcessMessage (var rMsg: TMsg): boolean;
begin
Result := FALSE;
end;
constructor TMQThread.Create (bSuspend: boolean);
begin
inherited Create (bSuspend);
FReadyEvent := TEvent.CreateSimple;
QuitWaitTimeout := cDefMQThreadQuitWaitTimeout;
end;
destructor TMQThread.Destroy;
begin
FReadyEvent.Free;
inherited;
end;
procedure TMQThread.Execute;
var
rMsg: TMsg;
begin
EnsureMessageQueue;
{ thread message loop }
while (TRUE) do
begin
if (GetMessage (rMsg, 0, 0, 0)) then
begin
{ handle message }
ProcessMessage (rMsg);
{ check any next pending messages }
Continue;
end
else begin
Terminate;
end; { else }
if (Terminated) then Break;
end; { while }
end;
function TMQThread.Quit (bWait: boolean): boolean;
begin
if not (Terminated) then
begin
PostThreadMessage (ThreadId, WM_QUIT, 0, 0);
if (bWait) then WaitForQuit;
end; { if }
Result := TRUE;
end;
procedure TMQThread.SignalReady;
begin
Assert (FReadyEvent <> NIL);
FReadyEvent.SetEvent;
end;
procedure TMQThread.WaitForQuit;
var
wr: TWaitResult;
begin
Verify (ThreadId <> GetCurrentThreadId,
'Message queue thread cannot be terminated from within its own thread!'
);
wr := WaitForThreadSyncObject (Handle, QuitWaitTimeout);
{ if wait was unsuccessful, take thread by force }
if (wr <> wrSignaled) then
TerminateThread (Handle, 1);
end;
function TMQThread.WaitForReady: boolean;
begin
Assert (FReadyEvent <> NIL);
Result := (FReadyEvent.WaitFor (INFINITE) = wrSignaled);
end;
{ apartment handler window }
function ApartmentThreadWndProc (hWndTarget: HWND; iMessage, wParam, lParam: longint): longint; stdcall;
var
at: TApartmentThread;
ao: TApartmentObject;
pUnk: IUnknown;
pciInfo: PCreateInstanceInfo absolute wParam;
begin
Result := 0; // default to success
if (UINT (iMessage) = WM_CREATEOBJECTINTHREAD) then
begin
{ wParam points to a PCreateInstanceInfo }
Assert (pciInfo <> NIL);
at := pciInfo^.ApartmentThread;
Assert (at <> NIL);
with at do
begin
ao := pciInfo^.ApartmentObject;
Assert (ao <> NIL);
with ao do
begin
{ class factory create }
Assert (@FCreateInstanceFunc <> NIL);
FCreateResult := FCreateInstanceFunc (Apartment, NIL, FCreateIID, pUnk);
{ marshal newly created interface pointer }
if Succeeded (FCreateResult) then
FCreateResult := MarshalInterface (FCreateIID, pUnk);
{ return status }
if not (Succeeded (FCreateResult)) then Result := FCreateResult;
end; { with }
end; { with }
end
else
if (iMessage = WM_QUIT) then
begin
DestroyWindow (hWndTarget);
end
else begin
Result := DefWindowProc (hWndTarget, iMessage, wParam, lParam);
end; { else }
end;
var
cApartmentThreadWindowClass: TWndClass = (
style: 0;
lpfnWndProc: @ApartmentThreadWndProc;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: NIL;
lpszClassName: 'TApartmentThreadWindow'
);
function CreateApartmentThreadWindow: HWnd;
var
pWndClass: TWndClass;
bRegistered: boolean;
begin
cApartmentThreadWindowClass.hInstance := HInstance;
bRegistered := GetClassInfo (
HInstance, cApartmentThreadWindowClass.lpszClassName, pWndClass
);
{ need to register? }
if not (bRegistered) or (pWndClass.lpfnWndProc <> @ApartmentThreadWndProc) then
begin
if (bRegistered) then
Windows.UnregisterClass (cApartmentThreadWindowClass.lpszClassName, HInstance);
Windows.RegisterClass(cApartmentThreadWindowClass);
end; { if }
{ create }
Result := CreateWindow (
cApartmentThreadWindowClass.lpszClassName, '', 0, 0, 0, 0, 0, 0, 0, HInstance, NIL
);
end;
{ TObjectMarshaler }
procedure TObjectMarshaler.ReleaseStream;
begin
{ release any held/marshaled object }
IStream (FStream) := NIL;
end;
constructor TObjectMarshaler.CreateMarshalObject (const iid: TGUID; const pUnk: IUnknown);
begin
Verify (not (IsEqualIID (iid, GUID_NULL)) and (pUnk <> NIL), 'Invalid object parameters');
inherited Create;
MarshalObject (iid, pUnk);
end;
constructor TObjectMarshaler.CreateMarshalOleObject (const vObj: olevariant);
begin
CreateMarshalObject (IDispatch, IDispatch (vObj) as IUnknown);
end;
destructor TObjectMarshaler.Destroy;
begin
ReleaseStream;
inherited;
end;
function TObjectMarshaler.MarshalObject (const iid: TGUID; const pUnk: IUnknown): boolean;
begin
Assert (pUnk <> NIL);
ReleaseStream;
OleCheck (CoMarshalInterThreadInterfaceInStream (iid, pUnk, IStream (FStream)));
FMarshalIID := iid;
Result := TRUE;
end;
function TObjectMarshaler.MarshalOleObject (const vObj: olevariant): boolean;
begin
Assert (not VarIsEmpty (vObj));
{ marshal as IDispatch }
Result := MarshalObject (IDispatch, IDispatch (vObj) as IUnknown);
end;
function TObjectMarshaler.UnMarshalObject (out pObj): boolean;
begin
Result := FALSE;
if (FStream = NIL) then Exit;
OleCheck (CoGetInterfaceAndReleaseStream (IStream (FStream), FMarshalIID, pObj));
FStream := NIL;
Result := TRUE;
end;
function TObjectMarshaler.UnMarshalOleObject (out vObj: olevariant): boolean;
var
pDispatch: IDispatch;
begin
Result := UnMarshalObject (pDispatch);
if (Result) then vObj := pDispatch;
end;
{ TApartmentManagerObject }
function TApartmentManagerObject.GetAllocator: TApartmentAllocator;
begin
if (FAllocator = NIL) then FAllocator := TApartmentAllocator.Create (Self);
Result := FAllocator;
end;
function TApartmentManagerObject.GetServerObjectCount: integer;
begin
Result := -1; // -1 means not implemented
end;
destructor TApartmentManagerObject.Destroy;
begin
if (FAllocator <> NIL) then FAllocator.Free;
FAllocator := NIL;
inherited;
end;
function TApartmentManagerObject.CanCreateInstance (var hr: HResult): boolean;
begin
Result := TRUE;
if (ServerIsShuttingDown) then Result := FALSE;
if not (Result) then
begin
hr := CLASS_E_CLASSNOTAVAILABLE;
if (cNT4DCOMSupported) then
begin
hr := CO_E_SERVER_STOPPING;
Beep;
end; { if }
end; { if }
end;
function TApartmentManagerObject.CreateInstance (
cf: TComObjectFactory; pfnci: TFuncFactoryCreateInstance;
tm: TThreadingModel; am: TSTAAllocMode; pUnkOuter: IUnknown;
const iid: TGUID; out pObject): HResult;
var
pcf: IClassFactory;
apt: TApartment;
rciData: TCreateInstanceData;
begin
Assert (@pfnci <> NIL);
//Result := E_FAIL;
{ ensure server is locked while we are in the process of creating an instance!
if we rely on the OS to call LockServer, we're doomed! =)
}
if (cf <> NIL) then pcf := cf as IClassFactory else pcf := NIL;
if (pcf <> NIL) then pcf.LockServer (TRUE);
try
{ proactive apartments are only supported for EXE servers }
if (IsLibrary) then
begin
Result := pfnci (NIL, pUnkOuter, iid, pObject);
Exit;
end; { if }
{ plug shutdown race-condition! }
if not CanCreateInstance (Result) then Exit;
if (pUnkOuter <> NIL) then
begin
{ cannot aggregate across apartments }
Result := CLASS_E_NOAGGREGATION;
Exit;
end
else begin
{ init rciData }
Fillchar (rciData, sizeof (rciData), 0);
if (cf <> NIL) then rciData.IsThreadedComClass := IsThreadedFactory (cf);
case tm of
tmApartment :
begin
{ allocate then create in STA }
if (Allocator <> NIL) then
begin
apt := Allocator.AllocateApartment (am);
if (apt <> NIL) then
begin
Result := apt.CreateInstance (pfnci, IID, @rciData, pObject);
Exit;
end; { if }
end; { if }
end;
tmFree,
tmBoth :
begin
{ "both" threading is really not defined for outproc objects;
by default, we just assume that the user wants MTA
}
apt := Apartments.EnsureMTA;
if (apt <> NIL) then
begin
Result := apt.CreateInstance (pfnci, IID, @rciData, pObject);
Exit;
end; { if }
end;
end; { case }
{ for all other settings, use default handler! }
Result := pfnci (NIL, pUnkOuter, IID, pObject);
end; { else }
finally
if (pcf <> NIL) then pcf.LockServer (FALSE);
end; { finally }
end;
procedure TApartmentManagerObject.LastReleased (var bShutdown: boolean);
begin
end;
procedure TApartmentManagerObject.Resume;
begin
end;
{ TApartmentsGCThread }
function TApartmentsGCThread.GetManager: TApartmentManagerObject;
begin
Result := FOwner.Manager;
end;
function TApartmentsGCThread.ProcessMessage (var rMsg: TMsg): boolean;
begin
Result := FALSE;
if (Manager.ServerIsShuttingDown) then Exit;
if (rMsg.Message = WM_GARBAGECOLLECTCOMSERVER) then
begin
GarbageCollect (TObject (rMsg.lParam));
Result := TRUE; { handled }
end; { if }
end;
constructor TApartmentsGCThread.Create (Owner: TApartmentsGC; tp: TThreadPriority);
begin
Assert (Owner <> NIL);
inherited Create (TRUE);
FOwner := Owner;
Priority := tp;
Resume;
end;
procedure TApartmentsGCThread.GarbageCollect (Sender: TObject);
begin
with Manager do
begin
if (ServerIsShuttingDown) then Exit;
if (Sender = NIL) then
Apartments.DeleteEmptyApartments
else
Apartments.SafeRemoveApartment (TApartment (Sender));
end; { with }
end;
{ TApartmentsGC }
procedure TApartmentsGC.InitializeThread (tp: TThreadPriority);
begin
FThread := TApartmentsGCThread.Create (Self, tp);
FThread.WaitForReady;
end;
constructor TApartmentsGC.Create (am: TApartmentManagerObject; tp: TThreadPriority);
begin
Assert (am <> NIL);
inherited Create;
FManager := am;
InitializeThread (tp);
Verify (Thread <> NIL, 'Garbage collector thread must be initialized!');
end;
destructor TApartmentsGC.Destroy;
begin
Terminate;
FThread.Free;
inherited;
end;
procedure TApartmentsGC.Activate (Sender: TObject);
begin
PostThreadMessage (Thread.ThreadId, WM_GARBAGECOLLECTCOMSERVER, 0, lParam (Sender));
end;
procedure TApartmentsGC.Terminate;
begin
Verify (GetCurrentThreadId <> Thread.ThreadID,
'Garbage collector cannot be terminated from within its own thread!'
);
Thread.Quit (TRUE);
end;
{ TApartmentObject }
procedure TApartmentObject.Clear;
begin
FCreateStream := NIL;
FCreateResult := E_FAIL;
end;
function TApartmentObject.CreateOnThread (pciInfo: PCreateInstanceInfo): boolean;
var
at: TApartmentThread;
begin
Assert (pciInfo <> NIL);
at := pciInfo^.ApartmentThread;
Assert (at <> NIL);
Clear;
pciInfo^.ApartmentObject := Self;
Result := (SendMessage (
at.ServerWindow, WM_CREATEOBJECTINTHREAD, wParam (pciInfo), 0) = 0
);
end;
function TApartmentObject.GetInstance (out pObject): HResult;
begin
Result := UnmarshalInterface (FCreateIID, pObject);
end;
function TApartmentObject.MarshalInterface (const iid: TGUID; pUnk: IUnknown): HResult;
begin
Result := CoMarshalInterThreadInterfaceInStream (iid, pUnk, IStream (FCreateStream));
end;
function TApartmentObject.UnmarshalInterface (const iid: TGUID; out pObject): HResult;
begin
Assert (FCreateStream <> NIL);
Result := CoGetInterfaceAndReleaseStream (IStream (FCreateStream), iid, pObject);
FCreateStream := NIL;
end;
constructor TApartmentObject.Create (
pCreateInstance: TFuncFactoryCreateInstance; const iid: TGUID);
begin
Assert (@pCreateInstance <> NIL);
inherited Create;
FCreateInstanceFunc := pCreateInstance;
FCreateIID := iid;
end;
destructor TApartmentObject.Destroy;
begin
inherited;
end;
function TApartmentObject.CreateInApartmentThread (pciInfo: PCreateInstanceInfo; out pObject): HResult;
var
at: TApartmentThread;
begin
Assert (pciInfo <> NIL);
at := pciInfo^.ApartmentThread;
Assert (at <> NIL);
Assert (at.ThreadId <> GetCurrentThreadId);
{ create object on thread }
if (CreateOnThread (pciInfo)) then
Result := GetInstance (pObject)
else
Result := FCreateResult;
end;
{ TApartmentThread }
procedure TApartmentThread.Execute;
var
rMsg: TMsg;
begin
InitializeCOM (TRUE, Apartment.ApartmentType);
try
{ create apartment window that handles object creation }
InitServerWindow (TRUE);
{ flush out pending window messages }
while PeekMessage (rMsg, FServerWindow, 0, 0, PM_NOREMOVE) do
DispatchMessage (rMsg);
{ enter default loop }
inherited;
finally
InitializeCOM (FALSE, Apartment.ApartmentType);
end; { finally }
end;
function TApartmentThread.GetApartment: TApartment;
begin
Result := FOwner.FOwner;
end;
procedure TApartmentThread.InitServerWindow (bInit: boolean);
begin
if (bInit) then
begin
if (ServerWindow <> 0) then Exit;
FServerWindow := CreateApartmentThreadWindow;
end
else begin
if (ServerWindow = 0) then Exit;
SendMessage (ServerWindow, WM_QUIT, 0, 0);
FServerWindow := 0;
end; { else }
end;
procedure TApartmentThread.InstanceCreated (pciInfo: PCreateInstanceInfo; pUnk: IUnknown);
begin
end;
function TApartmentThread.ProcessMessage (var rMsg: TMsg): boolean;
begin
DispatchMessage (rMsg);
Result := TRUE;
end;
constructor TApartmentThread.Create (Owner: TApartmentThreads);
begin
Assert (Owner <> NIL);
inherited Create (TRUE);
FOwner := Owner;
end;
destructor TApartmentThread.Destroy;
begin
InitServerWindow (FALSE);
inherited;
end;
function TApartmentThread.CreateInstance (pCreateInstance: TFuncFactoryCreateInstance;
const iid: TGUID; pData: pointer; out pObject): HResult;
var
ao: TApartmentObject;
rciInfo: TCreateInstanceInfo;
begin
Assert (@pCreateInstance <> NIL);
{ init rciInfo }
Fillchar (rciInfo, sizeof (rciInfo), 0);
rciInfo.ApartmentThread := Self;
rciInfo.Data := pData;
if (GetCurrentThreadId = ThreadId) then
begin
{ if we're requesting a create instance on this thread, then we are already
in this thread's apartment and thus, there is no need to create and
marshal it out of this apartment.
}
Result := pCreateInstance (Apartment, NIL, iid, pObject);
end
else begin
{ Create and marshal out from this thread }
ao := TApartmentObject.Create (pCreateInstance, iid);
try
Result := ao.CreateInApartmentThread (@rciInfo, pObject);
finally
ao.Free;
end; { finally }
end; { else }
{ log instance creation }
if (Succeeded (Result)) then InstanceCreated (@rciInfo, IUnknown (pObject));
end;
function TApartmentThread.Quit (bWait: boolean): boolean;
begin
InitServerWindow (FALSE);
Result := inherited Quit (bWait);
end;
{ TApartmentThreads }
function TApartmentThreads.CreateThread: TApartmentThread;
begin
Result := cDefApartmentThreadClass.Create (Self);
end;
function TApartmentThreads.GetItemById (iThreadId: integer): TApartmentThread;
var
i: integer;
begin
LockThreads (TRUE);
try
Result := NIL;
for i := 0 to FThreads.Count - 1 do
if (TApartmentThread (FThreads [i]).ThreadId = THandle (iThreadId)) then
begin
Result := FThreads [i];
Break;
end; { if }
finally
LockThreads (FALSE);
end; { finally }
end;
function TApartmentThreads.GetItems (i: integer): TApartmentThread;
begin
LockThreads (TRUE);
try
Assert ((i >= 0) and (i < Count));
Result := FThreads [i];
finally
LockThreads (FALSE);
end; { finally }
end;
procedure TApartmentThreads.LockThreads (bLock: boolean);
begin
Assert (FCSThreads <> NIL);
FCSThreads.Lock (bLock);
end;
constructor TApartmentThreads.Create (Owner: TApartment);
begin
Assert (Owner <> NIL);
inherited Create;
FCSThreads := TCriticalSection.Create;
FOwner := Owner;
FThreads := TList.Create;
end;
destructor TApartmentThreads.Destroy;
begin
Clear;
FThreads.Free;
FCSThreads.Free;
inherited;
end;
function TApartmentThreads.AddThread (at: TApartmentThread): integer;
begin
Assert (at <> NIL);
LockThreads (TRUE);
try
Result := FThreads.Add (at);
finally
LockThreads (FALSE);
end; { finally }
end;
procedure TApartmentThreads.Clear;
var
i: integer;
begin
LockThreads (TRUE);
try
Terminate;
for i := 0 to Count - 1 do
Items [i].Free;
FThreads.Clear;
finally
LockThreads (FALSE);
end; { finally }
end;
function TApartmentThreads.Count: integer;
begin
LockThreads (TRUE);
try
Result := FThreads.Count;
finally
LockThreads (FALSE);
end; { finally }
end;
function TApartmentThreads.NewThread: TApartmentThread;
procedure ValidateRequest;
begin
{ Verify STAs only have at most 1 thread }
if (Apartment.ApartmentType = atSTA) then
Verify ((Count < 1), 'Only 1 thread can be created in a single-threaded apartment!');
end;
var
at: TApartmentThread;
begin
LockThreads (TRUE);
try
ValidateRequest;
{ new thread }
at := CreateThread;
FThreads.Add (at);
at.Resume;
{ wait for thread to be ready for use }
at.WaitForReady;
Result := at;
finally
LockThreads (FALSE);
end; { finally }
end;
function TApartmentThreads.Terminate: boolean;
var
i: integer;
begin
LockThreads (TRUE);
try
{ signal and wait for done }
for i := 0 to Count - 1 do
Items [i].Quit (TRUE);
Result := TRUE;
finally
LockThreads (FALSE);
end; { finally }
end;
{ TApartment }
function TApartment.GetManager: TApartmentManagerObject;
begin
Result := FOwner.Manager;
end;
function TApartment.CreateThreads: TApartmentThreads;
begin
Result := TApartmentThreads.Create (Self);
end;
function TApartment.GetLockCount: integer;
begin
LockRefCount (TRUE);
try
Result := FLockCount;
finally
LockRefCount (FALSE);
end; { finally }
end;
procedure TApartment.LastReleased;
begin
{ wake garbage collector }
if not (Manager.ServerIsShuttingDown) and (AutoDelete) then
begin
MarkForDelete := TRUE;
Manager.GarbageCollect (Self);
end; { if }
end;
procedure TApartment.SetAutoDelete (bSet: boolean);
begin
LockRefCount (TRUE);
try
FAutoDelete := bSet;
finally
LockRefCount (FALSE);
end; { finally }
end;
procedure TApartment.SetPooled (bSet: boolean);
begin
if (Pooled = bSet) then Exit;
FPooled := bSet;
//if (Pooled) then AutoDelete := FALSE; pooled ones can be removed too! =)
end;
constructor TApartment.Create (Owner: TApartments; at: TApartmentType);
begin
Assert (Owner <> NIL);
inherited Create;
FCSRefCount := TCriticalSection.Create;
FThreads := CreateThreads;
Verify (FThreads <> NIL, 'Apartment must have at least 1 thread!');
FApartmentType := at;
FOwner := Owner;
FAutoDelete := (at = atSTA);
end;
destructor TApartment.Destroy;
begin
FThreads.Free;
FCSRefCount.Free;
inherited;
end;
function TApartment.CreateInstance (pCreateInstance: TFuncFactoryCreateInstance;
const iid: TGUID; pData: pointer; out pObject): HResult;
begin
Assert (Threads.Count > 0);
Result := Threads [0].CreateInstance (pCreateInstance, iid, pData, pObject);
end;
function TApartment.CountObject (bLock: boolean): integer;
begin
LockRefCount (TRUE);
try
if (bLock) then
begin
inc (FLockCount);
Result := FLockCount;
if (Result > 0) then MarkForDelete := FALSE;
end
else begin
dec (FLockCount);
Result := FLockCount;
if (Result = 0) then LastReleased;
end; { else }
finally
LockRefCount (FALSE);
end; { finally }
end;
function TApartment.GarbageCollect: boolean;
begin
Result := TRUE;
end;
procedure TApartment.LockRefCount (bLock: boolean);
begin
Assert (FCSRefCount <> NIL);
FCSRefCount.Lock (bLock);
end;
function TApartment.TerminateThreads: boolean;
begin
Result := Threads.Terminate;
end;
{ TApartments }
function TApartments.CreateApartment (at: TApartmentType): TApartment;
begin
Result := cDefApartmentClass.Create (Self, at);
end;
function TApartments.GetActiveApartment: TApartment;
var
thrd: TApartmentThread;
begin
if not (GetCurrentApartment (Result, thrd)) then Result := NIL;
end;
function TApartments.GetActiveApartmentName: string;
var
apt: TApartment;
begin
Result := '';
apt := ActiveApartment;
if (apt <> NIL) then Result := apt.Name;
end;
function TApartments.GetItemByName (const sName: string): TApartment;
var
i: integer;
begin
LockApartments (TRUE);
try
Result := NIL;
for i := 0 to Count - 1 do
if (AnsiCompareText (Items [i].Name, sName) = 0) then
begin
Result := Items [i];
Break;
end; { if }
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.GetItems (i: integer): TApartment;
begin
LockApartments (TRUE);
try
Result := NIL;
if (i < 0) or (i >= Count) then Exit;
Result := FApartments [i];
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.GetLockCount: integer;
var
i: integer;
begin
LockApartments (TRUE);
try
Result := 0;
for i := 0 to Count - 1 do
Result := Result + Items [i].LockCount;
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.GetObjects (i: integer): pointer;
begin
LockApartments (TRUE);
try
Result := NIL;
if (i < 0) or (i >= Count) then Exit;
Result := Items [i].Data;
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.GetPooledCount: integer;
var
i: integer;
begin
LockApartments (TRUE);
try
Result := 0;
for i := 0 to Count - 1 do
if (Items [i].Pooled) then
Result := Result + 1;
finally
LockApartments (FALSE);
end; { finally }
end;
procedure TApartments.LockApartments (bLock: boolean);
begin
Assert (FCSApartments <> NIL);
FCSApartments.Lock (bLock);
end;
procedure TApartments.SetObjects (i: integer; pObj: pointer);
begin
LockApartments (TRUE);
try
if (i < 0) or (i >= Count) then Exit;
Items [i].Data := pObj;
finally
LockApartments (FALSE);
end; { finally }
end;
constructor TApartments.Create (am: TApartmentManagerObject);
begin
Assert (am <> NIL);
inherited Create;
FCSApartments := TCriticalSection.Create;
FApartments := TList.Create;
FManager := am;
end;
destructor TApartments.Destroy;
begin
Clear;
FApartments.Free;
FCSApartments.Free;
inherited;
end;
procedure TApartments.Clear;
var
i: integer;
begin
LockApartments (TRUE);
try
TerminateThreads;
for i := 0 to Count - 1 do
Items [i].Free;
FApartments.Clear;
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.Count: integer;
begin
LockApartments (TRUE);
try
Result := FApartments.Count;
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.DeleteApartment (i: integer): boolean;
var
apt: TApartment;
begin
LockApartments (TRUE);
try
Result := FALSE;
if (i < 0) or (i > Count) then Exit;
apt := Items [i];
if not (apt.TerminateThreads) then Exit;
FApartments.Delete (i);
apt.Free;
Result := TRUE;
finally
LockApartments (FALSE);
end; { finally }
end;
procedure TApartments.DeleteEmptyApartments;
var
i: integer;
begin
{ this method should only be called from a low-priority garbage collector thread }
LockApartments (TRUE);
try
{ free any hanging unlocked apartments }
i := 0;
while (i < Count) do
begin
{ check shutdown per pass }
if (Manager.ServerIsShuttingDown) then Exit;
if (Items [i].AutoDelete) and (Items [i].MarkForDelete) then
begin
DeleteApartment (i);
Continue;
end; { if }
{ next }
i := i + 1;
end; { while }
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.EnsureMTA: TApartment;
begin
LockApartments (TRUE);
try
Result := NIL;
if not (FindMTA (Result)) then
Result := NewApartment ('', atMTA, TRUE);
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.FindMTA (var mta: TApartment): boolean;
var
i: integer;
begin
Result := FALSE;
LockApartments (TRUE);
try
for i := 0 to FApartments.Count - 1 do
if (TApartment (FApartments [i]).ApartmentType = atMTA) then
begin
Result := TRUE;
mta := FApartments [i];
Break;
end; { if }
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.GarbageCollect (iCount: integer): integer;
var
i: integer;
bgc: boolean;
begin
Result := 0;
LockApartments (TRUE);
try
{ if iCount = -1, do all }
if (iCount = -1) then iCount := Count;
for i := Count - 1 downto 0 do
begin
{ check shutdown per pass }
if (Manager.ServerIsShuttingDown) then Exit;
if (iCount <= 0) then Break;
bgc := Items [i].GarbageCollect;
if (bgc) then
begin
dec (iCount);
inc (Result);
end; { if }
end; { for }
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.GetCurrentApartment (var apt: TApartment; var thrd: TApartmentThread): boolean;
var
i: integer;
begin
LockApartments (TRUE);
try
Result := FALSE;
{ this reverse-order might be more efficient! }
for i := FApartments.Count - 1 downto 0 do
begin
apt := FApartments [i];
thrd := apt.FThreads.ItemById [GetCurrentThreadId];
if (thrd <> NIL) then
begin
Result := TRUE;
Break;
end; { if }
end; { for }
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.HasMTA: boolean;
var
mta: TApartment;
begin
Result := FindMTA (mta);
end;
function TApartments.IndexOfApartment (apt: TApartment): integer;
var
i: integer;
begin
Result := -1;
if (apt = NIL) then Exit;
LockApartments (TRUE);
try
for i := 0 to Count - 1 do
if (Items [i] = apt) then
begin
Result := i;
Break;
end; { if }
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.NewApartment (const sName: string; at: TApartmentType; bCreateThread: boolean): TApartment;
procedure ValidateRequest;
begin
{ Verify only 1 MTA exists }
if (at = atMTA) then
Verify (not (HasMTA), 'Only 1 multithreaded apartment can be created per process!');
end;
var
apt: TApartment;
begin
LockApartments (TRUE);
try
ValidateRequest;
{ create apartment }
apt := CreateApartment (at);
apt.Name := sName;
FApartments.Add (apt);
{ create thread? }
if (bCreateThread) then
begin
apt.Threads.NewThread;
{ generate default apartment names }
if (sName = '') then
case at of
atSTA :
apt.Name := Format ('STA (%d)', [apt.Threads [0].ThreadId]);
atMTA :
apt.Name := Format ('MTA (%d)', [apt.Threads [0].ThreadId]);
end; { case }
end; { if }
Result := apt;
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.NewPooledSTA: TApartment;
var
apt: TApartment;
begin
LockApartments (TRUE);
try
apt := NewApartment ('', atSTA, TRUE);
apt.Pooled := TRUE;
apt.Name := Format ('STA Pool (%d)', [apt.Threads [0].ThreadId]);
Result := apt;
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.RemoveApartment (apt: TApartment): boolean;
var
i: integer;
begin
LockApartments (TRUE);
try
i := IndexOfApartment (apt);
Result := DeleteApartment (i);
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.SafeRemoveApartment (apt: TApartment): boolean;
begin
Assert (apt <> NIL);
LockApartments (TRUE);
try
Result := FALSE;
if (apt.MarkForDelete) then Result := RemoveApartment (apt);
finally
LockApartments (FALSE);
end; { finally }
end;
function TApartments.TerminateThreads: boolean;
var
i: integer;
begin
LockApartments (TRUE);
try
Result := TRUE;
for i := 0 to Count - 1 do
begin
Result := Items [i].TerminateThreads;
if not (Result) then Break;
end; { for }
finally
LockApartments (FALSE);
end; { finally }
end;
{ TApartmentAllocator }
constructor TApartmentAllocator.Create (am: TApartmentManagerObject);
begin
Assert (am <> NIL);
inherited Create;
FApartmentIndex := -1;
FManager := am;
end;
destructor TApartmentAllocator.Destroy;
begin
inherited;
end;
function TApartmentAllocator.AllocateApartment (am: TSTAAllocMode): TApartment;
var
apt: TApartment;
begin
Result := NIL;
with Manager do
begin
case am of
amPooled :
begin
Apartments.LockApartments (TRUE);
try
{ ensure pooled STA }
if (Apartments.PooledCount < GetPooledSTACount) then
begin
{ alloc new }
Result := Apartments.NewPooledSTA;
PostMessage(Application.MainForm.Handle, 8888, 51,0); // by cxg 创建一个新的
{ if alloced, assume it baby! }
if (Result <> NIL) then Exit;
end; { if }
{ safety! bail if no pool! }
if (Apartments.PooledCount <= 0) then Exit;
{ pool, round-robin! }
while (TRUE) do
begin
FApartmentIndex := FApartmentIndex + 1;
if (FApartmentIndex >= Apartments.Count) then
FApartmentIndex := 0;
if (Apartments [FApartmentIndex].Pooled) then
begin
Result := Apartments [FApartmentIndex];
PostMessage(Application.MainForm.Handle, 8888, 53,0); // by cxg 使用一个空闲的
Break;
end; { if }
end; { while }
finally
if (Result <> NIL) then Result.MarkForDelete := FALSE; { ! }
Apartments.LockApartments (FALSE);
PostMessage(Application.MainForm.Handle, 8888, 52,0); // by cxg 归还池中
end; { finally }
end;
amDistinct :
begin
{ distinct allocation. always create new STA with 1 thread }
apt := Apartments.NewApartment ('', atSTA, TRUE);
Verify (apt <> NIL, 'Unable to allocate a new/distinct apartment!');
Result := apt;
end;
amDefault :
{ do nothing, ApartmentManager will know to create the object in the
default/main apartment
}
end; { case }
end; { with }
end;
{ TApartmentStats }
function TApartmentStats.GetGrid: TStringGrid;
begin
if (FGrid = NIL) then
begin
FGrid := TStringGrid.Create (Self);
with FGrid do
begin
Visible := FALSE;
Options := Options + [goRowSelect, goColSizing];
DefaultColWidth := 120;
Width := (DefaultColWidth + 5) * 3;
FixedCols := 1;
ColCount := 3;
DefaultRowHeight := 18;
FixedRows := 1;
RowCount := 2;
Cells [0, 0] := 'Apartment';
Cells [1, 0] := 'Thread count';
Cells [2, 0] := 'Object count';
end; { with }
if (Owner is TWinControl) then FGrid.Parent := TWinControl (Owner);
end; { if }
Result := FGrid;
end;
function TApartmentStats.GetTimer: TTimer;
begin
if (FTimer = NIL) then
begin
FTimer := TTimer.Create (Self);
FTimer.Enabled := FALSE;
FTimer.OnTimer := TimerUpdate;
end; { if }
Result := FTimer;
end;
procedure TApartmentStats.Notification (cmp: TComponent; op: TOperation);
begin
if (cmp = GridParent) and (op = opRemove) then
GridParent := NIL;
inherited;
end;
procedure TApartmentStats.SetAlign (al: TAlign);
begin
FAlign := al;
if not (csDesigning in ComponentState) then
Grid.Align := al;
end;
procedure TApartmentStats.SetEnabled (bSet: boolean);
begin
FEnabled := bSet;
if not (csDesigning in ComponentState) then
Timer.Enabled := bSet;
end;
procedure TApartmentStats.SetGridParent (ctlParent: TWinControl);
begin
FGridParent := ctlParent;
if not (csDesigning in ComponentState) then
if (ctlParent <> NIL) then
Grid.Parent := ctlParent;
end;
procedure TApartmentStats.SetUpdateInterval (iValue: integer);
begin
FUpdateInterval := iValue;
if not (csDesigning in ComponentState) then
Timer.Interval := iValue;
end;
procedure TApartmentStats.SetVisible (bSet: boolean);
begin
FVisible := bSet;
if not (csDesigning in ComponentState) then
begin
Grid.Visible := bSet;
if (Visible) and (Enabled) then UpdateGrid;
end; { if }
end;
procedure TApartmentStats.TimerUpdate (Sender: TObject);
begin
if (Visible) then UpdateGrid;
end;
procedure TApartmentStats.UpdateGrid;
var
apt: TApartment;
sMainObjects: string;
i, iThreadCount, iObjectCount, iMainObjectCount: integer;
begin
if (Apartments = NIL) then Exit;
iThreadCount := 0;
iObjectCount := 0;
{ Note: This grid updating process will lock the global apartments list
meaning that any calls that need to use the apartments (such as creating
new objects) will be blocked - which may cause serious performance problems.
Therefore, it is highly recommended that your TApartmentStats component be
enabled only for debugging purposes and disabled when in production.
}
Apartments.LockApartments (TRUE);
try
Grid.RowCount := Apartments.Count + 2;
if (Apartments.Count > 0) then
begin
for i := 0 to Apartments.Count - 1 do
begin
apt := Apartments [i];
if (apt = NIL) then break;
{ Load stats }
with Grid do
begin
inc (iThreadCount, apt.Threads.Count);
inc (iObjectCount, apt.LockCount);
Cells [0, i + 2] := apt.Name;
Cells [1, i + 2] := IntToStr (apt.Threads.Count);
Cells [2, i + 2] := IntToStr (apt.LockCount);
end;
end;
end; { if }
{ calc main object count }
iMainObjectCount := Apartments.Manager.ServerObjectCount - iObjectCount;
finally
Apartments.LockApartments (FALSE);
end; { finally }
{ totals }
Grid.Cells [0, 1] := 'Total . . .';
Grid.Cells [1, 1] := IntToStr (iThreadCount) + ' (+ Main Thread)';
sMainObjects := '';
if (iMainObjectCount >= 0) then sMainObjects := IntToStr (iMainObjectCount) + ' ';
Grid.Cells [2, 1] := IntToStr (iObjectCount) + ' (+ ' + sMainObjects + 'Main Objects)';
end;
constructor TApartmentStats.Create (pOwner: TComponent);
begin
inherited Create (pOwner);
Enabled := TRUE;
UpdateInterval := 1000;
Visible := TRUE;
Align := alClient;
end;
destructor TApartmentStats.Destroy;
begin
{ FGrid and FTimer are both owned by self, so were ok! }
inherited;
end;
{ TThreadedComObject }
function TThreadedComObject.GetFTM: IUnknown;
begin
SelfLock.Lock (TRUE);
try
if (FFTM = NIL) and (cNT4DCOMSupported) then
begin
OleCheck (CoCreateFreeThreadedMarshaler (Self, FFTM));
end; { if }
Result := FFTM;
finally
SelfLock.Lock (FALSE);
end; { finally }
end;
function TThreadedComObject.GetRefCountLock: TCriticalSection;
begin
{ this routine is not thread-safe, however, this routine is guaranteed to
be called the first time this object is created so were ok!
}
if (FCSRefCount = NIL) then FCSRefCount := TCriticalSection.Create;
Result := FCSRefCount;
end;
function TThreadedComObject.GetSelfLock: TCriticalSection;
begin
// ensures SelfLock is initialized at create-time!
Assert (FCSSelfLock <> NIL, 'SelfLock is undefined. You forgot to call inherited Initialize first in your overriden Initialize!');
Result := FCSSelfLock;
end;
destructor TThreadedComObject.Destroy;
var
apt: TApartment;
begin
apt := Apartment;
FFTM := NIL;
if (FCSRefCount <> NIL) then FCSRefCount.Free;
FCSRefCount := NIL;
if (FCSSelfLock <> NIL) then FCSSelfLock.Free;
FCSSelfLock := NIL;
inherited;
if (apt <> NIL) then apt.CountObject (FALSE);
end;
procedure TThreadedComObject.Initialize;
begin
FCSSelfLock := TCriticalSection.Create;
{ initialize owner apartment }
if not (IsLibrary) then
begin
FApartment := ApartmentManager.Apartments.ActiveApartment;
if (Apartment <> NIL) then Apartment.CountObject (TRUE);
end; { if }
inherited;
end;
function TThreadedComObject.ObjAddRef: integer;
begin
{$IFDEF D3}
RefCountLock.Lock (TRUE);
try
{ make threadsafe for D3 }
Result := inherited ObjAddRef;
finally
RefCountLock.Lock (FALSE);
end; { finally }
{$ELSE}
Result := inherited ObjAddRef;
{$ENDIF}
end;
function TThreadedComObject.ObjRelease: integer;
begin
{$IFDEF D3}
Result := 1; // dummy
RefCountLock.Lock (TRUE);
try
Result := inherited ObjRelease;
finally
if (Result <> 0) then RefCountLock.Lock (FALSE);
end; { finally }
{$ELSE}
Result := inherited ObjRelease;
{$ENDIF}
end;
function TThreadedComObject.ObjQueryInterface (const IID: TGUID; out pObj): HResult;
begin
if (FTMSupported) and (IsEqualGuid (IID, IMarshal)) then
if (FTM <> NIL) then
begin
{ lazy-aggregate with FTM }
Result := FTM.QueryInterface (IID, pObj);
Exit;
end; { if }
Result := inherited ObjQueryInterface (IID, pObj);
end;
{ TThreadedAutoObject }
function TThreadedAutoObject.GetFTM: IUnknown;
begin
SelfLock.Lock (TRUE);
try
if (FFTM = NIL) and (cNT4DCOMSupported) then
begin
OleCheck (CoCreateFreeThreadedMarshaler (Self, FFTM));
end; { if }
Result := FFTM;
finally
SelfLock.Lock (FALSE);
end; { finally }
end;
function TThreadedAutoObject.GetRefCountLock: TCriticalSection;
begin
{ this routine is not thread-safe, however, this routine is guaranteed to
be called the first time this object is created so were ok!
}
if (FCSRefCount = NIL) then FCSRefCount := TCriticalSection.Create;
Result := FCSRefCount;
end;
function TThreadedAutoObject.GetSelfLock: TCriticalSection;
begin
// ensures SelfLock is initialized at create-time!
Assert (FCSSelfLock <> NIL, 'SelfLock is undefined. You forgot to call inherited Initialize first in your overriden Initialize!');
Result := FCSSelfLock;
end;
destructor TThreadedAutoObject.Destroy;
var
apt: TApartment;
begin
apt := Apartment;
FFTM := NIL;
if (FCSRefCount <> NIL) then FCSRefCount.Free;
FCSRefCount := NIL;
if (FCSSelfLock <> NIL) then FCSSelfLock.Free;
FCSSelfLock := NIL;
inherited;
if (apt <> NIL) then apt.CountObject (FALSE);
end;
procedure TThreadedAutoObject.Initialize;
begin
FCSSelfLock := TCriticalSection.Create;
{ initialize owner apartment }
if not (IsLibrary) then
begin
FApartment := ApartmentManager.Apartments.ActiveApartment;
if (Apartment <> NIL) then Apartment.CountObject (TRUE);
end; { if }
inherited;
end;
function TThreadedAutoObject.ObjAddRef: integer;
begin
{$IFDEF D3}
RefCountLock.Lock (TRUE);
try
{ make threadsafe for D3 }
Result := inherited ObjAddRef;
finally
RefCountLock.Lock (FALSE);
end; { finally }
{$ELSE}
Result := inherited ObjAddRef;
{$ENDIF}
end;
function TThreadedAutoObject.ObjRelease: integer;
begin
{$IFDEF D3}
Result := 1; // dummy
RefCountLock.Lock (TRUE);
try
Result := inherited ObjRelease;
finally
if (Result <> 0) then RefCountLock.Lock (FALSE);
end; { finally }
{$ELSE}
Result := inherited ObjRelease;
{$ENDIF}
end;
function TThreadedAutoObject.ObjQueryInterface (const IID: TGUID; out pObj): HResult;
begin
if (FTMSupported) and (IsEqualGuid (IID, IMarshal)) then
if (FTM <> NIL) then
begin
{ lazy-aggregate with FTM }
Result := FTM.QueryInterface (IID, pObj);
Exit;
end; { if }
Result := inherited ObjQueryInterface (IID, pObj);
end;
type
{ enhanced TVCLAutoObject. derives from TThreadedAutoObject }
TThreadedVCLAutoObject = class (TThreadedAutoObject, IVCLComObject)
private
FComponent: TComponent;
FOwnsComponent: Boolean;
protected
procedure FreeOnRelease;
function Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params;
VarResult, ExcepInfo, ArgErr: Pointer): HResult; override;
public
constructor Create(Factory: TComObjectFactory; Component: TComponent);
destructor Destroy; override;
procedure Initialize; override;
function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override;
end;
{ TThreadedVCLAutoObject }
constructor TThreadedVCLAutoObject.Create(Factory: TComObjectFactory;
Component: TComponent);
begin
FComponent := Component;
CreateFromFactory (Factory, nil);
end;
destructor TThreadedVCLAutoObject.Destroy;
begin
if FComponent <> nil then
begin
FComponent.VCLComObject := nil;
if FOwnsComponent then FComponent.Free;
end;
inherited Destroy;
end;
procedure TThreadedVCLAutoObject.FreeOnRelease;
begin
FOwnsComponent := True;
end;
procedure TThreadedVCLAutoObject.Initialize;
begin
inherited Initialize;
if FComponent = nil then
begin
FComponent := TComponentClass(Factory.ComClass).Create(nil);
FOwnsComponent := True;
end;
FComponent.VCLComObject := Pointer(IVCLComObject(Self));
end;
function TThreadedVCLAutoObject.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params;
VarResult, ExcepInfo, ArgErr: Pointer): HResult;
begin
Result := DispInvoke(Pointer(Integer(FComponent) +
TComponentFactory(Factory).DispIntfEntry^.IOffset),
TComponentFactory(Factory).DispTypeInfo, DispID, Flags,
TDispParams(Params), VarResult, ExcepInfo, ArgErr);
end;
function TThreadedVCLAutoObject.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
begin
Result := inherited ObjQueryInterface(IID, Obj);
if (Result <> 0) and (FComponent <> nil) then
if FComponent.GetInterface(IID, Obj) then Result := 0;
end;
type
TComServerHack = class (TComServerObject);
const
{ IExternalConnection constants }
EXTCONN_STRONG = $0001;
EXTCONN_WEAK = $0002;
EXTCONN_CALLABLE = $0004;
{ TThreadedComObjectFactory }
function TThreadedComObjectFactory.CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
out Obj): HResult;
begin
if (IsLibrary) then
Result := inherited CreateInstance (UnkOuter, IID, Obj)
else
Result := ApartmentManager.CreateInstance (Self, DoCreateInstance, ThreadingModel, STAAllocMode, UnkOuter, iid, Obj);
end;
function TThreadedComObjectFactory.LockServer(fLock: BOOL): HResult;
begin
{$IFDEF D3}
TComServerHack (ComServer).CountObject (fLock);
{$ENDIF}
Result := inherited LockServer (fLock);
end;
function TThreadedComObjectFactory.AddConnection (extconn: longint; reserved: longint): longint;
begin
if (extconn AND EXTCONN_STRONG <> 0) then TComServerHack (ComServer).CountObject (TRUE);
Result := 2; // dummy
end;
function TThreadedComObjectFactory.ReleaseConnection (extconn: longint; reserved: longint; fLastReleaseCloses: BOOL): longint;
begin
if (extconn AND EXTCONN_STRONG <> 0) then TComServerHack (ComServer).CountObject (FALSE);
Result := 1; // dummy
end;
function TThreadedComObjectFactory.DoCreateInstance(pApt: TApartment;
const UnkOuter: IUnknown; const IID: TGUID; out Obj): HResult;
begin
Result := inherited CreateInstance (UnkOuter, IID, Obj);
end;
procedure TThreadedComObjectFactory.Initialize;
begin
end;
constructor TThreadedComObjectFactory.CreateThreaded (ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const ClassName, Description: string;
Instancing: TClassInstancing; tm: TThreadingModel);
begin
CreateThreadedEx (ComServer, ComClass, ClassId, ClassName, Description, Instancing, tm, cDefApartmentAllocMode);
end;
constructor TThreadedComObjectFactory.CreateThreadedEx (ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const ClassName, Description: string;
Instancing: TClassInstancing; tm: TThreadingModel; am: TSTAAllocMode);
begin
inherited Create (ComServer, ComClass, ClassId, ClassName, Description, Instancing {$IFNDEF D3}, tm {$ENDIF});
FSTAAllocMode := am;
FThreadingModel := tm;
FRegisterClass := -1;
Initialize;
end;
{$IFDEF D3}
constructor TThreadedComObjectFactory.Create (ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const ClassName, Description: string;
Instancing: TClassInstancing);
begin
CreateThreaded (ComServer, ComClass, ClassId, ClassName, Description, Instancing, cDefServerThreadingModel);
end;
{$ELSE}
constructor TThreadedComObjectFactory.Create (ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const ClassName, Description: string;
Instancing: TClassInstancing);
begin
Create (ComServer, ComClass, ClassId, ClassName, Description, Instancing, cDefServerThreadingModel);
end;
constructor TThreadedComObjectFactory.Create (ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const ClassName, Description: string;
Instancing: TClassInstancing; tm: TThreadingModel);
begin
Create (ComServer, ComClass, ClassId, ClassName, Description, Instancing, tm, cDefApartmentAllocMode);
end;
constructor TThreadedComObjectFactory.Create (ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const ClassName, Description: string;
Instancing: TClassInstancing; tm: TThreadingModel; am: TSTAAllocMode);
begin
inherited Create (ComServer, ComClass, ClassId, ClassName, Description, Instancing, tm);
FSTAAllocMode := am;
FThreadingModel := tm;
FRegisterClass := -1;
Initialize;
end;
{$ENDIF}
destructor TThreadedComObjectFactory.Destroy;
begin
RegisterClass (FALSE);
inherited;
end;
procedure TThreadedComObjectFactory.RegisterClass (bRegister: boolean);
begin
RegisterClassFactory (bRegister, ClassId, Self, Instancing, FRegisterClass);
end;
procedure TThreadedComObjectFactory.UpdateRegistry (bRegister: boolean);
var
sServerKey: string;
begin
if (bRegister) and (IsLibrary) then
begin
{ remove ThreadingModel value first! }
sServerKey := 'CLSID\' + GuidToString (ClassID) + '\' + ComServer.ServerKey;
DeleteRegValue (sServerKey, 'ThreadingModel');
{$IFDEF D3}
if (ThreadingModel <> tmSingle) then
begin
inherited;
CreateRegKey (sServerKey, 'ThreadingModel', ThreadingModelFlags [FThreadingModel]);
Exit;
end;
{$ENDIF}
end; { if }
inherited;
end;
{ TThreadedAutoObjectFactory }
function TThreadedAutoObjectFactory.CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
out Obj): HResult;
begin
if (IsLibrary) then
Result := inherited CreateInstance (UnkOuter, IID, Obj)
else
Result := ApartmentManager.CreateInstance (Self, DoCreateInstance, ThreadingModel, STAAllocMode, UnkOuter, iid, Obj);
end;
function TThreadedAutoObjectFactory.LockServer(fLock: BOOL): HResult;
begin
{$IFDEF D3}
TComServerHack (ComServer).CountObject (fLock);
{$ENDIF}
Result := inherited LockServer (fLock);
end;
function TThreadedAutoObjectFactory.AddConnection (extconn: longint; reserved: longint): longint;
begin
if (extconn AND EXTCONN_STRONG <> 0) then TComServerHack (ComServer).CountObject (TRUE);
Result := 2; // dummy
end;
function TThreadedAutoObjectFactory.ReleaseConnection (extconn: longint; reserved: longint; fLastReleaseCloses: BOOL): longint;
begin
if (extconn AND EXTCONN_STRONG <> 0) then TComServerHack (ComServer).CountObject (FALSE);
Result := 1; // dummy
end;
function TThreadedAutoObjectFactory.DoCreateInstance (pApt: TApartment;
const UnkOuter: IUnknown; const IID: TGUID; out Obj): HResult; stdcall;
begin
Result := inherited CreateInstance (UnkOuter, IID, Obj);
end;
procedure TThreadedAutoObjectFactory.Initialize;
begin
end;
constructor TThreadedAutoObjectFactory.CreateThreaded (ComServer: TComServerObject; AutoClass: TAutoClass;
const ClassID: TGUID; Instancing: TClassInstancing; tm: TThreadingModel);
begin
CreateThreadedEx (ComServer, AutoClass, ClassId, Instancing, tm, cDefApartmentAllocMode);
end;
constructor TThreadedAutoObjectFactory.CreateThreadedEx (ComServer: TComServerObject; AutoClass: TAutoClass;
const ClassID: TGUID; Instancing: TClassInstancing; tm: TThreadingModel; am: TSTAAllocMode);
begin
inherited Create (ComServer, AutoClass, ClassId, Instancing {$IFNDEF D3}, tm {$ENDIF});
FSTAAllocMode := am;
FThreadingModel := tm;
FRegisterClass := -1;
Initialize;
end;
{$IFDEF D3}
constructor TThreadedAutoObjectFactory.Create(ComServer: TComServerObject; AutoClass: TAutoClass;
const ClassID: TGUID; Instancing: TClassInstancing);
begin
CreateThreaded (ComServer, AutoClass, ClassId, Instancing, cDefServerThreadingModel);
end;
{$ELSE}
constructor TThreadedAutoObjectFactory.Create(ComServer: TComServerObject; AutoClass: TAutoClass;
const ClassID: TGUID; Instancing: TClassInstancing);
begin
Create (ComServer, AutoClass, ClassId, Instancing, cDefServerThreadingModel);
end;
constructor TThreadedAutoObjectFactory.Create(ComServer: TComServerObject; AutoClass: TAutoClass;
const ClassID: TGUID; Instancing: TClassInstancing;
tm: TThreadingModel);
begin
Create (ComServer, AutoClass, ClassId, Instancing, tm, cDefApartmentAllocMode);
end;
constructor TThreadedAutoObjectFactory.Create(ComServer: TComServerObject; AutoClass: TAutoClass;
const ClassID: TGUID; Instancing: TClassInstancing;
tm: TThreadingModel; am: TSTAAllocMode);
begin
inherited Create (ComServer, AutoClass, ClassId, Instancing, tm);
FSTAAllocMode := am;
FThreadingModel := tm;
FRegisterClass := -1;
Initialize;
end;
{$ENDIF}
destructor TThreadedAutoObjectFactory.Destroy;
begin
RegisterClass (FALSE);
inherited;
end;
procedure TThreadedAutoObjectFactory.RegisterClass (bRegister: boolean);
begin
RegisterClassFactory (bRegister, ClassId, Self, Instancing, FRegisterClass);
end;
procedure TThreadedAutoObjectFactory.UpdateRegistry (bRegister: boolean);
var
sServerKey: string;
begin
if (bRegister) and (IsLibrary) then
begin
{ remove ThreadingModel value first! }
sServerKey := 'CLSID\' + GuidToString (ClassID) + '\' + ComServer.ServerKey;
DeleteRegValue (sServerKey, 'ThreadingModel');
{$IFDEF D3}
if (ThreadingModel <> tmSingle) then
begin
inherited;
CreateRegKey (sServerKey, 'ThreadingModel', ThreadingModelFlags [FThreadingModel]);
Exit;
end;
{$ENDIF}
end; { if }
inherited;
end;
{ TThreadedClassFactory }
function TThreadedClassFactory.CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
out Obj): HResult;
begin
if (IsLibrary) then
Result := inherited CreateInstance (UnkOuter, IID, Obj)
else
Result := ApartmentManager.CreateInstance (Self, DoCreateInstance, ThreadingModel, STAAllocMode, UnkOuter, iid, Obj);
end;
function TThreadedClassFactory.LockServer(fLock: BOOL): HResult;
begin
{$IFDEF D3}
TComServerHack (ComServer).CountObject (fLock);
{$ENDIF}
Result := inherited LockServer (fLock);
end;
function TThreadedClassFactory.AddConnection (extconn: longint; reserved: longint): longint;
begin
if (extconn AND EXTCONN_STRONG <> 0) then TComServerHack (ComServer).CountObject (TRUE);
Result := 2; // dummy
end;
function TThreadedClassFactory.ReleaseConnection (extconn: longint; reserved: longint; fLastReleaseCloses: BOOL): longint;
begin
if (extconn AND EXTCONN_STRONG <> 0) then TComServerHack (ComServer).CountObject (FALSE);
Result := 1; // dummy
end;
function TThreadedClassFactory.DoCreateInstance(pApt: TApartment;
const UnkOuter: IUnknown; const IID: TGUID; out Obj): HResult; stdcall;
begin
Result := inherited CreateInstance (UnkOuter, IID, Obj);
end;
procedure TThreadedClassFactory.Initialize;
begin
end;
constructor TThreadedClassFactory.CreateThreaded (ComServer: TComServerObject;
ComponentClass: TComponentClass; const ClassID: TGUID;
Instancing: TClassInstancing; tm: TThreadingModel);
begin
CreateThreadedEx (ComServer, ComponentClass, ClassId, Instancing, tm, cDefApartmentAllocMode);
end;
constructor TThreadedClassFactory.CreateThreadedEx (ComServer: TComServerObject;
ComponentClass: TComponentClass; const ClassID: TGUID;
Instancing: TClassInstancing; tm: TThreadingModel; am: TSTAAllocMode);
begin
inherited Create (ComServer, ComponentClass, ClassId, Instancing {$IFNDEF D3}, tm {$ENDIF});
FSTAAllocMode := am;
FThreadingModel := tm;
FRegisterClass := -1;
Initialize;
end;
{$IFDEF D3}
constructor TThreadedClassFactory.Create (ComServer: TComServerObject;
ComponentClass: TComponentClass; const ClassID: TGUID;
Instancing: TClassInstancing);
begin
CreateThreaded (ComServer, ComponentClass, ClassId, Instancing, cDefServerThreadingModel);
end;
{$ELSE}
constructor TThreadedClassFactory.Create(ComServer: TComServerObject;
ComponentClass: TComponentClass; const ClassID: TGUID;
Instancing: TClassInstancing);
begin
Create (ComServer, ComponentClass, ClassId, Instancing, cDefServerThreadingModel);
end;
constructor TThreadedClassFactory.Create(ComServer: TComServerObject;
ComponentClass: TComponentClass; const ClassID: TGUID;
Instancing: TClassInstancing; tm: TThreadingModel);
begin
Create (ComServer, ComponentClass, ClassId, Instancing, tm, cDefApartmentAllocMode);
end;
constructor TThreadedClassFactory.Create(ComServer: TComServerObject;
ComponentClass: TComponentClass; const ClassID: TGUID;
Instancing: TClassInstancing; tm: TThreadingModel; am: TSTAAllocMode);
begin
inherited Create (ComServer, ComponentClass, ClassId, Instancing, tm);
FSTAAllocMode := am;
FThreadingModel := tm;
FRegisterClass := -1;
Initialize;
end;
{$ENDIF}
destructor TThreadedClassFactory.Destroy;
begin
RegisterClass (FALSE);
inherited;
end;
function TThreadedClassFactory.CreateComObject (const Controller: IUnknown): TComObject;
begin
Result := TThreadedVCLAutoObject.CreateFromFactory (Self, Controller);
end;
procedure TThreadedClassFactory.RegisterClass (bRegister: boolean);
begin
RegisterClassFactory (bRegister, ClassId, Self, Instancing, FRegisterClass);
end;
procedure TThreadedClassFactory.UpdateRegistry (bRegister: boolean);
var
sServerKey: string;
begin
if (bRegister) and (IsLibrary) then
begin
{ remove ThreadingModel value first! }
sServerKey := 'CLSID\' + GuidToString (ClassID) + '\' + ComServer.ServerKey;
DeleteRegValue (sServerKey, 'ThreadingModel');
{$IFDEF D3}
if (ThreadingModel <> tmSingle) then
begin
inherited;
CreateRegKey (sServerKey, 'ThreadingModel', ThreadingModelFlags [FThreadingModel]);
Exit;
end;
{$ENDIF}
end; { if }
inherited;
end;
{ TSingletonComObject }
function TSingletonComObject.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
Result := ObjQueryInterface (IID, Obj);
end;
function TSingletonComObject._AddRef: Integer;
begin
Result := ObjAddRef;
end;
function TSingletonComObject._Release: Integer;
begin
Result := ObjRelease;
end;
function TSingletonComObject.CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
out Obj): HResult;
begin
if (UnkOuter <> NIL) then
Result := CLASS_E_NOAGGREGATION
else
Result := QueryInterface (IID, Obj);
end;
function TSingletonComObject.ObjAddRef: Integer;
begin
Result := inherited _AddRef;
end;
function TSingletonComObject.ObjQueryInterface(const IID: TGUID; out Obj): Integer;
begin
Result := inherited QueryInterface (IID, Obj);
end;
function TSingletonComObject.ObjRelease: Integer;
begin
Result := inherited _Release;
end;
procedure InitializeSingletonComObject (ComServer: TComServerObject;
SingletonClass: TSingletonComClass; const clsid: TGUID;
const sClassName, sDescription: string);
begin
SingletonClass.Create (ComServer, TComObject {dummy}, clsid, sClassName, sDescription, ciMultiInstance);
end;
function TSingletonComObject.SafeCallException(ExceptObject: TObject;
ExceptAddr: Pointer): HResult;
begin
Result := HandleSafeCallException (ExceptObject, ExceptAddr,
ErrorIID, ProgID, ComServer.HelpFileName);
end;
{ TSingletonAutoObject }
function TSingletonAutoObject.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
Result := ObjQueryInterface (IID, Obj);
end;
function TSingletonAutoObject._AddRef: Integer;
begin
Result := ObjAddRef;
end;
function TSingletonAutoObject._Release: Integer;
begin
Result := ObjRelease;
end;
function TSingletonAutoObject.GetClassInfo(out TypeInfo: ITypeInfo): HResult;
begin
TypeInfo := ClassInfo;
Result := S_OK;
end;
function TSingletonAutoObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := DispGetIDsOfNames (DispTypeInfo, Names, NameCount, DispIDs);
end;
function TSingletonAutoObject.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
pointer (TypeInfo) := nil;
if (Index <> 0) then
begin
Result := DISP_E_BADINDEX;
Exit;
end; { if }
ITypeInfo (TypeInfo) := DispTypeInfo;
Result := S_OK;
end;
function TSingletonAutoObject.GetTypeInfoCount(out Count: Integer): HResult;
begin
Count := 1;
Result := S_OK;
end;
function TSingletonAutoObject.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
const
INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
begin
if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
Result := DispTypeInfo.Invoke (Pointer(Integer(Self) + DispIntfEntry.IOffset),
DispID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr);
end;
function TSingletonAutoObject.CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
out Obj): HResult;
begin
if (UnkOuter <> NIL) then
Result := CLASS_E_NOAGGREGATION
else
Result := QueryInterface (IID, Obj);
end;
function TSingletonAutoObject.GetIntfEntry (Guid: TGUID): PInterfaceEntry;
begin
Result := GetInterfaceEntry (Guid);
end;
function TSingletonAutoObject.ObjAddRef: Integer;
begin
Result := inherited _AddRef;
end;
function TSingletonAutoObject.ObjQueryInterface(const IID: TGUID; out Obj): Integer;
begin
Result := inherited QueryInterface (IID, Obj);
end;
function TSingletonAutoObject.ObjRelease: Integer;
begin
Result := inherited _Release;
end;
procedure InitializeSingletonAutoObject (ComServer: TComServerObject;
SingletonClass: TSingletonAutoClass; const clsid: TGUID);
begin
SingletonClass.Create (ComServer, TAutoObject {dummy}, clsid, ciMultiInstance)
end;
function TSingletonAutoObject.SafeCallException(ExceptObject: TObject;
ExceptAddr: Pointer): HResult;
begin
Result := HandleSafeCallException (ExceptObject, ExceptAddr,
ErrorIID, ProgID, ComServer.HelpFileName);
end;
type
TObjectList = class
protected
FApartment: TApartment;
FCSLock: TCriticalSection;
FItems: TList;
function GetCount: integer;
function GetUnks (i: integer): IUnknown;
procedure Lock (bLock: boolean);
procedure SetUnks (i: integer; pUnk: IUnknown);
property Unks [i: integer]: IUnknown read GetUnks write SetUnks;
public
constructor Create (pApt: TApartment);
destructor Destroy; override;
procedure Add (pUnk: IUnknown);
procedure Clear;
function Compact: boolean;
property Count: integer read GetCount;
end;
TDefaultApartmentThread = class (TApartmentThread)
protected
function GetObjects: TObjectList;
procedure InstanceCreated (pciInfo: PCreateInstanceInfo; pUnk: IUnknown); override;
property Objects: TObjectList read GetObjects;
end;
TDefaultApartmentThreads = class (TApartmentThreads)
protected
function CreateThread: TApartmentThread; override;
end;
TDefaultApartment = class (TApartment)
protected
FHasObjects: boolean;
FObjects: TObjectList;
function CreateThreads: TApartmentThreads; override;
public
constructor Create (Owner: TApartments; at: TApartmentType); override;
destructor Destroy; override;
function GarbageCollect: boolean; override;
property HasObjects: boolean read FHasObjects write FHasObjects;
property Objects: TObjectList read FObjects;
end;
TDefaultApartments = class (TApartments)
protected
function CreateApartment (at: TApartmentType): TApartment; override;
end;
{ TObjectList }
function TObjectList.GetCount: integer;
begin
Lock (TRUE);
try
Result := FItems.Count;
finally
Lock (FALSE);
end; { finally }
end;
function TObjectList.GetUnks (i: integer): IUnknown;
begin
Lock (TRUE);
try
Result := IUnknown (FItems [i]);
finally
Lock (FALSE);
end; { finally }
end;
procedure TObjectList.Lock (bLock: boolean);
begin
FCSLock.Lock (bLock);
end;
procedure TObjectList.SetUnks (i: integer; pUnk: IUnknown);
begin
Lock (TRUE);
try
if (FItems [i] <> NIL) then IUnknown (FItems [i])._Release;
FItems [i] := pointer (pUnk);
if (pUnk <> NIL) then IUnknown (FItems [i])._AddRef;
finally
Lock (FALSE);
end; { finally }
end;
constructor TObjectList.Create (pApt: TApartment);
begin
Assert (pApt <> NIL);
inherited Create;
FCSLock := TCriticalSection.Create;
FItems := TList.Create;
FApartment := pApt;
end;
destructor TObjectList.Destroy;
begin
Clear;
FItems.Free;
FCSLock.Free;
inherited;
end;
procedure TObjectList.Add (pUnk: IUnknown);
var
i: integer;
begin
Assert (pUnk <> NIL);
Lock (TRUE);
try
i := FItems.Add (NIL);
if (i >= 0) then
begin
FApartment.CountObject (TRUE);
Unks [i] := pUnk;
end; { if }
finally
Lock (FALSE);
end; { finally }
end;
procedure TObjectList.Clear;
var
i: integer;
begin
Lock (TRUE);
try
for i := Count - 1 downto 0 do
Unks [i] := NIL;
FItems.Clear;
finally
Lock (FALSE);
end; { finally }
end;
{ releases unused objects. returns TRUE if everything was just released! }
function TObjectList.Compact: boolean;
var
i, iLastCount: integer;
begin
Result := FALSE;
Lock (TRUE);
try
for i := Count - 1 downto 0 do
begin
{ note: must manipulate as raw IUnknowns to avoid Delphi's automatic
refcounting!
}
IUnknown (FItems [i])._AddRef;
if (IUnknown (FItems [i])._Release = 1) then
begin
Unks [i] := NIL;
iLastCount := FApartment.CountObject (FALSE);
if (iLastCount = 0) then Result := TRUE;
end; { if }
end; { for }
FItems.Pack;
finally
Lock (FALSE);
end; { finally }
end;
{ TDefaultApartmentThread }
function TDefaultApartmentThread.GetObjects: TObjectList;
begin
Result := TObjectList (TDefaultApartment (Apartment).Objects);
end;
procedure TDefaultApartmentThread.InstanceCreated (pciInfo: PCreateInstanceInfo; pUnk: IUnknown);
var
pciData: PCreateInstanceData;
begin
{ we don't need to track a threaded com class because they already know how
to refcount their corresponding apartments. this way, we're a lot more
efficient!
}
if (pciInfo <> NIL) then
begin
pciData := pciInfo^.Data;
if (pciData <> NIL) then
if (pciData^.IsThreadedComClass) then Exit;
end; { if }
{ can't enlist object if calling thread is not the main thread (apartment
where all class factories are registered) because we'd be violating the
rules of COM threading!
}
if (GetCurrentThreadId <> MainThreadId) then Exit;
{ add object into manageables list }
Objects.Add (pUnk);
TDefaultApartment (Apartment).HasObjects := TRUE;
end;
{ TDefaultApartmentThreads }
function TDefaultApartmentThreads.CreateThread: TApartmentThread;
begin
Result := TDefaultApartmentThread.Create (Self);
end;
{ TDefaultApartment }
function TDefaultApartment.CreateThreads: TApartmentThreads;
begin
Result := TDefaultApartmentThreads.Create (Self);
end;
constructor TDefaultApartment.Create (Owner: TApartments; at: TApartmentType);
begin
inherited Create (Owner, at);
FObjects := TObjectList.Create (Self);
end;
destructor TDefaultApartment.Destroy;
begin
FObjects.Free;
inherited;
end;
function TDefaultApartment.GarbageCollect: boolean;
begin
Result := FALSE;
if not (HasObjects) then Exit;
Result := Objects.Compact;
end;
{ TDefaultApartments }
function TDefaultApartments.CreateApartment (at: TApartmentType): TApartment;
begin
Result := TDefaultApartment.Create (Self, at);
end;
{ TDefaultApartmentManager }
function TDefaultApartmentManager.GetApartments: TApartments;
begin
Result := FApartments;
end;
procedure TDefaultApartmentManager.TimerUpdate (pSender: TObject);
const
cDiv = 3;
begin
{ regularly clean out apartments! }
FGCTimer.Enabled := FALSE;
try
Apartments.GarbageCollect ((Apartments.Count DIV cDiv) + cDiv);
finally
FGCTimer.Enabled := TRUE;
end; { finally }
end;
constructor TDefaultApartmentManager.Create;
begin
inherited Create;
FApartments := TDefaultApartments.Create (Self);
FGC := TApartmentsGC.Create (Self, tpIdle);
FGCTimer := TTimer.Create (NIL);
FGCTimer.Interval := cDefApartmentGCTimerInterval;
FGCTimer.OnTimer := TimerUpdate;
end;
destructor TDefaultApartmentManager.Destroy;
begin
FShuttingDown := TRUE;
FGCTimer.Free;
Apartments.GarbageCollect (-1);
FGC.Free;
FApartments.Free;
inherited;
end;
procedure TDefaultApartmentManager.GarbageCollect (Sender: TObject);
begin
FGC.Activate (Sender);
end;
function TDefaultApartmentManager.GetPooledSTACount: integer;
begin
Result := cDefApartmentPoolCount;
end;
{ this is meant to be called after your LastReleased handler! }
procedure TDefaultApartmentManager.LastReleased (var bShutdown: boolean);
begin
if (bShutdown) then
begin
FShuttingDown := TRUE;
GCTimer.Enabled := FALSE;
if not (IsLibrary) then
begin
if (cNT4DCOMSupported) then CoSuspendClassObjects;
PostThreadMessage (MainThreadID, WM_QUIT, 0, 0); // D3 fix!
end; { if }
end; { if }
end;
procedure TDefaultApartmentManager.Resume;
begin
FShuttingDown := FALSE;
GCTimer.Enabled := TRUE;
end;
function TDefaultApartmentManager.ServerIsShuttingDown: boolean;
begin
Result := FShuttingDown;
end;
procedure Register;
begin
RegisterComponents ('ThreadComLib', [TApartmentStats]);
end;
{ init }
procedure InitializeNT4DCOMExtensions;
var
hOle32: THandle;
begin
hOle32 := GetModuleHandle ('ole32.dll');
if (hOle32 <> 0) then
begin
{$IFDEF D3} //D3
@CoInitializeEx := GetProcAddress (hOle32, 'CoInitializeEx');
cNT4DCOMSupported := (@CoInitializeEx <> NIL);
if (cNT4DCOMSupported) then
begin
@CoAddRefServerProcess := GetProcAddress (hOle32, 'CoAddRefServerProcess');
@CoReleaseServerProcess := GetProcAddress (hOle32, 'CoReleaseServerProcess');
@CoSuspendClassObjects := GetProcAddress (hOle32, 'CoSuspendClassObjects');
@CoResumeClassObjects := GetProcAddress (hOle32, 'CoResumeClassObjects');
end; { if }
{$ELSE}
cNT4DCOMSupported := (@CoInitializeEx <> NIL);
{$ENDIF}
{ bind to CoCreateFTM for D3 and D4! }
if (cNT4DCOMSupported) then
begin
@CoCreateFreeThreadedMarshaler := GetProcAddress (hOle32, 'CoCreateFreeThreadedMarshaler');
end; { if }
end; { if }
end;
initialization
csApartmentManager := TCriticalSection.Create;
{ initialize NT4 DCOM extension APIs }
InitializeNT4DCOMExtensions;
if not (IsLibrary) then
begin
{ ensure unique values }
WM_CREATEOBJECTINTHREAD := RegisterWindowMessage ('WM_CREATEOBJECTINTHREAD');
WM_GARBAGECOLLECTCOMSERVER := RegisterWindowMessage ('WM_GARBAGECOLLECTCOMSERVER');
end; { if }
finalization
DestroyDefaultApartmentManager;
csApartmentManager.Free;
csApartmentManager := NIL;
end.