From 864081102a5f252415f41950b3039a896b4ae9c5 Mon Sep 17 00:00:00 2001 From: Vadim Dashevskiy Date: Mon, 8 Oct 2012 18:43:29 +0000 Subject: Awkwars's plugins - welcome to our trunk git-svn-id: http://svn.miranda-ng.org/main/trunk@1822 1316c22d-e87f-b044-9b9b-93d7a3e3ba9c --- plugins/Libs/kolcomobj.pas | 2352 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2352 insertions(+) create mode 100644 plugins/Libs/kolcomobj.pas (limited to 'plugins/Libs/kolcomobj.pas') diff --git a/plugins/Libs/kolcomobj.pas b/plugins/Libs/kolcomobj.pas new file mode 100644 index 0000000000..8d8010906a --- /dev/null +++ b/plugins/Libs/kolcomobj.pas @@ -0,0 +1,2352 @@ + +{*******************************************************} +{ } +{ Borland Delphi Runtime Library } +{ COM object support } +{ } +{ Copyright (C) 1997,99 Inprise Corporation } +{ } +{*******************************************************} + +{$IMPORTEDDATA ON} +unit KOLComObj; + +{$G+} +{$DEFINE NOWARNINGS} +{$I KOLDEF.inc} + +interface + +uses Windows, ActiveX, KOL, err {$IFDEF _D6orHigher}, Variants {$ENDIF}; + +type +{ Forward declarations } + + TComObjectFactory = class; + +{ COM server abstract base class } + + TComServerObject = class(TObject) + protected + function CountObject(Created: Boolean): Integer; virtual; abstract; + function CountFactory(Created: Boolean): Integer; virtual; abstract; + function GetHelpFileName: AnsiString; virtual; abstract; + function GetServerFileName: AnsiString; virtual; abstract; + function GetServerKey: AnsiString; virtual; abstract; + function GetServerName: AnsiString; virtual; abstract; + function GetStartSuspended: Boolean; virtual; abstract; + function GetTypeLib: ITypeLib; virtual; abstract; + procedure SetHelpFileName(const Value: AnsiString); virtual; abstract; + public + property HelpFileName: AnsiString read GetHelpFileName write SetHelpFileName; + property ServerFileName: AnsiString read GetServerFileName; + property ServerKey: AnsiString read GetServerKey; + property ServerName: AnsiString read GetServerName; + property TypeLib: ITypeLib read GetTypeLib; + property StartSuspended: Boolean read GetStartSuspended; + end; + + +{ TMultiReadExclusiveWriteSynchronizer minimizes thread serialization to gain + read access to a resource shared among threads while still providing complete + exclusivity to callers needing write access to the shared resource. + (multithread shared reads, single thread exclusive write) + Reading is allowed while owning a write lock. + Read locks can be promoted to write locks.} + + {$IFNDEF _D2orD3} + TActiveThreadRecord = record + ThreadID: Integer; + RecursionCount: Integer; + end; + TActiveThreadArray = array of TActiveThreadRecord; + + TMultiReadExclusiveWriteSynchronizer = class + private + FLock: TRTLCriticalSection; + FReadExit: THandle; + FCount: Integer; + FSaveReadCount: Integer; + FActiveThreads: TActiveThreadArray; + FWriteRequestorID: Integer; + FReallocFlag: Integer; + FWriting: Boolean; + function WriterIsOnlyReader: Boolean; + public + constructor Create; + destructor Destroy; override; + procedure BeginRead; + procedure EndRead; + procedure BeginWrite; + procedure EndWrite; + end; + {$ENDIF} + +{ COM class manager } + + TFactoryProc = procedure(Factory: TComObjectFactory) of object; + + TComClassManager = class(TObject) + private + FFactoryList: TComObjectFactory; + {$IFNDEF _D2orD3} + FLock: TMultiReadExclusiveWriteSynchronizer; + {$ENDIF} + procedure AddObjectFactory(Factory: TComObjectFactory); + procedure RemoveObjectFactory(Factory: TComObjectFactory); + public + constructor Create; + destructor Destroy; override; + procedure ForEachFactory(ComServer: TComServerObject; + FactoryProc: TFactoryProc); + function GetFactoryFromClass(ComClass: TClass): TComObjectFactory; + function GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory; + end; + +{ IServerExceptionHandler } +{ This interface allows you to report safecall exceptions that occur in a + TComObject server to a third party, such as an object that logs errors into + the system event log or a server monitor residing on another machine. + Obtain an interface from the error logger implementation and assign it + to your TComObject's ServerExceptionHandler property. Each TComObject + instance can have its own server exception handler, or all instances can + share the same handler. The server exception handler can override the + TComObject's default exception handling by setting Handled to True and + assigning an OLE HResult code to the HResult parameter. +} + + IServerExceptionHandler = interface + ['{6A8D432B-EB81-11D1-AAB1-00C04FB16FBC}'] + procedure OnException( + const ServerClass, ExceptionClass, ErrorMessage: WideString; + ExceptAddr: Integer; const ErrorIID, ProgID: WideString; + var Handled: Integer; var Result: HResult); dispid 2; + end; + +{ COM object } + + TComObject = class(TObject, IUnknown, ISupportErrorInfo) + private + FController: Pointer; + FFactory: TComObjectFactory; + FNonCountedObject: Boolean; + FRefCount: Integer; + FServerExceptionHandler: IServerExceptionHandler; + function GetController: IUnknown; + protected + { IUnknown } + function IUnknown.QueryInterface = ObjQueryInterface; + function IUnknown._AddRef = ObjAddRef; + function IUnknown._Release = ObjRelease; + { IUnknown methods for other interfaces } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + { ISupportErrorInfo } + function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall; + public + constructor Create; + constructor CreateAggregated(const Controller: IUnknown); + constructor CreateFromFactory(Factory: TComObjectFactory; + const Controller: IUnknown); + destructor Destroy; override; + procedure Initialize; virtual; + function ObjAddRef: Integer; virtual; stdcall; + function ObjQueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; + function ObjRelease: Integer; virtual; stdcall; + function SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; override; + property Controller: IUnknown read GetController; + property Factory: TComObjectFactory read FFactory; + property RefCount: Integer read FRefCount; + property ServerExceptionHandler: IServerExceptionHandler + read FServerExceptionHandler write FServerExceptionHandler; + end; + +{ COM class } + + TComClass = class of TComObject; + +{ Instancing mode for COM classes } + + TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance); + +{ Threading model supported by COM classes } + + TThreadingModel = (tmSingle, tmApartment, tmFree, tmBoth); + +{ COM object factory } + + {$IFDEF NOWARNINGS} + {$WARNINGS OFF} + {$ENDIF} + TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2) + private + FNext: TComObjectFactory; + FComServer: TComServerObject; + FComClass: TClass; + FClassID: TGUID; + FClassName: AnsiString; + FDescription: AnsiString; + FErrorIID: TGUID; + FInstancing: TClassInstancing; + FLicString: WideString; + FRegister: Longint; + FShowErrors: Boolean; + FSupportsLicensing: Boolean; + FThreadingModel: TThreadingModel; + protected + function GetProgID: AnsiString; virtual; + function GetLicenseString: WideString; virtual; + function HasMachineLicense: Boolean; virtual; + function ValidateUserLicense(const LicStr: WideString): Boolean; virtual; + { IUnknown } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + { IClassFactory } + function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID; + out Obj): HResult; stdcall; + function LockServer(fLock: BOOL): HResult; stdcall; + { IClassFactory2 } + function GetLicInfo(var licInfo: TLicInfo): HResult; stdcall; + function RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult; stdcall; + function CreateInstanceLic(const unkOuter: IUnknown; const unkReserved: IUnknown; + const iid: TIID; const bstrKey: WideString; out vObject): HResult; stdcall; + public + constructor Create(ComServer: TComServerObject; ComClass: TComClass; + const ClassID: TGUID; const ClassName, Description: AnsiString; + Instancing: TClassInstancing; ThreadingModel: TThreadingModel {= tmSingle} ); + destructor Destroy; override; + function CreateComObject(const Controller: IUnknown): TComObject; virtual; + procedure RegisterClassObject; + procedure UpdateRegistry(Register: Boolean); virtual; + property ClassID: TGUID read FClassID; + property ClassName: AnsiString read FClassName; + property ComClass: TClass read FComClass; + property ComServer: TComServerObject read FComServer; + property Description: AnsiString read FDescription; + property ErrorIID: TGUID read FErrorIID write FErrorIID; + property LicString: WideString read FLicString write FLicString; + property ProgID: AnsiString read GetProgID; + property Instancing: TClassInstancing read FInstancing; + property ShowErrors: Boolean read FShowErrors write FShowErrors; + property SupportsLicensing: Boolean read FSupportsLicensing write FSupportsLicensing; + property ThreadingModel: TThreadingModel read FThreadingModel; + end; + {$IFDEF NOWARNINGS} + {$WARNINGS ON} + {$ENDIF} + +{ COM objects intended to be aggregated / contained } + + TAggregatedObject = class + private + FController: Pointer; + function GetController: IUnknown; + protected + { IUnknown } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + public + constructor Create(Controller: IUnknown); + property Controller: IUnknown read GetController; + end; + + TContainedObject = class(TAggregatedObject, IUnknown) + protected + { IUnknown } + function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall; + end; + +{ COM object with type information } + + TTypedComObject = class(TComObject, IProvideClassInfo) + protected + { IProvideClassInfo } + function GetClassInfo(out TypeInfo: ITypeInfo): HResult; stdcall; + end; + + TTypedComClass = class of TTypedComObject; + + {$IFDEF NOWARNINGS} + {$WARNINGS OFF} + {$ENDIF} + TTypedComObjectFactory = class(TComObjectFactory) + private + FClassInfo: ITypeInfo; + public + constructor Create(ComServer: TComServerObject; + TypedComClass: TTypedComClass; const ClassID: TGUID; + Instancing: TClassInstancing; ThreadingModel: TThreadingModel {= tmSingle} ); + function GetInterfaceTypeInfo(TypeFlags: Integer): ITypeInfo; + procedure UpdateRegistry(Register: Boolean); override; + property ClassInfo: ITypeInfo read FClassInfo; + end; + {$IFDEF NOWARNINGS} + {$WARNINGS ON} + {$ENDIF} + +{ OLE Automation object } + + TConnectEvent = procedure (const Sink: IUnknown; Connecting: Boolean) of object; + + TAutoObjectFactory = class; + + TAutoObject = class(TTypedComObject, IDispatch) + private + FEventSink: IUnknown; + FAutoFactory: TAutoObjectFactory; + protected + { 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; + { Other methods } + procedure EventConnect(const Sink: IUnknown; Connecting: Boolean); + procedure EventSinkChanged(const EventSink: IUnknown); virtual; + property AutoFactory: TAutoObjectFactory read FAutoFactory; + property EventSink: IUnknown read FEventSink write FEventSink; + public + procedure Initialize; override; + end; + +{ OLE Automation class } + + TAutoClass = class of TAutoObject; + +{ OLE Automation object factory } + + TAutoObjectFactory = class(TTypedComObjectFactory) + private + FDispTypeInfo: ITypeInfo; + FDispIntfEntry: PInterfaceEntry; + FEventIID: TGUID; + FEventTypeInfo: ITypeInfo; + public + constructor Create(ComServer: TComServerObject; AutoClass: TAutoClass; + const ClassID: TGUID; Instancing: TClassInstancing; + ThreadingModel: TThreadingModel {= tmSingle} ); + function GetIntfEntry(Guid: TGUID): PInterfaceEntry; virtual; + property DispIntfEntry: PInterfaceEntry read FDispIntfEntry; + property DispTypeInfo: ITypeInfo read FDispTypeInfo; + property EventIID: TGUID read FEventIID; + property EventTypeInfo: ITypeInfo read FEventTypeInfo; + end; + + TAutoIntfObject = class(TInterfacedObject, IDispatch, ISupportErrorInfo) + private + FDispTypeInfo: ITypeInfo; + FDispIntfEntry: PInterfaceEntry; + FDispIID: TGUID; + protected + { IDispatch } + function GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; + function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; + function GetTypeInfoCount(out Count: Integer): HResult; stdcall; + function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; + Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; + { ISupportErrorInfo } + function InterfaceSupportsErrorInfo(const iid: TIID): HResult; stdcall; + public + constructor Create(const TypeLib: ITypeLib; const DispIntf: TGUID); + function SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; override; + property DispIntfEntry: PInterfaceEntry read FDispIntfEntry; + property DispTypeInfo: ITypeInfo read FDispTypeInfo; + property DispIID: TGUID read FDispIID; + end; + +{ OLE exception classes } + + EOleError = Exception; // class(Exception); + + EOleSysError = EOleError; { class(EOleError) + private + FErrorCode: HRESULT; + public + constructor Create(const Message: AnsiString; ErrorCode: HRESULT; + HelpContext: Integer); + property ErrorCode: HRESULT read FErrorCode write FErrorCode; + end;} + + EOleException = EOleSysError; { class(EOleSysError) + private + FSource: AnsiString; + FHelpFile: AnsiString; + public + constructor Create(const Message: AnsiString; ErrorCode: HRESULT; + const Source, HelpFile: AnsiString; HelpContext: Integer); + property HelpFile: AnsiString read FHelpFile write FHelpFile; + property Source: AnsiString read FSource write FSource; + end;} + + EOleRegistrationError = EOleError; { class(EOleError);} + + { Dispatch call descriptor } + + PCallDesc = ^TCallDesc; + TCallDesc = packed record + CallType: Byte; + ArgCount: Byte; + NamedArgCount: Byte; + ArgTypes: array[0..255] of Byte; + end; + + PDispDesc = ^TDispDesc; + TDispDesc = packed record + DispID: Integer; + ResType: Byte; + CallDesc: TCallDesc; + end; + +procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc; + DispIDs: PDispIDList; Params: Pointer; Result: PVariant); +procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo); + +{function HandleSafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID, + HelpFileName: WideString): HResult;} + +function CreateComObject(const ClassID: TGUID): IUnknown; +function CreateRemoteComObject(const MachineName: WideString; const ClassID: TGUID): IUnknown; +function CreateOleObject(const ClassName: AnsiString): IDispatch; +function GetActiveOleObject(const ClassName: AnsiString): IDispatch; + +procedure OleError(ErrorCode: HResult); +procedure OleCheck(Result: HResult); + +function StringToGUID(const S: AnsiString): TGUID; +function GUIDToString(const ClassID: TGUID): AnsiString; + +function ProgIDToClassID(const ProgID: AnsiString): TGUID; +function ClassIDToProgID(const ClassID: TGUID): AnsiString; + +procedure CreateRegKey(const Key, ValueName, Value: KOLstring); +procedure DeleteRegKey(const Key: KOLstring); +function GetRegStringValue(const Key, ValueName: KOLstring): KOLstring; + +function StringToLPOLESTR(const Source: KOLstring): POleStr; + +procedure RegisterComServer(const DLLName: KOLstring); +procedure RegisterAsService(const ClassID, ServiceName: KOLstring); + +function CreateClassID: KOLstring; + +procedure InterfaceConnect(const Source: IUnknown; const IID: TIID; + const Sink: IUnknown; var Connection: Longint); +procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID; + var Connection: Longint); + +type + TCoCreateInstanceExProc = function (const clsid: TCLSID; + unkOuter: IUnknown; dwClsCtx: Longint; ServerInfo: PCoServerInfo; + dwCount: Longint; rgmqResults: PMultiQIArray): HResult stdcall; + TCoInitializeExProc = function (pvReserved: Pointer; + coInit: Longint): HResult; stdcall; + TCoAddRefServerProcessProc = function :Longint; stdcall; + TCoReleaseServerProcessProc = function :Longint; stdcall; + TCoResumeClassObjectsProc = function :HResult; stdcall; + TCoSuspendClassObjectsProc = function :HResult; stdcall; + +// COM functions that are only available on DCOM updated OSs +// These pointers may be nil on Win95 or Win NT 3.51 systems +var + CoCreateInstanceEx: TCoCreateInstanceExProc = nil; + CoInitializeEx: TCoInitializeExProc = nil; + CoAddRefServerProcess: TCoAddRefServerProcessProc = nil; + CoReleaseServerProcess: TCoReleaseServerProcessProc = nil; + CoResumeClassObjects: TCoResumeClassObjectsProc = nil; + CoSuspendClassObjects: TCoSuspendClassObjectsProc = nil; + + +{ CoInitFlags determines the COM threading model of the application or current + thread. This bitflag value is passed to CoInitializeEx in ComServ initialization. + Assign COINIT_APARTMENTTHREADED or COINIT_MULTITHREADED to this variable before + Application.Initialize is called by the project source file to select a + threading model. Other CoInitializeEx flags (such as COINIT_SPEED_OVER_MEMORY) + can be OR'd in also. } +var + CoInitFlags: Integer = -1; // defaults to no threading model, call CoInitialize() + +function ComClassManager: TComClassManager; + +const + GUID_NULL: TGUID = '{00000000-0000-0000-0000-000000000000}'; + +implementation + +resourcestring + SCreateRegKeyError = 'Error creating system registry entry'; + SOleError = 'OLE error %.8x'; + SObjectFactoryMissing = 'Object factory for class %s missing'; + STypeInfoMissing = 'Type information missing for class %s'; + SBadTypeInfo = 'Incorrect type information for class %s'; + SDispIntfMissing = 'Dispatch interface missing from class %s'; + SNoMethod = 'Method ''%s'' not supported by automation object'; + SVarNotObject = 'Variant does not reference an automation object'; + SDCOMNotInstalled = 'DCOM not installed'; + SDAXError = 'DAX Error'; + + SAutomationWarning = 'COM Server Warning'; + SNoCloseActiveServer1 = 'There are still active COM objects in this ' + + 'application. One or more clients may have references to these objects, ' + + 'so manually closing '; + SNoCloseActiveServer2 = 'this application may cause those client ' + + 'application(s) to fail.'#13#10#13#10'Are you sure you want to close this ' + + 'application?'; + +var + OleUninitializing: Boolean; + +{ Handle a safe call exception } + +{function HandleSafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer; const ErrorIID: TGUID; const ProgID, + HelpFileName: WideString): HResult; +var + E: TObject; + CreateError: ICreateErrorInfo; + ErrorInfo: IErrorInfo; +begin + Result := E_UNEXPECTED; + E := ExceptObject; + if Succeeded(CreateErrorInfo(CreateError)) then + begin + CreateError.SetGUID(ErrorIID); + if ProgID <> '' then CreateError.SetSource(PWideChar(ProgID)); + if HelpFileName <> '' then CreateError.SetHelpFile(PWideChar(HelpFileName)); + if E is Exception then + begin + CreateError.SetDescription(PWideChar(WideString(Exception(E).Message))); + CreateError.SetHelpContext(Exception(E).HelpContext); + if (E is EOleSysError) and (EOleSysError(E).ErrorCode < 0) then + Result := EOleSysError(E).ErrorCode; + end; + if CreateError.QueryInterface(IErrorInfo, ErrorInfo) = S_OK then + SetErrorInfo(0, ErrorInfo); + end; +end;} + +{ TDispatchSilencer } + +type + TDispatchSilencer = class(TInterfacedObject, IUnknown, IDispatch) + private + Dispatch: IDispatch; + DispIntfIID: TGUID; + public + constructor Create(ADispatch: IUnknown; const ADispIntfIID: TGUID); + { IUnknown } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + { IDispatch } + function GetTypeInfoCount(out Count: Integer): HResult; stdcall; + function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; + function GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; + function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; + Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; + end; + +constructor TDispatchSilencer.Create(ADispatch: IUnknown; + const ADispIntfIID: TGUID); +begin + inherited Create; + DispIntfIID := ADispIntfIID; + OleCheck(ADispatch.QueryInterface(ADispIntfIID, Dispatch)); +end; + +function TDispatchSilencer.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + Result := inherited QueryInterface(IID, Obj); + if Result = E_NOINTERFACE then + if IsEqualGUID(IID, DispIntfIID) then + begin + IDispatch(Obj) := Self; + Result := S_OK; + end + else + Result := Dispatch.QueryInterface(IID, Obj); +end; + +function TDispatchSilencer.GetTypeInfoCount(out Count: Integer): HResult; +begin + Result := Dispatch.GetTypeInfoCount(Count); +end; + +function TDispatchSilencer.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; +begin + Result := Dispatch.GetTypeInfo(Index, LocaleID, TypeInfo); +end; + +function TDispatchSilencer.GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; +begin + Result := Dispatch.GetIDsOfNames(IID, Names, NameCount, LocaleID, DispIDs); +end; + +function TDispatchSilencer.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; + Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; +begin + { Ignore error since some containers, such as Internet Explorer 3.0x, will + return error when the method was not handled, or scripting errors occur } + Dispatch.Invoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, + ArgErr); + Result := S_OK; +end; + +{$IFNDEF _D2orD3} +{ TMultiReadExclusiveWriteSynchronizer } + +constructor TMultiReadExclusiveWriteSynchronizer.Create; +begin + inherited Create; + InitializeCriticalSection(FLock); + FReadExit := CreateEvent(nil, True, True, nil); // manual reset, start signaled + SetLength(FActiveThreads, 4); +end; + +destructor TMultiReadExclusiveWriteSynchronizer.Destroy; +begin + BeginWrite; + inherited Destroy; + CloseHandle(FReadExit); + DeleteCriticalSection(FLock); +end; + +function TMultiReadExclusiveWriteSynchronizer.WriterIsOnlyReader: Boolean; +var + I, Len: Integer; +begin + Result := False; + if FWriteRequestorID = 0 then Exit; + // We know a writer is waiting for entry with the FLock locked, + // so FActiveThreads is stable - no BeginRead could be resizing it now + I := 0; + Len := High(FActiveThreads); + while (I < Len) and + ((FActiveThreads[I].ThreadID = 0) or (FActiveThreads[I].ThreadID = FWriteRequestorID)) do + Inc(I); + Result := I >= Len; +end; + +procedure TMultiReadExclusiveWriteSynchronizer.BeginWrite; +begin + EnterCriticalSection(FLock); // Block new read or write ops from starting + if not FWriting then + begin + FWriteRequestorID := GetCurrentThreadID; // Indicate that writer is waiting for entry + if not WriterIsOnlyReader then // See if any other thread is reading + WaitForSingleObject(FReadExit, INFINITE); // Wait for current readers to finish + FSaveReadCount := FCount; // record prior read recursions for this thread + FCount := 0; + FWriteRequestorID := 0; + FWriting := True; + end; + Inc(FCount); // allow read recursions during write without signalling FReadExit event +end; + +procedure TMultiReadExclusiveWriteSynchronizer.EndWrite; +begin + Dec(FCount); + if FCount = 0 then + begin + FCount := FSaveReadCount; // restore read recursion count + FSaveReadCount := 0; + FWriting := False; + end; + LeaveCriticalSection(FLock); +end; + +procedure TMultiReadExclusiveWriteSynchronizer.BeginRead; +var + I: Integer; + ThreadID: Integer; + ZeroSlot: Integer; + AlreadyInRead: Boolean; +begin + ThreadID := GetCurrentThreadID; + // First, do a lightweight check to see if this thread already has a read lock + while InterlockedExchange(FReallocFlag, ThreadID) <> 0 do Sleep(0); + try // FActiveThreads array is now stable + I := 0; + while (I < High(FActiveThreads)) and (FActiveThreads[I].ThreadID <> ThreadID) do + Inc(I); + AlreadyInRead := I < High(FActiveThreads); + if AlreadyInRead then // This thread already has a read lock + begin // Don't grab FLock, since that could deadlock with + if not FWriting then // a waiting BeginWrite + begin // Bump up ref counts and exit + InterlockedIncrement(FCount); + Inc(FActiveThreads[I].RecursionCount); // thread safe = unique to threadid + end; + end + finally + FReallocFlag := 0; + end; + if not AlreadyInRead then + begin // Ok, we don't already have a lock, so do the hard work of making one + EnterCriticalSection(FLock); + try + if not FWriting then + begin + // This will call ResetEvent more than necessary on win95, but still work + if InterlockedIncrement(FCount) = 1 then + ResetEvent(FReadExit); // Make writer wait until all readers are finished. + I := 0; // scan for empty slot in activethreads list + ZeroSlot := -1; + while (I < High(FActiveThreads)) and (FActiveThreads[I].ThreadID <> ThreadID) do + begin + if (FActiveThreads[I].ThreadID = 0) and (ZeroSlot < 0) then ZeroSlot := I; + Inc(I); + end; + if I >= High(FActiveThreads) then // didn't find our threadid slot + begin + if ZeroSlot < 0 then // no slots available. Grow array to make room + begin // spin loop. wait for EndRead to put zero back into FReallocFlag + while InterlockedExchange(FReallocFlag, ThreadID) <> 0 do Sleep(0); + try + SetLength(FActiveThreads, High(FActiveThreads) + 3); + finally + FReallocFlag := 0; + end; + end + else // use an empty slot + I := ZeroSlot; + // no concurrency issue here. We're the only thread interested in this record. + FActiveThreads[I].ThreadID := ThreadID; + FActiveThreads[I].RecursionCount := 1; + end + else // found our threadid slot. + Inc(FActiveThreads[I].RecursionCount); // thread safe = unique to threadid + end; + finally + LeaveCriticalSection(FLock); + end; + end; +end; + +procedure TMultiReadExclusiveWriteSynchronizer.EndRead; +var + I, ThreadID, Len: Integer; +begin + if not FWriting then + begin + // Remove our threadid from the list of active threads + I := 0; + ThreadID := GetCurrentThreadID; + // wait for BeginRead to finish any pending realloc of FActiveThreads + while InterlockedExchange(FReallocFlag, ThreadID) <> 0 do Sleep(0); + try + Len := High(FActiveThreads); + while (I < Len) and (FActiveThreads[I].ThreadID <> ThreadID) do Inc(I); + assert(I < Len); + // no concurrency issues here. We're the only thread interested in this record. + Dec(FActiveThreads[I].RecursionCount); // threadsafe = unique to threadid + if FActiveThreads[I].RecursionCount = 0 then + FActiveThreads[I].ThreadID := 0; // must do this last! + finally + FReallocFlag := 0; + end; + if (InterlockedDecrement(FCount) = 0) or WriterIsOnlyReader then + SetEvent(FReadExit); // release next writer + end; +end; + +procedure FreeAndNil(var Obj); +var + P: TObject; +begin + P := TObject(Obj); + TObject(Obj) := nil; // clear the reference before destroying the object + P.Free; +end; +{$ENDIF} + +{ TComClassManager } +constructor TComClassManager.Create; +begin + inherited Create; + {$IFNDEF _D2orD3} + FLock := TMultiReadExclusiveWriteSynchronizer.Create; + {$ENDIF} +end; + +destructor TComClassManager.Destroy; +begin + {$IFNDEF _D2orD3} + FLock.Free; + {$ENDIF} + inherited Destroy; +end; + +procedure TComClassManager.AddObjectFactory(Factory: TComObjectFactory); +begin + {$IFNDEF _D2orD3} + FLock.BeginWrite; + try + {$ENDIF} + Factory.FNext := FFactoryList; + FFactoryList := Factory; + {$IFNDEF _D2orD3} + finally + FLock.EndWrite; + end; + {$ENDIF} +end; + +procedure TComClassManager.ForEachFactory(ComServer: TComServerObject; + FactoryProc: TFactoryProc); +var + Factory, Next: TComObjectFactory; +begin + {$IFNDEF _D2orD3} + FLock.BeginWrite; // FactoryProc could add or delete factories from list + try + {$ENDIF} + Factory := FFactoryList; + while Factory <> nil do + begin + Next := Factory.FNext; + if Factory.ComServer = ComServer then FactoryProc(Factory); + Factory := Next; + end; + {$IFNDEF _D2orD3} + finally + FLock.EndWrite; + end; + {$ENDIF} +end; + +function TComClassManager.GetFactoryFromClass(ComClass: TClass): TComObjectFactory; +begin + {$IFNDEF _D2orD3} + FLock.BeginRead; + try + {$ENDIF} + Result := FFactoryList; + while Result <> nil do + begin + if Result.ComClass = ComClass then Exit; + Result := Result.FNext; + end; + raise EOleError.CreateResFmt(e_Ole, Integer( @SObjectFactoryMissing ), [ComClass.ClassName]); + {$IFNDEF _D2orD3} + finally + FLock.EndRead; + end; + {$ENDIF} +end; + +function TComClassManager.GetFactoryFromClassID(const ClassID: TGUID): TComObjectFactory; +begin + {$IFNDEF _D2orD3} + FLock.BeginRead; + try + {$ENDIF} + Result := FFactoryList; + while Result <> nil do + begin + if IsEqualGUID(Result.ClassID, ClassID) then Exit; + Result := Result.FNext; + end; + {$IFNDEF _D2orD3} + finally + FLock.EndRead; + end; + {$ENDIF} +end; + +procedure TComClassManager.RemoveObjectFactory(Factory: TComObjectFactory); +var + F, P: TComObjectFactory; +begin + {$IFNDEF _D2orD3} + FLock.BeginWrite; + try + {$ENDIF} + P := nil; + F := FFactoryList; + while F <> nil do + begin + if F = Factory then + begin + if P <> nil then P.FNext := F.FNext else FFactoryList := F.FNext; + Exit; + end; + P := F; + F := F.FNext; + end; + {$IFNDEF _D2orD3} + finally + FLock.EndWrite; + end; + {$ENDIF} +end; + +{ TComObject } + +constructor TComObject.Create; +begin + FNonCountedObject := True; + CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType), nil); +end; + +constructor TComObject.CreateAggregated(const Controller: IUnknown); +begin + FNonCountedObject := True; + CreateFromFactory(ComClassManager.GetFactoryFromClass(ClassType), Controller); +end; + +constructor TComObject.CreateFromFactory(Factory: TComObjectFactory; + const Controller: IUnknown); +begin + FRefCount := 1; + FFactory := Factory; + FController := Pointer(Controller); + if not FNonCountedObject then FFactory.ComServer.CountObject(True); + Initialize; + Dec(FRefCount); +end; + +destructor TComObject.Destroy; +begin + if not OleUninitializing then + begin + if (FFactory <> nil) and not FNonCountedObject then + FFactory.ComServer.CountObject(False); + if FRefCount > 0 then CoDisconnectObject(Self, 0); + end; +end; + +function TComObject.GetController: IUnknown; +begin + Result := IUnknown(FController); +end; + +procedure TComObject.Initialize; +begin +end; + +function TComObject.SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; +var + Msg: AnsiString; + Handled: Integer; +begin + Handled := 0; + if ServerExceptionHandler <> nil then + begin + if ExceptObject is Exception then + Msg := Exception(ExceptObject).Message; + Result := 0; + ServerExceptionHandler.OnException(ClassName, + ExceptObject.ClassName, Msg, Integer(ExceptAddr), + WideString(GUIDToString(FFactory.ErrorIID)), + FFactory.ProgID, Handled, Result); + end; + if Handled = 0 then + {Result := HandleSafeCallException(ExceptObject, ExceptAddr, + FFactory.ErrorIID, FFactory.ProgID, FFactory.ComServer.HelpFileName);} +end; + +{ TComObject.IUnknown } + +function TComObject.ObjQueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; +end; + +function TComObject.ObjAddRef: Integer; +begin + Result := InterlockedIncrement(FRefCount); +end; + +function TComObject.ObjRelease: Integer; +begin + // InterlockedDecrement returns only 0 or 1 on Win95 and NT 3.51 + // returns actual result on NT 4.0 + Result := InterlockedDecrement(FRefCount); + if Result = 0 then Destroy; +end; + +{ TComObject.IUnknown for other interfaces } + +function TComObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if FController <> nil then + Result := IUnknown(FController).QueryInterface(IID, Obj) else + Result := ObjQueryInterface(IID, Obj); +end; + +function TComObject._AddRef: Integer; +begin + if FController <> nil then + Result := IUnknown(FController)._AddRef else + Result := ObjAddRef; +end; + +function TComObject._Release: Integer; +begin + if FController <> nil then + Result := IUnknown(FController)._Release else + Result := ObjRelease; +end; + +{ TComObject.ISupportErrorInfo } + +function TComObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult; +begin + if GetInterfaceEntry(iid) <> nil then + Result := S_OK else + Result := S_FALSE; +end; + +{ TComObjectFactory } + +constructor TComObjectFactory.Create(ComServer: TComServerObject; + ComClass: TComClass; const ClassID: TGUID; const ClassName, + Description: AnsiString; Instancing: TClassInstancing; + ThreadingModel: TThreadingModel); +begin + IsMultiThread := IsMultiThread or (ThreadingModel <> tmSingle); + if ThreadingModel in [tmFree, tmBoth] then + CoInitFlags := COINIT_MULTITHREADED else + if (ThreadingModel = tmApartment) and (CoInitFlags <> COINIT_MULTITHREADED) then + CoInitFlags := COINIT_APARTMENTTHREADED; + ComClassManager.AddObjectFactory(Self); + FComServer := ComServer; + FComClass := ComClass; + FClassID := ClassID; + FClassName := ClassName; + FDescription := Description; + FInstancing := Instancing; + FErrorIID := IUnknown; + FShowErrors := True; + FThreadingModel := ThreadingModel; + FRegister := -1; +end; + +destructor TComObjectFactory.Destroy; +begin + if FRegister <> -1 then CoRevokeClassObject(FRegister); + ComClassManager.RemoveObjectFactory(Self); +end; + +function TComObjectFactory.CreateComObject(const Controller: IUnknown): TComObject; +begin + Result := TComClass(FComClass).CreateFromFactory(Self, Controller); +end; + +function TComObjectFactory.GetProgID: AnsiString; +begin + if FClassName <> '' then + Result := FComServer.ServerName + '.' + FClassName else + Result := ''; +end; + +procedure TComObjectFactory.RegisterClassObject; +const + RegFlags: array[ciSingleInstance..ciMultiInstance] of Integer = ( + REGCLS_SINGLEUSE, REGCLS_MULTIPLEUSE); + SuspendedFlag: array[Boolean] of Integer = (0, REGCLS_SUSPENDED); +begin + if FInstancing <> ciInternal then + OleCheck(CoRegisterClassObject(FClassID, Self, CLSCTX_LOCAL_SERVER, + RegFlags[FInstancing] or SuspendedFlag[FComServer.StartSuspended], FRegister)); +end; + +procedure TComObjectFactory.UpdateRegistry(Register: Boolean); +const + ThreadStrs: array[TThreadingModel] of AnsiString = + ('', 'Apartment', 'Free', 'Both'); +var + ClassID, ProgID, ServerKeyName, ShortFileName: AnsiString; +begin + if FInstancing = ciInternal then Exit; + ClassID := GUIDToString(FClassID); + ProgID := GetProgID; + ServerKeyName := 'CLSID\' + ClassID + '\' + FComServer.ServerKey; + if Register then + begin + CreateRegKey('CLSID\' + ClassID, '', Description); + ShortFileName := FComServer.ServerFileName; + if {Ansi}Pos(' ', ShortFileName) <> 0 then + ShortFileName := ExtractShortPathName(ShortFileName); + CreateRegKey(ServerKeyName, '', ShortFileName); + if (FThreadingModel <> tmSingle) and IsLibrary then + CreateRegKey(ServerKeyName, 'ThreadingModel', ThreadStrs[FThreadingModel]); + if ProgID <> '' then + begin + CreateRegKey(ProgID, '', Description); + CreateRegKey(ProgID + '\Clsid', '', ClassID); + CreateRegKey('CLSID\' + ClassID + '\ProgID', '', ProgID); + end; + end else + begin + if ProgID <> '' then + begin + DeleteRegKey('CLSID\' + ClassID + '\ProgID'); + DeleteRegKey(ProgID + '\Clsid'); + DeleteRegKey(ProgID); + end; + DeleteRegKey(ServerKeyName); + DeleteRegKey('CLSID\' + ClassID); + end; +end; + +function TComObjectFactory.GetLicenseString: WideString; +begin + if FSupportsLicensing then Result := FLicString + else Result := ''; +end; + +function TComObjectFactory.HasMachineLicense: Boolean; +begin + Result := True; +end; + +function TComObjectFactory.ValidateUserLicense(const LicStr: WideString): Boolean; +begin + Result := AnsiCompareText(LicStr, FLicString) = 0; +end; + +{ TComObjectFactory.IUnknown } + +function TComObjectFactory.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; +end; + +function TComObjectFactory._AddRef: Integer; +begin + Result := ComServer.CountFactory(True); +end; + +function TComObjectFactory._Release: Integer; +begin + Result := ComServer.CountFactory(False); +end; + +{ TComObjectFactory.IClassFactory } + +function TComObjectFactory.CreateInstance(const UnkOuter: IUnknown; + const IID: TGUID; out Obj): HResult; +begin + Result := CreateInstanceLic(UnkOuter, nil, IID, '', Obj); +end; + +function TComObjectFactory.LockServer(fLock: BOOL): HResult; +begin + Result := CoLockObjectExternal(Self, fLock, True); + // Keep com server alive until this class factory is unlocked + ComServer.CountObject(fLock); +end; + +{ TComObjectFactory.IClassFactory2 } + +function TComObjectFactory.GetLicInfo(var licInfo: TLicInfo): HResult; +begin + Result := S_OK; + try + with licInfo do + begin + cbLicInfo := SizeOf(licInfo); + fRuntimeKeyAvail := (not FSupportsLicensing) or (GetLicenseString <> ''); + fLicVerified := (not FSupportsLicensing) or HasMachineLicense; + end; + except + Result := E_UNEXPECTED; + end; +end; + +function TComObjectFactory.RequestLicKey(dwResrved: Longint; out bstrKey: WideString): HResult; +begin + // Can't give away a license key on an unlicensed machine + if not HasMachineLicense then + begin + Result := CLASS_E_NOTLICENSED; + Exit; + end; + bstrKey := FLicString; + Result := NOERROR; +end; + +function TComObjectFactory.CreateInstanceLic(const unkOuter: IUnknown; + const unkReserved: IUnknown; const iid: TIID; const bstrKey: WideString; + out vObject): HResult; stdcall; +var + ComObject: TComObject; +begin + // We can't write to a nil pointer. Duh. + if @vObject = nil then + begin + Result := E_POINTER; + Exit; + end; + // In case of failure, make sure we return at least a nil interface. + Pointer(vObject) := nil; + // Check for licensing. + if FSupportsLicensing and + ((bstrKey <> '') and (not ValidateUserLicense(bstrKey))) or + ((bstrKey = '') and (not HasMachineLicense)) then + begin + Result := CLASS_E_NOTLICENSED; + Exit; + end; + // We can only aggregate if they are requesting our IUnknown. + if (unkOuter <> nil) and not (IsEqualIID(iid, IUnknown)) then + begin + Result := CLASS_E_NOAGGREGATION; + Exit; + end; + try + ComObject := CreateComObject(UnkOuter); + except + if FShowErrors and (ExceptObject is Exception) then + with Exception(ExceptObject) do + begin + {if (Message <> '') and (AnsiLastChar(Message) > '.') then + Message := Message + '.';} + MessageBox(0, PKOLChar(Message), PKOLChar(KOLString( SDAXError )), MB_OK or MB_ICONSTOP or + MB_SETFOREGROUND); + end; + Result := E_UNEXPECTED; + Exit; + end; + Result := ComObject.ObjQueryInterface(IID, vObject); + if ComObject.RefCount = 0 then ComObject.Free; +end; + +{ TAggregatedObject } + +constructor TAggregatedObject.Create(Controller: IUnknown); +begin + FController := Pointer(Controller); +end; + +function TAggregatedObject.GetController: IUnknown; +begin + Result := IUnknown(FController); +end; + +{ TAggregatedObject.IUnknown } + +function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + Result := IUnknown(FController).QueryInterface(IID, Obj); +end; + +function TAggregatedObject._AddRef: Integer; +begin + Result := IUnknown(FController)._AddRef; +end; + +function TAggregatedObject._Release: Integer; stdcall; +begin + Result := IUnknown(FController)._Release; +end; + +{ TContainedObject.IUnknown } + +function TContainedObject.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; +end; + +{ TTypedComObject.IProvideClassInfo } + +function TTypedComObject.GetClassInfo(out TypeInfo: ITypeInfo): HResult; +begin + TypeInfo := TTypedComObjectFactory(FFactory).FClassInfo; + Result := S_OK; +end; + +{ TTypedComObjectFactory } + +constructor TTypedComObjectFactory.Create(ComServer: TComServerObject; + TypedComClass: TTypedComClass; const ClassID: TGUID; + Instancing: TClassInstancing; ThreadingModel: TThreadingModel); +var + ClassName, Description: WideString; +begin + if ComServer.TypeLib.GetTypeInfoOfGUID(ClassID, FClassInfo) <> S_OK then + raise EOleError.CreateResFmt(e_Ole, Integer(@STypeInfoMissing), [TypedComClass.ClassName]); + OleCheck(FClassInfo.GetDocumentation(MEMBERID_NIL, @ClassName, + @Description, nil, nil)); + inherited Create(ComServer, TypedComClass, ClassID, + ClassName, Description, Instancing, ThreadingModel); +end; + +function TTypedComObjectFactory.GetInterfaceTypeInfo( + TypeFlags: Integer): ITypeInfo; +const + FlagsMask = IMPLTYPEFLAG_FDEFAULT or IMPLTYPEFLAG_FSOURCE; +var + ClassAttr: PTypeAttr; + I, TypeInfoCount, Flags: Integer; + RefType: HRefType; +begin + OleCheck(FClassInfo.GetTypeAttr(ClassAttr)); + TypeInfoCount := ClassAttr^.cImplTypes; + ClassInfo.ReleaseTypeAttr(ClassAttr); + for I := 0 to TypeInfoCount - 1 do + begin + OleCheck(ClassInfo.GetImplTypeFlags(I, Flags)); + if Flags and FlagsMask = TypeFlags then + begin + OleCheck(ClassInfo.GetRefTypeOfImplType(I, RefType)); + OleCheck(ClassInfo.GetRefTypeInfo(RefType, Result)); + Exit; + end; + end; + Result := nil; +end; + +procedure TTypedComObjectFactory.UpdateRegistry(Register: Boolean); +var + ClassKey: AnsiString; + TypeLib: ITypeLib; + TLibAttr: PTLibAttr; +begin + ClassKey := 'CLSID\' + GUIDToString(FClassID); + if Register then + begin + inherited UpdateRegistry(Register); + TypeLib := FComServer.TypeLib; + OleCheck(TypeLib.GetLibAttr(TLibAttr)); + try + CreateRegKey(ClassKey + '\Version', '', Format('%d.%d', + [TLibAttr.wMajorVerNum, TLibAttr.wMinorVerNum])); + CreateRegKey(ClassKey + '\TypeLib', '', GUIDToString(TLibAttr.guid)); + finally + TypeLib.ReleaseTLibAttr(TLibAttr); + end; + end else + begin + DeleteRegKey(ClassKey + '\TypeLib'); + DeleteRegKey(ClassKey + '\Version'); + inherited UpdateRegistry(Register); + end; +end; + +{ TAutoObject } + +procedure TAutoObject.EventConnect(const Sink: IUnknown; + Connecting: Boolean); +begin + if Connecting then + begin + OleCheck(Sink.QueryInterface(FAutoFactory.FEventIID, FEventSink)); + EventSinkChanged(TDispatchSilencer.Create(Sink, FAutoFactory.FEventIID)); + end + else + begin + FEventSink := nil; + EventSinkChanged(nil); + end; +end; + +procedure TAutoObject.EventSinkChanged(const EventSink: IUnknown); +begin +end; + +procedure TAutoObject.Initialize; +begin + FAutoFactory := Factory as TAutoObjectFactory; + inherited Initialize; +end; + +{ TAutoObject.IDispatch } + +function TAutoObject.GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; +begin + Result := DispGetIDsOfNames(FAutoFactory.DispTypeInfo, + Names, NameCount, DispIDs); +end; + +function TAutoObject.GetTypeInfo(Index, LocaleID: Integer; + out TypeInfo): HResult; +begin + Pointer(TypeInfo) := nil; + if Index <> 0 then + begin + Result := DISP_E_BADINDEX; + Exit; + end; + ITypeInfo(TypeInfo) := TAutoObjectFactory(Factory).DispTypeInfo; + Result := S_OK; +end; + +function TAutoObject.GetTypeInfoCount(out Count: Integer): HResult; +begin + Count := 1; + Result := S_OK; +end; + +function TAutoObject.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 := TAutoObjectFactory(Factory).DispTypeInfo.Invoke(Pointer( + Integer(Self) + TAutoObjectFactory(Factory).DispIntfEntry.IOffset), + DispID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr); +end; + +{ TAutoObjectFactory } + +constructor TAutoObjectFactory.Create(ComServer: TComServerObject; + AutoClass: TAutoClass; const ClassID: TGUID; + Instancing: TClassInstancing; ThreadingModel: TThreadingModel); +var + TypeAttr: PTypeAttr; +begin + inherited Create(ComServer, AutoClass, ClassID, Instancing, ThreadingModel); + FDispTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT); + if FDispTypeInfo = nil then + raise EOleError.CreateResFmt(e_Ole, Integer(@SBadTypeInfo), [AutoClass.ClassName]); + OleCheck(FDispTypeInfo.GetTypeAttr(TypeAttr)); + FDispIntfEntry := GetIntfEntry(TypeAttr^.guid); + FDispTypeInfo.ReleaseTypeAttr(TypeAttr); + if FDispIntfEntry = nil then + raise EOleError.CreateResFmt(e_Ole, Integer(@SDispIntfMissing), + [AutoClass.ClassName]); + FErrorIID := FDispIntfEntry^.IID; + FEventTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT or + IMPLTYPEFLAG_FSOURCE); + if FEventTypeInfo <> nil then + begin + OleCheck(FEventTypeInfo.GetTypeAttr(TypeAttr)); + FEventIID := TypeAttr.guid; + FEventTypeInfo.ReleaseTypeAttr(TypeAttr); + end; +end; + +function TAutoObjectFactory.GetIntfEntry(Guid: TGUID): PInterfaceEntry; +begin + Result := FComClass.GetInterfaceEntry(Guid); +end; + +{ TAutoIntfObject } + +constructor TAutoIntfObject.Create(const TypeLib: ITypeLib; const DispIntf: TGUID); +begin + inherited Create; + OleCheck(TypeLib.GetTypeInfoOfGuid(DispIntf, FDispTypeInfo)); + FDispIntfEntry := GetInterfaceEntry(DispIntf); +end; + +{ TAutoIntfObject.IDispatch } + +function TAutoIntfObject.GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; +begin + Result := DispGetIDsOfNames(FDispTypeInfo, Names, NameCount, DispIDs); +end; + +function TAutoIntfObject.GetTypeInfo(Index, LocaleID: Integer; + out TypeInfo): HResult; +begin + Pointer(TypeInfo) := nil; + if Index <> 0 then + begin + Result := DISP_E_BADINDEX; + Exit; + end; + ITypeInfo(TypeInfo) := FDispTypeInfo; + Result := S_OK; +end; + +function TAutoIntfObject.GetTypeInfoCount(out Count: Integer): HResult; +begin + Count := 1; + Result := S_OK; +end; + +function TAutoIntfObject.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 := FDispTypeInfo.Invoke(Pointer(Integer(Self) + + FDispIntfEntry.IOffset), DispID, Flags, TDispParams(Params), VarResult, + ExcepInfo, ArgErr); +end; + +function TAutoIntfObject.InterfaceSupportsErrorInfo(const iid: TIID): HResult; +begin + if IsEqualGUID(DispIID, iid) then + Result := S_OK else + Result := S_FALSE; +end; + +function TAutoIntfObject.SafeCallException(ExceptObject: TObject; + ExceptAddr: Pointer): HResult; +begin + Result := 0; { HandleSafeCallException(ExceptObject, ExceptAddr, DispIID, '', ''); } +end; + +const +{ Maximum number of dispatch arguments } + + MaxDispArgs = 64; {!!!} + +{ Special variant type codes } + + varStrArg = $0048; + +{ Parameter type masks } + + atVarMask = $3F; + atTypeMask = $7F; + atByRef = $80; + +{function TrimPunctuation(const S: AnsiString): AnsiString; +var + P: PChar; +begin + Result := S; + P := AnsiLastChar(Result); + while (Length(Result) > 0) and (P^ in [#0..#32, '.']) do + begin + SetLength(Result, P - PChar(Result)); + P := AnsiLastChar(Result); + end; +end;} + +{ EOleSysError } + +{constructor EOleSysError.Create(const Message: AnsiString; + ErrorCode: HRESULT; HelpContext: Integer); +var + S: AnsiString; +begin + S := Message; + if S = '' then + begin + S := SysErrorMessage(ErrorCode); + if S = '' then FmtStr(S, SOleError, [ErrorCode]); + end; + inherited CreateHelp(S, HelpContext); + FErrorCode := ErrorCode; +end;} + +{ EOleException } + +{constructor EOleException.Create(const Message: AnsiString; ErrorCode: HRESULT; + const Source, HelpFile: AnsiString; HelpContext: Integer); +begin + inherited Create(TrimPunctuation(Message), ErrorCode, HelpContext); + FSource := Source; + FHelpFile := HelpFile; +end;} + + +{ Raise EOleSysError exception from an error code } + +procedure OleError(ErrorCode: HResult); +begin + raise EOleSysError.Create(e_Ole, 'OLE error: ' + Int2Str( ErrorCode ) ); +end; + +{ Raise EOleSysError exception if result code indicates an error } + +procedure OleCheck(Result: HResult); +begin + if not Succeeded(Result) then OleError(Result); +end; + +{ Convert a AnsiString to a GUID } + +function StringToGUID(const S: AnsiString): TGUID; +begin + OleCheck(CLSIDFromString(PWideChar(WideString(S)), Result)); +end; + +{ Convert a GUID to a AnsiString } + +function GUIDToString(const ClassID: TGUID): AnsiString; +var + P: PWideChar; +begin + OleCheck(StringFromCLSID(ClassID, P)); + Result := P; + CoTaskMemFree(P); +end; + +{ Convert a programmatic ID to a class ID } + +function ProgIDToClassID(const ProgID: AnsiString): TGUID; +begin + OleCheck(CLSIDFromProgID(PWideChar(WideString(ProgID)), Result)); +end; + +{ Convert a class ID to a programmatic ID } + +function ClassIDToProgID(const ClassID: TGUID): AnsiString; +var + P: PWideChar; +begin + OleCheck(ProgIDFromCLSID(ClassID, P)); + Result := P; + CoTaskMemFree(P); +end; + +{ Create registry key } + +procedure CreateRegKey(const Key, ValueName, Value: KOLstring); +var + Handle: HKey; + Status, Disposition: Integer; +begin + Status := RegCreateKeyEx(HKEY_CLASSES_ROOT, PKOLChar(Key), 0, '', + REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE, nil, Handle, + @Disposition); + if Status = 0 then + begin + Status := RegSetValueEx(Handle, PKOLChar(ValueName), 0, REG_SZ, + PKOLChar(Value), Length(Value) + 1); + RegCloseKey(Handle); + end; + if Status <> 0 then raise EOleRegistrationError.CreateResFmt(e_Registry, + Integer(@SCreateRegKeyError), [ nil ] ); +end; + +{ Delete registry key } + +procedure DeleteRegKey(const Key: KOLstring); +begin + RegDeleteKey(HKEY_CLASSES_ROOT, PKOLChar(Key)); +end; + +{ Get registry value } + +function GetRegStringValue(const Key, ValueName: KOLstring): KOLstring; +var + Size: DWord; + RegKey: HKEY; +begin + Result := ''; + if RegOpenKey(HKEY_CLASSES_ROOT, PKOLChar(Key), RegKey) = ERROR_SUCCESS then + try + Size := 256; + SetLength(Result, Size); + if RegQueryValueEx(RegKey, PKOLChar(ValueName), nil, nil, PByte(PKOLChar(Result)), @Size) = ERROR_SUCCESS then + SetLength(Result, Size - 1) else + Result := ''; + finally + RegCloseKey(RegKey); + end; +end; + +function CreateComObject(const ClassID: TGUID): IUnknown; +begin + OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or + CLSCTX_LOCAL_SERVER, IUnknown, Result)); +end; + +function CreateRemoteComObject(const MachineName: WideString; + const ClassID: TGUID): IUnknown; +const + LocalFlags = CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER or CLSCTX_INPROC_SERVER; + RemoteFlags = CLSCTX_REMOTE_SERVER; +var + MQI: TMultiQI; + ServerInfo: TCoServerInfo; + IID_IUnknown: TGuid; + Flags, Size: DWORD; + LocalMachine: array [0..MAX_COMPUTERNAME_LENGTH] of KOLchar; +begin + if @CoCreateInstanceEx = nil then + raise Exception.CreateResFmt(e_Com, Integer(@SDCOMNotInstalled), [nil]); + FillChar(ServerInfo, sizeof(ServerInfo), 0); + ServerInfo.pwszName := PWideChar(MachineName); + IID_IUnknown := IUnknown; + MQI.IID := @IID_IUnknown; + MQI.itf := nil; + MQI.hr := 0; + { If a MachineName is specified check to see if it the local machine. + If it isn't, do not allow LocalServers to be used. } + if Length(MachineName) > 0 then + begin + Size := Sizeof(LocalMachine); // Win95 is hypersensitive to size + if GetComputerName(LocalMachine, Size) and + (AnsiCompareText(LocalMachine, MachineName) = 0) then + Flags := LocalFlags else + Flags := RemoteFlags; + end else + Flags := LocalFlags; + OleCheck(CoCreateInstanceEx(ClassID, nil, Flags, @ServerInfo, 1, @MQI)); + OleCheck(MQI.HR); + Result := MQI.itf; +end; + +function CreateOleObject(const ClassName: AnsiString): IDispatch; +var + ClassID: TCLSID; +begin + ClassID := ProgIDToClassID(ClassName); + OleCheck(CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or + CLSCTX_LOCAL_SERVER, IDispatch, Result)); +end; + +function GetActiveOleObject(const ClassName: AnsiString): IDispatch; +var + ClassID: TCLSID; + Unknown: IUnknown; +begin + ClassID := ProgIDToClassID(ClassName); + OleCheck(GetActiveObject(ClassID, nil, Unknown)); + OleCheck(Unknown.QueryInterface(IDispatch, Result)); +end; + +function StringToLPOLESTR(const Source: KOLstring): POleStr; +var + SourceLen: Integer; + Buffer: PWideChar; +begin + SourceLen := Length(Source); + Buffer := CoTaskMemAlloc((SourceLen+1) * sizeof(WideChar)); + StringToWideChar( Source, Buffer, SourceLen+1 ); + Result := POleStr( Buffer ); +end; + +function CreateClassID: KOLstring; +var + ClassID: TCLSID; + P: PWideChar; +begin + CoCreateGuid(ClassID); + StringFromCLSID(ClassID, P); + Result := P; + CoTaskMemFree(P); +end; + +procedure RegisterComServer(const DLLName: KOLstring); +type + TRegProc = function: HResult; stdcall; +const + RegProcName = 'DllRegisterServer'; { Do not localize } +var + Handle: THandle; + RegProc: TRegProc; +begin + {$IFDEF _D2orD3} + Handle := LoadLibrary( PChar( DLLName ) ); + {$ELSE} + Handle := SafeLoadLibrary(DLLName); + {$ENDIF} + if Handle <= HINSTANCE_ERROR then + raise Exception.CreateFmt( e_Com, '%s: %s', [SysErrorMessage(GetLastError), DLLName]); + try + RegProc := GetProcAddress(Handle, RegProcName); + if Assigned(RegProc) then OleCheck(RegProc) else RaiseLastWin32Error; + finally + FreeLibrary(Handle); + end; +end; + +procedure RegisterAsService(const ClassID, ServiceName: KOLstring); +begin + CreateRegKey('AppID\' + ClassID, 'LocalService', ServiceName); + CreateRegKey('CLSID\' + ClassID, 'AppID', ClassID); +end; + +{ Connect an IConnectionPoint interface } + +procedure InterfaceConnect(const Source: IUnknown; const IID: TIID; + const Sink: IUnknown; var Connection: Longint); +var + CPC: IConnectionPointContainer; + CP: IConnectionPoint; +begin + Connection := 0; + if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then + if Succeeded(CPC.FindConnectionPoint(IID, CP)) then + CP.Advise(Sink, Connection); +end; + +{ Disconnect an IConnectionPoint interface } + +procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID; + var Connection: Longint); +var + CPC: IConnectionPointContainer; + CP: IConnectionPoint; +begin + if Connection <> 0 then + if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then + if Succeeded(CPC.FindConnectionPoint(IID, CP)) then + if Succeeded(CP.Unadvise(Connection)) then Connection := 0; +end; + +procedure LoadComExProcs; +var + Ole32: HModule; +begin + Ole32 := GetModuleHandle('ole32.dll'); + if Ole32 <> 0 then + begin + @CoCreateInstanceEx := GetProcAddress(Ole32, 'CoCreateInstanceEx'); + @CoInitializeEx := GetProcAddress(Ole32, 'CoInitializeEx'); + @CoAddRefServerProcess := GetProcAddress(Ole32, 'CoAddRefServerProcess'); + @CoReleaseServerProcess := GetProcAddress(Ole32, 'CoReleaseServerProcess'); + @CoResumeClassObjects := GetProcAddress(Ole32, 'CoResumeClassObjects'); + @CoSuspendClassObjects := GetProcAddress(Ole32, 'CoSuspendClassObjects'); + end; +end; + +procedure SafeCallError(ErrorCode: Integer; ErrorAddr: Pointer); +var + ErrorInfo: IErrorInfo; + Source, Description, HelpFile: WideString; + HelpContext: Longint; +begin + HelpContext := 0; + if GetErrorInfo(0, ErrorInfo) = S_OK then + begin + ErrorInfo.GetSource(Source); + ErrorInfo.GetDescription(Description); + ErrorInfo.GetHelpFile(HelpFile); + ErrorInfo.GetHelpContext(HelpContext); + end; + raise EOleException.Create(e_Ole, Description + Int2Str( ErrorCode ) {, Source, + HelpFile, HelpContext} ) at ErrorAddr; +end; + +{ Call Invoke method on the given IDispatch interface using the given + call descriptor, dispatch IDs, parameters, and result } + +procedure DispatchInvoke(const Dispatch: IDispatch; CallDesc: PCallDesc; + DispIDs: PDispIDList; Params: Pointer; Result: PVariant); +type + PVarArg = ^TVarArg; + TVarArg = array[0..3] of DWORD; + TStringDesc = record + BStr: PWideChar; + PStr: pAnsiString; + end; +var + I, J, K, ArgType, ArgCount, StrCount, DispID, InvKind, Status: Integer; + VarFlag: Byte; + ParamPtr: ^Integer; + ArgPtr, VarPtr: PVarArg; + DispParams: TDispParams; + ExcepInfo: TExcepInfo; + Strings: array[0..MaxDispArgs - 1] of TStringDesc; + Args: array[0..MaxDispArgs - 1] of TVarArg; +begin + StrCount := 0; + try + ArgCount := CallDesc^.ArgCount; + if ArgCount <> 0 then + begin + ParamPtr := Params; + ArgPtr := @Args[ArgCount]; + I := 0; + repeat + Dec(Integer(ArgPtr), SizeOf(TVarData)); + ArgType := CallDesc^.ArgTypes[I] and atTypeMask; + VarFlag := CallDesc^.ArgTypes[I] and atByRef; + if ArgType = varError then + begin + ArgPtr^[0] := varError; + ArgPtr^[2] := DWORD(DISP_E_PARAMNOTFOUND); + end else + begin + if ArgType = varStrArg then + begin + with Strings[StrCount] do + if VarFlag <> 0 then + begin + BStr := StringToOleStr(pAnsiString(ParamPtr^)^); + PStr := pAnsiString(ParamPtr^); + ArgPtr^[0] := varOleStr or varByRef; + ArgPtr^[2] := Integer(@BStr); + end else + begin + BStr := StringToOleStr(pAnsiString(ParamPtr)^); + PStr := nil; + ArgPtr^[0] := varOleStr; + ArgPtr^[2] := Integer(BStr); + end; + Inc(StrCount); + end else + if VarFlag <> 0 then + begin + if (ArgType = varVariant) and + (PVarData(ParamPtr^)^.VType = varString) then + VarCast(PVariant(ParamPtr^)^, PVariant(ParamPtr^)^, varOleStr); + ArgPtr^[0] := ArgType or varByRef; + ArgPtr^[2] := ParamPtr^; + end else + if ArgType = varVariant then + begin + if PVarData(ParamPtr)^.VType = varString then + begin + with Strings[StrCount] do + begin + BStr := StringToOleStr(AnsiString(PVarData(ParamPtr^)^.VString)); + PStr := nil; + ArgPtr^[0] := varOleStr; + ArgPtr^[2] := Integer(BStr); + end; + Inc(StrCount); + end else + begin + VarPtr := PVarArg(ParamPtr); + ArgPtr^[0] := VarPtr^[0]; + ArgPtr^[1] := VarPtr^[1]; + ArgPtr^[2] := VarPtr^[2]; + ArgPtr^[3] := VarPtr^[3]; + Inc(Integer(ParamPtr), 12); + end; + end else + begin + ArgPtr^[0] := ArgType; + ArgPtr^[2] := ParamPtr^; + if (ArgType >= varDouble) and (ArgType <= varDate) then + begin + Inc(Integer(ParamPtr), 4); + ArgPtr^[3] := ParamPtr^; + end; + end; + Inc(Integer(ParamPtr), 4); + end; + Inc(I); + until I = ArgCount; + end; + DispParams.rgvarg := @Args; + DispParams.rgdispidNamedArgs := @DispIDs[1]; + DispParams.cArgs := ArgCount; + DispParams.cNamedArgs := CallDesc^.NamedArgCount; + DispID := DispIDs[0]; + InvKind := CallDesc^.CallType; + if InvKind = DISPATCH_PROPERTYPUT then + begin + if Args[0][0] and varTypeMask = varDispatch then + InvKind := DISPATCH_PROPERTYPUTREF; + DispIDs[0] := DISPID_PROPERTYPUT; + Dec(Integer(DispParams.rgdispidNamedArgs), SizeOf(Integer)); + Inc(DispParams.cNamedArgs); + end else + if (InvKind = DISPATCH_METHOD) and (ArgCount = 0) and (Result <> nil) then + InvKind := DISPATCH_METHOD or DISPATCH_PROPERTYGET; + Status := Dispatch.Invoke(DispID, GUID_NULL, 0, InvKind, DispParams, + Result, @ExcepInfo, nil); + if Status <> 0 then DispatchInvokeError(Status, ExcepInfo); + J := StrCount; + while J <> 0 do + begin + Dec(J); + with Strings[J] do + if PStr <> nil then OleStrToStrVar(BStr, PStr^); + end; + finally + K := StrCount; + while K <> 0 do + begin + Dec(K); + SysFreeString(Strings[K].BStr); + end; + end; +end; + +{ Call GetIDsOfNames method on the given IDispatch interface } + +procedure GetIDsOfNames(const Dispatch: IDispatch; Names: PAnsiChar; + NameCount: Integer; DispIDs: PDispIDList); + + procedure RaiseNameException; + begin + raise EOleError.CreateResFmt(e_Com, Integer( @SNoMethod ), [Names]); + end; + +type + PNamesArray = ^TNamesArray; + TNamesArray = array[0..0] of PWideChar; +var + N, SrcLen, DestLen: Integer; + Src: PAnsiChar; + Dest: PWideChar; + NameRefs: PNamesArray; + StackTop: Pointer; + Temp: Integer; +begin + Src := Names; + N := 0; + asm + MOV StackTop, ESP + MOV EAX, NameCount + INC EAX + SHL EAX, 2 // sizeof pointer = 4 + SUB ESP, EAX + LEA EAX, NameRefs + MOV [EAX], ESP + end; + repeat + SrcLen := StrLen(Src); + DestLen := MultiByteToWideChar(0, 0, Src, SrcLen, nil, 0) + 1; + asm + MOV EAX, DestLen + ADD EAX, EAX + ADD EAX, 3 // round up to 4 byte boundary + AND EAX, not 3 + SUB ESP, EAX + LEA EAX, Dest + MOV [EAX], ESP + end; + if N = 0 then NameRefs[0] := Dest else NameRefs[NameCount - N] := Dest; + MultiByteToWideChar(0, 0, Src, SrcLen, Dest, DestLen); + Dest[DestLen-1] := #0; + Inc(Src, SrcLen+1); + Inc(N); + until N = NameCount; + Temp := Dispatch.GetIDsOfNames(GUID_NULL, NameRefs, NameCount, + GetThreadLocale, DispIDs); + if Temp = Integer(DISP_E_UNKNOWNNAME) then RaiseNameException else OleCheck(Temp); + asm + MOV ESP, StackTop + end; +end; + +{ Central call dispatcher } + +procedure VarDispInvoke(Result: PVariant; const Instance: Variant; + CallDesc: PCallDesc; Params: Pointer); cdecl; + + procedure RaiseException; + begin + raise EOleError.CreateResFmt(e_Com, Integer( @SVarNotObject ), [ nil ] ); + end; + +var + Dispatch: Pointer; + DispIDs: array[0..MaxDispArgs - 1] of Integer; +begin + if TVarData(Instance).VType = varDispatch then + Dispatch := TVarData(Instance).VDispatch + else if TVarData(Instance).VType = (varDispatch or varByRef) then + Dispatch := Pointer(TVarData(Instance).VPointer^) + else RaiseException; + GetIDsOfNames(IDispatch(Dispatch), @CallDesc^.ArgTypes[CallDesc^.ArgCount], + CallDesc^.NamedArgCount + 1, @DispIDs); + if Result <> nil then VarClear(Result^); + DispatchInvoke(IDispatch(Dispatch), CallDesc, @DispIDs, @Params, Result); +end; + +{ Raise exception given an OLE return code and TExcepInfo structure } + +procedure DispCallError(Status: Integer; var ExcepInfo: TExcepInfo; + ErrorAddr: Pointer; FinalizeExcepInfo: Boolean); +var + E: Exception; +begin + if Status = Integer(DISP_E_EXCEPTION) then + begin + with ExcepInfo do + E := EOleException.Create(e_Com, bstrDescription {, scode, bstrSource, + bstrHelpFile, dwHelpContext } ); + if FinalizeExcepInfo then + Finalize(ExcepInfo); + end else + E := EOleSysError.Create(e_com, '' {, Status, 0}); + if ErrorAddr <> nil then + raise E at ErrorAddr + else + raise E; +end; + +{ Raise exception given an OLE return code and TExcepInfo structure } + +procedure DispatchInvokeError(Status: Integer; const ExcepInfo: TExcepInfo); +begin + DispCallError(Status, PExcepInfo(@ExcepInfo)^, nil, False); +end; + +procedure ClearExcepInfo(var ExcepInfo: TExcepInfo); +begin + FillChar(ExcepInfo, SizeOf(ExcepInfo), 0); +end; + +procedure DispCall(const Dispatch: IDispatch; CallDesc: PCallDesc; + DispID: Integer; NamedArgDispIDs, Params, Result: Pointer); stdcall; +type + TExcepInfoRec = record // mock type to avoid auto init and cleanup code + wCode: Word; + wReserved: Word; + bstrSource: PWideChar; + bstrDescription: PWideChar; + bstrHelpFile: PWideChar; + dwHelpContext: Longint; + pvReserved: Pointer; + pfnDeferredFillIn: Pointer; + scode: HResult; + end; +var + DispParams: TDispParams; + ExcepInfo: TExcepInfoRec; +asm + PUSH EBX + PUSH ESI + PUSH EDI + MOV EBX,CallDesc + XOR EDX,EDX + MOV EDI,ESP + MOVZX ECX,[EBX].TCallDesc.ArgCount + MOV DispParams.cArgs,ECX + TEST ECX,ECX + JE @@10 + ADD EBX,OFFSET TCallDesc.ArgTypes + MOV ESI,Params +@@1: MOVZX EAX,[EBX].Byte + TEST AL,atByRef + JNE @@3 + CMP AL,varVariant + JE @@2 + CMP AL,varDouble + JB @@4 + CMP AL,varDate + JA @@4 + PUSH [ESI].Integer[4] + PUSH [ESI].Integer[0] + PUSH EDX + PUSH EAX + ADD ESI,8 + JMP @@5 +@@2: PUSH [ESI].Integer[12] + PUSH [ESI].Integer[8] + PUSH [ESI].Integer[4] + PUSH [ESI].Integer[0] + ADD ESI,16 + JMP @@5 +@@3: AND AL,atTypeMask + OR EAX,varByRef +@@4: PUSH EDX + PUSH [ESI].Integer[0] + PUSH EDX + PUSH EAX + ADD ESI,4 +@@5: INC EBX + DEC ECX + JNE @@1 + MOV EBX,CallDesc +@@10: MOV DispParams.rgvarg,ESP + MOVZX EAX,[EBX].TCallDesc.NamedArgCount + MOV DispParams.cNamedArgs,EAX + TEST EAX,EAX + JE @@12 + MOV ESI,NamedArgDispIDs +@@11: PUSH [ESI].Integer[EAX*4-4] + DEC EAX + JNE @@11 +@@12: MOVZX ECX,[EBX].TCallDesc.CallType + CMP ECX,DISPATCH_PROPERTYPUT + JNE @@20 + PUSH DISPID_PROPERTYPUT + INC DispParams.cNamedArgs + CMP [EBX].TCallDesc.ArgTypes.Byte[0],varDispatch + JE @@13 + CMP [EBX].TCallDesc.ArgTypes.Byte[0],varUnknown + JNE @@20 +@@13: MOV ECX,DISPATCH_PROPERTYPUTREF +@@20: MOV DispParams.rgdispidNamedArgs,ESP + PUSH EDX { ArgErr } + LEA EAX,ExcepInfo + PUSH EAX { ExcepInfo } + PUSH ECX + PUSH EDX + CALL ClearExcepInfo + POP EDX + POP ECX + PUSH Result { VarResult } + LEA EAX,DispParams + PUSH EAX { Params } + PUSH ECX { Flags } + PUSH EDX { LocaleID } + PUSH OFFSET GUID_NULL { IID } + PUSH DispID { DispID } + MOV EAX,Dispatch + PUSH EAX + MOV EAX,[EAX] + CALL [EAX].Pointer[24] + TEST EAX,EAX + JE @@30 + LEA EDX,ExcepInfo + MOV CL, 1 + PUSH ECX + MOV ECX,[EBP+4] + JMP DispCallError +@@30: MOV ESP,EDI + POP EDI + POP ESI + POP EBX +end; + +procedure DispCallByID(Result: Pointer; const Dispatch: IDispatch; + DispDesc: PDispDesc; Params: Pointer); cdecl; +asm + PUSH EBX + MOV EBX,DispDesc + XOR EAX,EAX + PUSH EAX + PUSH EAX + PUSH EAX + PUSH EAX + MOV EAX,ESP + PUSH EAX + LEA EAX,Params + PUSH EAX + PUSH EAX + PUSH [EBX].TDispDesc.DispID + LEA EAX,[EBX].TDispDesc.CallDesc + PUSH EAX + PUSH Dispatch + CALL DispCall + MOVZX EAX,[EBX].TDispDesc.ResType + MOV EBX,Result + JMP @ResultTable.Pointer[EAX*4] + +@ResultTable: + DD @ResEmpty + DD @ResNull + DD @ResSmallint + DD @ResInteger + DD @ResSingle + DD @ResDouble + DD @ResCurrency + DD @ResDate + DD @ResString + DD @ResDispatch + DD @ResError + DD @ResBoolean + DD @ResVariant + DD @ResUnknown + DD @ResDecimal + DD @ResError + DD @ResByte + +@ResSingle: + FLD [ESP+8].Single + JMP @ResDone + +@ResDouble: +@ResDate: + FLD [ESP+8].Double + JMP @ResDone + +@ResCurrency: + FILD [ESP+8].Currency + JMP @ResDone + +@ResString: + MOV EAX,[EBX] + TEST EAX,EAX + JE @@1 + PUSH EAX + CALL SysFreeString +@@1: MOV EAX,[ESP+8] + MOV [EBX],EAX + JMP @ResDone + +@ResDispatch: +@ResUnknown: + MOV EAX,[EBX] + TEST EAX,EAX + JE @@2 + PUSH EAX + MOV EAX,[EAX] + CALL [EAX].Pointer[8] +@@2: MOV EAX,[ESP+8] + MOV [EBX],EAX + JMP @ResDone + +@ResVariant: + MOV EAX,EBX + CALL System.@VarClear + MOV EAX,[ESP] + MOV [EBX],EAX + MOV EAX,[ESP+4] + MOV [EBX+4],EAX + MOV EAX,[ESP+8] + MOV [EBX+8],EAX + MOV EAX,[ESP+12] + MOV [EBX+12],EAX + JMP @ResDone + +@ResSmallint: +@ResInteger: +@ResBoolean: +@ResByte: + MOV EAX,[ESP+8] + +@ResDecimal: +@ResEmpty: +@ResNull: +@ResError: +@ResDone: + ADD ESP,16 + POP EBX +end; + +var + ComClassManagerVar: TObject; + SaveInitProc: Pointer; + NeedToUninitialize: Boolean; + +function ComClassManager: TComClassManager; +begin + if ComClassManagerVar = nil then + ComClassManagerVar := TComClassManager.Create; + Result := TComClassManager(ComClassManagerVar); +end; + +procedure InitComObj; +begin + if SaveInitProc <> nil then TProcedure(SaveInitProc); + if (CoInitFlags <> -1) and Assigned(KOLComObj.CoInitializeEx) then + begin + NeedToUninitialize := Succeeded(KOLComObj.CoInitializeEx(nil, CoInitFlags)); + IsMultiThread := IsMultiThread or + ((CoInitFlags and COINIT_APARTMENTTHREADED) <> 0) or + (CoInitFlags = COINIT_MULTITHREADED); // this flag has value zero + end + else + NeedToUninitialize := Succeeded(CoInitialize(nil)); +end; + + +initialization +begin + LoadComExProcs; + VarDispProc := @VarDispInvoke; + DispCallByIDProc := @DispCallByID; + SafeCallErrorProc := @SafeCallError; + if not IsLibrary then + begin + SaveInitProc := InitProc; + InitProc := @InitComObj; + end; +end; + +finalization +begin + OleUninitializing := True; + ComClassManagerVar.Free; + SafeCallErrorProc := nil; + DispCallByIDProc := nil; + VarDispProc := nil; + if NeedToUninitialize then CoUninitialize; +end; + +end. -- cgit v1.2.3