NtUtils.Com.pas

unit NtUtils.Com;

{
  This module allows working with variant types and IDispatch without
  relying on System.Variant.
}

interface

uses
  Ntapi.WinNt, Ntapi.ObjBase, Ntapi.ObjIdl, Ntapi.winrt, DelphiApi.Reflection,
  Ntapi.Versions, NtUtils, DelphiUtils.AutoObjects;

const
  COINIT_APARTMENTTHREADED = Ntapi.ObjBase.COINIT_APARTMENTTHREADED;
  COINIT_MULTITHREADED = Ntapi.ObjBase.COINIT_MULTITHREADED;

type
  IRtlxComDll = interface (IPointer)
    function GetLoadName: String;
    property LoadName: String read GetLoadName;
    function CanUnloadNow: Boolean;

    // Call DllGetClassObject
    function GetClassObject(
      const Clsid: TClsid;
      const Iid: TIid;
      out pv;
      [opt] const ClassNameHint: String = ''
    ): TNtxStatus;

    // Call DllGetClassObject followed by IClassFactory::CreateInstance
    function CreateInstance(
      const Clsid: TClsid;
      const Iid: TIid;
      out pv;
      [opt] const ClassNameHint: String = ''
    ): TNtxStatus;

    // Call DllGetActivationFactory
    function GetActivationFactory(
      const ActivatableClassId: String;
      out Factory: IActivationFactory
    ): TNtxStatus;

    // Call DllGetActivationFactory followed by IActivationFactory::ActivateInstance
    function ActivateInstance(
      const ActivatableClassId: String;
      out Instance: IInspectable
    ): TNtxStatus;
  end;

  IHString = IPointer<THString>;

{ Manual COM / Manual WinRT }

// Manually load a COM-compatible DLL
function RtlxComLoadDll(
  const DllName: String;
  out Dll: IRtlxComDll
): TNtxStatus;

// Unload unused manually loaded COM DLLs
procedure RtlxComFreeUnusedLibraries;

// Manually create a COM class factory from a DLL
function RtlxComGetClassObject(
  const DllName: String;
  const Clsid: TClsid;
  const Iid: TIid;
  out pv;
  [opt] const ClassNameHint: String = ''
): TNtxStatus;

// Manually create a COM object from a DLL
function RtlxComCreateInstance(
  const DllName: String;
  const Clsid: TClsid;
  const Iid: TIid;
  out pv;
  [opt] const ClassNameHint: String = ''
): TNtxStatus;

// Manually create a WinRT activation factory from a DLL
function RtlxComGetActivationFactory(
  const DllName: String;
  const ActivatableClassId: String;
  out Factory: IActivationFactory
): TNtxStatus;

// Manually create a WinRT object from a DLL
function RtlxComActivateInstance(
  const DllName: String;
  const ActivatableClassId: String;
  out Instance: IInspectable
): TNtxStatus;

{ COM Init }

// Allow COM initialization to proceed without lpacCom capability
function ComxSuppressCapabilityCheck(
): TNtxStatus;

// Initialize COM on the current thread
[Result: ReleaseWith('ComxUninitialize')]
function ComxInitializeEx(
  PreferredMode: TCoInitMode = COINIT_APARTMENTTHREADED
): TNtxStatus;

// Uninitialize COM on the current thread
procedure ComxUninitialize;

// Initialize COM on the current thread and uninitialize it later
function ComxInitializeExAuto(
  out Uninitializer: IDeferredOperation;
  Mode: TCoInitMode
): TNtxStatus;

// Initialize COM on the current thread and uninitialize it on module unload
function ComxInitializeExOnce(
  Mode: TCoInitMode
): TNtxStatus;

// Determine the appartment type on the current thread
function ComxGetApartmentType(
  out ApartmentType: TAptType;
  out ApartmentQualifier: TAptTypeQualifier
): TNtxStatus;

// Check if COM has been initialized on the current thread
function ComxIsInitialized(
): Boolean;

// Locate MTA usage global variables in combase
function ComxGetMtaUsageGlobals(
  out Globals: PMtaUsageGlobals
): TNtxStatus;

// Initialize implicit MTA on the current thread if it has no apartment
[MinOSVersion(OsWin8)]
function ComxInitializeImplicit(
  [out, opt, ReleaseWith('ComxUninitializeImplicit')]
    Cookie: PCoMtaUsageCookie = nil
): TNtxStatus;

// Release a previous implicit MTA initialization
[MinOSVersion(OsWin8)]
function ComxUninitializeImplicit(
  Cookie: TCoMtaUsageCookie
): TNtxStatus;

// Initialize implicit MTA and release it later
[MinOSVersion(OsWin8)]
function ComxInitializeImplicitAuto(
  out Uninitializer: IDeferredOperation
): TNtxStatus;

// Initialize implicit MTA and release it on this module unload
[MinOSVersion(OsWin8)]
function ComxInitializeImplicitOnce(
): TNtxStatus;

// Make sure COM is initialized (with any apartment type) and add a reference
function ComxEnsureInitialized(
  out Uninitializer: IDeferredOperation
): TNtxStatus;

{ Base COM }

// Create a class factory from a CLSID
[RequiresCOM]
function ComxGetClassObject(
  const Clsid: TClsid;
  const Iid: TIid;
  out pv;
  [opt] const ClassNameHint: String = '';
  ClsContext: TClsCtx = CLSCTX_ALL
): TNtxStatus;

// Create a class factory via CoGetClassObject or fallback to manual COM use
function ComxGetClassObjectWithFallback(
  const DllName: String;
  const Clsid: TClsid;
  const Iid: TIid;
  out pv;
  [opt] const ClassNameHint: String = '';
  ClsContext: TClsCtx = CLSCTX_ALL
): TNtxStatus;

// Create a COM object from a CLSID
[RequiresCOM]
function ComxCreateInstance(
  const Clsid: TClsid;
  const Iid: TIid;
  out pv;
  [opt] const ClassNameHint: String = '';
  ClsContext: TClsCtx = CLSCTX_ALL
): TNtxStatus;

// Create an in-process COM object via CoCreateInstance or fall back to loading
// it directly without using COM facilities
function ComxCreateInstanceWithFallback(
  const DllName: String;
  const Clsid: TClsid;
  const Iid: TIid;
  out pv;
  [opt] const ClassNameHint: String = '';
  ClsContext: TClsCtx = CLSCTX_ALL
): TNtxStatus;

// Create a customizable COM activator
[RequiresCOM]
function ComxCreateCustomActivator(
  out Activator: IStandardActivator;
  out Properties: ISpecialSystemProperties
): TNtxStatus;

// Create a class factory for a CLSID in an elevated local server
[RequiresCOM]
function ComxGetClassObjectElevated(
  const Clsid: TClsid;
  const Iid: TIid;
  out pv;
  RunLevel: TRunLevel = RUNLEVEL_ADMIN;
  [opt] ParentWindow: THwnd = 0;
  [opt] const ClassNameHint: String = ''
): TNtxStatus;

// Create a COM object in an elevated local server
[RequiresCOM]
function ComxCreateInstanceElevated(
  const Clsid: TClsid;
  const Iid: TIid;
  out pv;
  RunLevel: TRunLevel = RUNLEVEL_ADMIN;
  [opt] ParentWindow: THwnd = 0;
  [opt] const ClassNameHint: String = ''
): TNtxStatus;

// Create a class factory for a CLSID in a specific session
[RequiresCOM]
function ComxGetClassObjectInSession(
  const Clsid: TClsid;
  const Iid: TIid;
  out pv;
  SessionId: TSessionId = 0;
  UseConsole: Boolean = True;
  RemoteThisSessionId: Boolean = True;
  [opt] const ClassNameHint: String = ''
): TNtxStatus;

// Create a COM object in a specific session
[RequiresCOM]
function ComxCreateInstanceInSession(
  const Clsid: TClsid;
  const Iid: TIid;
  out pv;
  SessionId: TSessionId = 0;
  UseConsole: Boolean = True;
  RemoteThisSessionId: Boolean = True;
  [opt] const ClassNameHint: String = ''
): TNtxStatus;

// Query default COM security
function ComxGetSecurity(
  ComSDType: TComSD;
  out SecDesc: ISecurityDescriptor
): TNtxStatus;

{ IMalloc }

// Free a buffer via CoTaskMemFree after use
function DeferCoTaskMemFree(
  [in] Buffer: Pointer
): IDeferredOperation;

{ Variants }

// Variant creation helpers
function VarEmpty: TVarData;
function VarFromWord(const Value: Word): TVarData;
function VarFromCardinal(const Value: Cardinal): TVarData;
function VarFromInteger(const Value: Integer): TVarData;
function VarFromIntegerRef(var Value: Integer): TVarData;
function VarFromWideString(const [ref] Value: WideString): TVarData;
function VarFromIDispatch(const Value: IDispatch): TVarData;

// Make a wide string or an empty non-nil wide string
function WideStringNonNil(const Source: String): WideString;

{ IDispatch helpers }

// Bind to a COM IDispatch object by name
function DispxBindToObject(
  const ObjectName: String;
  out Dispatch: IDispatch
): TNtxStatus;

// Lookup an ID of an IDispatch name
function DispxGetNameId(
  const Dispatch: IDispatch;
  const Name: String;
  out DispId: TDispID
): TNtxStatus;

// Invoke IDispatch
function DispxInvoke(
  const Dispatch: IDispatch;
  const DispId: TDispID;
  const Flags: Word;
  var Params: TDispParams;
  [out, opt] VarResult: Pointer
): TNtxStatus;

// Invoke IDispatch using a string name
function DispxInvokeByName(
  const Dispatch: IDispatch;
  const Name: String;
  const Flags: Word;
  var Params: TDispParams;
  [out, opt] VarResult: Pointer
): TNtxStatus;

// Retrieve a property via an IDispatch by ID
function DispxGetProperty(
  const Dispatch: IDispatch;
  const DispId: TDispID;
  out Value: TVarData
): TNtxStatus;

// Retrieve a property via an IDispatch by name
function DispxGetPropertyByName(
  const Dispatch: IDispatch;
  const Name: String;
  out Value: TVarData
): TNtxStatus;

// Assign a property via an IDispatch by ID
function DispxSetProperty(
  const Dispatch: IDispatch;
  const DispId: TDispID;
  const Value: TVarData
): TNtxStatus;

// Assign a property via an IDispatch by name
function DispxSetPropertyByName(
  const Dispatch: IDispatch;
  const Name: String;
  const Value: TVarData
): TNtxStatus;

// Call a method via IDispatch by ID
function DispxCallMethod(
  const Dispatch: IDispatch;
  const DispId: TDispID;
  [opt] const Parameters: TArray<TVarData> = nil;
  [out, opt] VarResult: PVarData = nil
): TNtxStatus;

// Call a method via IDispatch by name
function DispxCallMethodByName(
  const Dispatch: IDispatch;
  const Name: String;
  [opt] const Parameters: TArray<TVarData> = nil;
  [out, opt] VarResult: PVarData = nil
): TNtxStatus;

{ WinRT strings }

// Capture ownership of a WinRT string
[MinOSVersion(OsWin8)]
function RoxCaptureString(
  [in, opt] Buffer: THString
): IHString;

// Release a WinRT string later
function DeferWindowsDeleteString(
  [in] Buffer: THString
): IDeferredOperation;

// Create a WinRT string from a Delphi string
[MinOSVersion(OsWin8)]
function RoxCreateString(
  const Source: String;
  out Str: IHString
): TNtxStatus;

// Create a Delphi string from a WinRT string
[MinOSVersion(OsWin8)]
function RoxSaveString(
  [in, opt] Str: THString
): String;

{ WinRT }

// Uninitialize the Windows Runtime
[MinOSVersion(OsWin8)]
procedure RoxUninitialize;

// Initialize the Windows Runtime
[MinOSVersion(OsWin8)]
function RoxInitialize(
  InitType: TRoInitType = RO_INIT_MULTITHREADED
): TNtxStatus;

// Initialize the Windows Runtime and uninitialize it later
[MinOSVersion(OsWin8)]
function RoxInitializeAuto(
  out Uninitializer: IDeferredOperation;
  InitType: TRoInitType = RO_INIT_MULTITHREADED
): TNtxStatus;

// Initialize the Windows Runtime and uninitialize at this module finalization
[MinOSVersion(OsWin8)]
function RoxInitializeOnce(
  InitType: TRoInitType = RO_INIT_MULTITHREADED
): TNtxStatus;

// Create a WinRT activation factory
[RequiresWinRT]
[MinOSVersion(OsWin8)]
function RoxGetActivationFactory(
  const ActivatableClassId: String;
  out Factory: IActivationFactory
): TNtxStatus;

// Create a WinRT activation factory via RoGetActivationFactory or fallback
// to manual WinRT
[MinOSVersion(OsWin8)]
function RoxGetActivationFactoryWithFallback(
  const DllName: String;
  const ActivatableClassId: String;
  out Factory: IActivationFactory
): TNtxStatus;

// Activate a WinRT class
[RequiresWinRT]
[MinOSVersion(OsWin8)]
function RoxActivateInstance(
  const ActivatableClassId: String;
  out Inspectable: IInspectable
): TNtxStatus;

// Activate a WinRT class via RoActivateInstance or fallback
// to manual WinRT
[MinOSVersion(OsWin8)]
function RoxActivateInstanceWithFallback(
  const DllName: String;
  const ActivatableClassId: String;
  out Inspectable: IInspectable
): TNtxStatus;

{ ORPC Debug }

type
  [NamingStyle(nsCamelCase, 'dm')]
  TOrpcDebugMethod = (
    dmClientGetBufferSize,
    dmClientFillBuffer,
    dmClientNotify,
    dmServerNotify,
    dmServerGetBufferSize,
    dmServerFillBuffer
  );
  TOrpcDebugMethods = set of TOrpcDebugMethod;

  TOrpcDebugCallback = reference to procedure (
    Method: TOrpcDebugMethod;
    var OrpcDebugAll: TOrpcDbgAll
  );

const
  ORPC_DEBUG_ALL_METHODS = [dmClientGetBufferSize..dmServerFillBuffer];

// Lookup a name for an interface
function ComxLookupInterfaceName(
  const IID: TIID;
  out Name: String
): TNtxStatus;

// Lookup a name for an interface or format it as a GUID
function ComxFormatInterfaceName(
  const IID: TIID
): String;

// Subscribe an anonymous function to ORPC debug events
function ComxDebugOrpcMethods(
  out Registration: IAutoReleasable;
  Callback: TOrpcDebugCallback;
  Serialize: Boolean = True;
  Methods: TOrpcDebugMethods = ORPC_DEBUG_ALL_METHODS
): TNtxStatus;

implementation

uses
  Ntapi.WinError, Ntapi.ntdef, Ntapi.ntstatus, Ntapi.ntpebteb, Ntapi.ntregapi,
  NtUtils.Errors, NtUtils.Ldr, NtUtils.AntiHooking, NtUtils.Tokens,
  NtUtils.Tokens.Info, NtUtils.Synchronization, NtUtils.Registry,
  NtUtils.SysUtils, DelphiUtils.Arrays;

{$BOOLEVAL OFF}
{$IFOPT R+}{$DEFINE R+}{$ENDIF}
{$IFOPT Q+}{$DEFINE Q+}{$ENDIF}

type
  TRtlxComDll = class (TCustomAutoPointer, IRtlxComDll)
  protected
    FName: String;
    FDllCanUnloadNow: TDllCanUnloadNow;
    FDllGetClassObject: TDllGetClassObject;
    FDllGetActivationFactory: TDllGetActivationFactory;
    destructor Destroy; override;
    constructor Create(
      const Name: String;
      DllBase: Pointer;
      ADllCanUnloadNow: TDllCanUnloadNow;
      ADllGetClassObject: TDllGetClassObject;
      ADllGetActivationFactory: TDllGetActivationFactory
    );
  public
    class var StorageLock: TRtlSRWLock;
    class var Storage: TArray<IRtlxComDll>;
  public
    function GetLoadName: String;
    function CanUnloadNow: Boolean;
    function GetClassObject(
      const clsid: TClsid;
      const Iid: TIID;
      out pv;
      const ClassNameHint: String
    ): TNtxStatus;
    function CreateInstance(
      const Clsid: TClsid;
      const Iid: TIid;
      out pv;
      const ClassNameHint: String
    ): TNtxStatus;
    function GetActivationFactory(
      const ActivatableClassId: String;
      out factory: IActivationFactory
    ): TNtxStatus;
    function ActivateInstance(
      const ActivatableClassId: String;
      out Instance: IInspectable
    ): TNtxStatus;
  end;

{ TRtlxComDll }

function TRtlxComDll.ActivateInstance;
var
  Factory: IActivationFactory;
begin
  Result := GetActivationFactory(ActivatableClassId, Factory);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'IActivationFactory::ActivateInstance';
  Result.LastCall.Parameter := ActivatableClassId;
  Result.HResult := Factory.ActivateInstance(Instance);
end;

function TRtlxComDll.CanUnloadNow;
begin
  // If there is no DllCanUnloadNow, allow unloading only if there are no
  // other COM exports
  if not Assigned(FDllCanUnloadNow) and not Assigned(FDllGetClassObject) and
    not Assigned(FDllGetActivationFactory) then
    Exit(True);

  try
    Result := (FDllCanUnloadNow = S_OK);
  except
    // If the DLL throws an exception in the callback, don't touch it; it
    // doesn't like manual COM
    Result := False;
  end;
end;

constructor TRtlxComDll.Create;
begin
  inherited Capture(DllBase);
  FName := Name;
  FDllCanUnloadNow := ADllCanUnloadNow;
  FDllGetClassObject := ADllGetClassObject;
  FDllGetActivationFactory := ADllGetActivationFactory;
end;

function TRtlxComDll.CreateInstance;
var
  Factory: IClassFactory;
begin
  Result := GetClassObject(Clsid, IClassFactory, Factory, ClassNameHint);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'IClassFactory::CreateInstance';
  Result.LastCall.Parameter := ClassNameHint;
  Result.HResult := Factory.CreateInstance(nil, Iid, pv);
end;

destructor TRtlxComDll.Destroy;
begin
  // Allow the DLL to prevent its unloading. Note that we are supposed to reach
  // this code when either the DLL is okay with being unloaded or it's the last
  // call (i.e., this module unload) since the storage should always keep the
  // last reference to the object.
  if Assigned(FData) and not FDiscardOwnership and CanUnloadNow then
    LdrxUnloadDll(FData);

  FData := nil;
  inherited;
end;

function TRtlxComDll.GetActivationFactory;
var
  ActivatableClassIdStr: IHString;
begin
  if not Assigned(FDllGetActivationFactory) then
  begin
    Result.Location := 'LdrGetProcedureAddress';
    Result.LastCall.Parameter := RtlxExtractNamePath(FName) +
      '!DllGetActivationFactory';
    Result.Status := STATUS_ENTRYPOINT_NOT_FOUND;
    Exit;
  end;

  Result := RoxCreateString(ActivatableClassId, ActivatableClassIdStr);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'DllGetActivationFactory';
  Result.LastCall.Parameter := ActivatableClassId;
  Result.HResult := FDllGetActivationFactory(ActivatableClassIdStr.Data,
    factory);
end;

function TRtlxComDll.GetClassObject;
begin
  if not Assigned(FDllGetClassObject) then
  begin
    Result.Location := 'LdrGetProcedureAddress';
    Result.LastCall.Parameter := RtlxExtractNamePath(FName) +
      '!DllGetClassObject';
    Result.Status := STATUS_ENTRYPOINT_NOT_FOUND;
    Exit;
  end;

  Result.Location := 'DllGetClassObject';
  Result.LastCall.Parameter := ClassNameHint;
  Result.HResult := FDllGetClassObject(clsid, Iid, pv);
end;

function TRtlxComDll.GetLoadName;
begin
  Result := FName;
end;

{ Manual COM }

function RtlxComLoadDll;
var
  Lock: IAutoReleasable;
  Index: Integer;
  Module: IPointer;
  ADllCanUnloadNow, ADllGetClassObject, ADllGetActivationFactory: Pointer;
begin
  // Synchronize access to the storage
  Lock := RtlxAcquireSRWLockExclusive(@TRtlxComDll.StorageLock);

  // Check if we already have en entry for the DLL
  Index := TArray.BinarySearchEx<IRtlxComDll>(TRtlxComDll.Storage,
    function (const Entry: IRtlxComDll): Integer
    begin
      Result := RtlxCompareStrings(Entry.LoadName, DllName);
    end
  );

  if Index >= 0 then
  begin
    // Found an existing entry
    Dll := TRtlxComDll.Storage[Index];
    Result := NtxSuccess;
    Exit;
  end;

  // Load the DLL
  Result := LdrxLoadDllAuto(DllName, Module);

  if not Result.IsSuccess then
    Exit;

  // Locate the unload checker export
  if not LdrxGetProcedureAddress(Module.Data, 'DllCanUnloadNow',
    ADllCanUnloadNow).IsSuccess then
    ADllCanUnloadNow := nil;

  // Locate the class factory export
  if not LdrxGetProcedureAddress(Module.Data, 'DllGetClassObject',
    ADllGetClassObject).IsSuccess then
    ADllGetClassObject := nil;

  // Locate the activation factory export
  if not LdrxGetProcedureAddress(Module.Data, 'DllGetActivationFactory',
    ADllGetActivationFactory).IsSuccess then
    ADllGetActivationFactory := nil;

  // Transfer DLL ownership to the wrapper
  Dll := TRtlxComDll.Create(DllName, Module.Data, ADllCanUnloadNow,
    ADllGetClassObject, ADllGetActivationFactory);
  Module.DiscardOwnership;

  // Register it in the storage
  Insert(Dll, TRtlxComDll.Storage, -(Index + 1));
end;

procedure RtlxComFreeUnusedLibraries;
var
  Lock: IAutoReleasable;
  i, Count: Integer;
  WeakRef: Weak<IRtlxComDll>;
begin
  // Synchronize access to the storage
  Lock := RtlxAcquireSRWLockExclusive(@TRtlxComDll.StorageLock);

  Count := 0;
  for i := 0 to High(TRtlxComDll.Storage) do
    if TRtlxComDll.Storage[i].CanUnloadNow then
    begin
      // The DLL reports that it's not in use.
      // Capture a weak reference and release the strong one
      WeakRef := TRtlxComDll.Storage[i];
      TRtlxComDll.Storage[i] := nil;

      // If we can upgrade the weak reference back, there are other strong
      // references, so we keep the object
      if WeakRef.Upgrade(TRtlxComDll.Storage[i]) then
        Inc(Count);
    end
    else
    begin
      // The DLL is not ready to unload; keep the object
      Inc(Count);
    end;

  // Truncate if necessary
  if Length(TRtlxComDll.Storage) <> Count then
    SetLength(TRtlxComDll.Storage, Count);
end;

function RtlxComGetClassObject;
var
  Dll: IRtlxComDll;
begin
  Result := RtlxComLoadDll(DllName, Dll);

  if not Result.IsSuccess then
    Exit;

  Result := Dll.GetClassObject(Clsid, Iid, pv, ClassNameHint);
end;

function RtlxComCreateInstance;
var
  Dll: IRtlxComDll;
begin
  Result := RtlxComLoadDll(DllName, Dll);

  if not Result.IsSuccess then
    Exit;

  Result := Dll.CreateInstance(Clsid, Iid, pv, ClassNameHint);
end;

function RtlxComGetActivationFactory;
var
  Dll: IRtlxComDll;
begin
  Result := RtlxComLoadDll(DllName, Dll);

  if not Result.IsSuccess then
    Exit;

  Result := Dll.GetActivationFactory(ActivatableClassId, Factory);
end;

function RtlxComActivateInstance;
var
  Dll: IRtlxComDll;
begin
  Result := RtlxComLoadDll(DllName, Dll);

  if not Result.IsSuccess then
    Exit;

  Result := Dll.ActivateInstance(ActivatableClassId, Instance);
end;

{ Base COM }

var
  // We want to undo hooking on module unload
  CapabilitySuppressionInitialized: TRtlRunOnce;
  CapabilitySuppressionReverter: IDeferredOperation;

function ComxpConfirmCapability(
  [in, opt] TokenHandle: THandle;
  [in] CapabilitySidToCheck: PSid;
  [out] out HasCapability: Boolean
): NTSTATUS; stdcall;
begin
  try
    HasCapability := True;
    Result := STATUS_SUCCESS;
  except
    Result := STATUS_ACCESS_VIOLATION;
  end;
end;

function ComxSuppressCapabilityCheck;
var
  Init: IAcquiredRunOnce;
  IsLpac: Boolean;
begin
  // Already called?
  if not RtlxRunOnceBegin(@CapabilitySuppressionInitialized, Init) then
    Exit(NtxSuccess);

  // No capability checks before RS2
  if not RtlOsVersionAtLeast(OsWin10RS2) then
  begin
    Init.Complete;
    Exit(NtxSuccess);
  end;

  // No capability checks for non-LPAC tokens
  if NtxQueryLpacToken(NtxCurrentProcessToken, IsLpac).IsSuccess and
    not IsLpac then
  begin
    Init.Complete;
    Exit(NtxSuccess);
  end;

  // Redirect the capability checking function
  Result := RtlxInstallIATHook(CapabilitySuppressionReverter, combase, ntdll,
    'RtlCheckTokenCapability', @ComxpConfirmCapability);

  if Result.IsSuccess then
    Init.Complete;
end;

function ComxInitializeEx;
begin
  // S_FALSE indicates that COM is already initialized; RPC_E_CHANGED_MODE means
  // that someone already initialized COM using a different mode.
  Result.Location := 'CoInitializeEx';
  Result.HResultAllowFalse := CoInitializeEx(nil, PreferredMode);
end;

procedure ComxUninitialize;
begin
  CoUninitialize;
end;

function ComxInitializeExAuto;
var
  CallingThread: TThreadId;
begin
  Result := ComxInitializeEx(Mode);

  if not Result.IsSuccess then
    Exit;

  // Record the calling thread since COM init is thread-specific
  CallingThread := NtCurrentTeb.ClientID.UniqueThread;

  Uninitializer := Auto.Defer(
    procedure
    begin
      // Make sure uninitialization runs on the same thread
      if CallingThread = NtCurrentTeb.ClientID.UniqueThread then
        ComxUninitialize;
    end
  );
end;

var
  ComUninitializerMode: TCoInitMode;
  ComUninitializer: IDeferredOperation;

function ComxInitializeExOnce;
begin
  if NtCurrentTeb.ClientID.UniqueThread <> MainThreadID then
  begin
    // Only allow this function to be called on the main thread.
    // Otherwise, uninitializing on module unload becomes a problem
    Result.Location := 'ComxInitializeExOnce';
    Result.HResult := RPC_E_WRONG_THREAD;
    Exit;
  end;

  if Assigned(ComUninitializer) then
  begin
    if ComUninitializerMode and COINIT_APARTMENTTHREADED <>
      Mode and COINIT_APARTMENTTHREADED then
    begin
      // Already called with an incompatible mode
      Result.Location := 'ComxInitializeExOnce';
      Result.HResult := RPC_E_CHANGED_MODE;
    end
    else
      Result := NtxSuccess;

    if not Result.IsSuccess then
      Exit;
  end;

  Result := ComxInitializeExAuto(ComUninitializer, Mode);

  if not Result.IsSuccess then
    Exit;

  ComUninitializerMode := Mode;
end;

function ComxGetApartmentType;
begin
  Result.Location := 'CoGetApartmentType';
  Result.HResult := CoGetApartmentType(ApartmentType, ApartmentQualifier);
end;

function ComxIsInitialized;
var
  ApartmentType: TAptType;
  ApartmentQualifier: TAptTypeQualifier;
begin
  Result := ComxGetApartmentType(ApartmentType, ApartmentQualifier).IsSuccess;
end;

var
  // MTA globals are constant
  MtaGlobalsInitialized: TRtlRunOnce;
  MtaGlobalsBuffer: PMtaUsageGlobals;

function ComxGetMtaUsageGlobals;
var
  Init: IAcquiredRunOnce;
begin
  Result := LdrxCheckDelayedImport(delayed_CoGetMTAUsageInfo);

  if not Result.IsSuccess then
    Exit;

  if not RtlxRunOnceBegin(@MtaGlobalsInitialized, Init) then
  begin
    Globals := MtaGlobalsBuffer;
    Exit(NtxSuccess);
  end;

  // Query and save
  MtaGlobalsBuffer := CoGetMTAUsageInfo;
  Globals := MtaGlobalsBuffer;

  if not Assigned(MtaGlobalsBuffer) then
  begin
    Result.Location := 'ComxGetMtaUsageGlobals';
    Result.Status := STATUS_NO_MEMORY;
    Exit;
  end;

  Init.Complete;
end;

function ComxInitializeImplicit;
var
  CookieValue: TCoMtaUsageCookie;
begin
  Result := LdrxCheckDelayedImport(delayed_CoIncrementMTAUsage);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'CoIncrementMTAUsage';
  Result.HResult := CoIncrementMTAUsage(CookieValue);

  if Result.IsSuccess and Assigned(Cookie) then
    Cookie^ := CookieValue;
end;

function ComxUninitializeImplicit;
begin
  Result := LdrxCheckDelayedImport(delayed_CoDecrementMTAUsage);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'CoDecrementMTAUsage';
  Result.HResult := CoDecrementMTAUsage(Cookie);
end;

function ComxInitializeImplicitAuto;
var
  Cookie: TCoMtaUsageCookie;
begin
  Result := ComxInitializeImplicit(@Cookie);

  if Result.IsSuccess then
    Uninitializer := Auto.Defer(
      procedure
      begin
        ComxUninitializeImplicit(Cookie);
      end
    );
end;

var
  // We want to release implicit MTA reference on module unload
  ImplicitMTAInitialized: TRtlRunOnce;
  ImplicitMTAUninitializer: IDeferredOperation;

function ComxInitializeImplicitOnce;
var
  Init: IAcquiredRunOnce;
begin
  // Already called?
  if not RtlxRunOnceBegin(@ImplicitMTAInitialized, Init) then
    Exit(NtxSuccess);

  // Initialize
  Result := ComxInitializeImplicitAuto(ImplicitMTAUninitializer);

  if Result.IsSuccess then
    Init.Complete;
end;

function ComxEnsureInitialized;
var
  ApartmentType: TAptType;
  ApartmentQualifier: TAptTypeQualifier;
  PreferredMode: TCoInitMode;
begin
  // Prefer an implicit MTA reference which is compatible with existing/future
  // aparatments
  Result := ComxInitializeImplicitAuto(Uninitializer);

  if Result.IsSuccess then
    Exit;

  // Determine if we are already in an apartment
  Result := ComxGetApartmentType(ApartmentType, ApartmentQualifier);

  // Choose the mode to align with the existing one or fallback to MTA
  PreferredMode := COINIT_MULTITHREADED;

  if Result.IsSuccess then
    case ApartmentType of
      APTTYPE_MAINSTA, APTTYPE_STA:
        PreferredMode := COINIT_APARTMENTTHREADED;

      APTTYPE_MTA:
        PreferredMode := COINIT_MULTITHREADED;

      APTTYPE_NA:
        case ApartmentQualifier of
          APTTYPEQUALIFIER_NA_ON_MAINSTA, APTTYPEQUALIFIER_NA_ON_STA,
          APTTYPEQUALIFIER_APPLICATION_STA:
            PreferredMode := COINIT_APARTMENTTHREADED;

          APTTYPEQUALIFIER_NA_ON_MTA, APTTYPEQUALIFIER_NA_ON_IMPLICIT_MTA:
            PreferredMode := COINIT_MULTITHREADED;
        end;
    end;

  // Use a regular initialization reference
  Result := ComxInitializeExAuto(Uninitializer, PreferredMode);
end;

{ Base COM }

function ComxGetClassObject;
begin
  Result.Location := 'CoGetClassObject';
  Result.LastCall.Parameter := ClassNameHint;
  Result.HResult := CoGetClassObject(Clsid, ClsContext, nil, Iid, pv);
end;

function ComxGetClassObjectWithFallback;
begin
  Result := ComxGetClassObject(Clsid, Iid, pv, ClassNameHint, ClsContext);

  if not Result.IsSuccess then
    Result := RtlxComGetClassObject(DllName, Clsid, Iid, pv, ClassNameHint);
end;

function ComxCreateInstance;
begin
  Result.Location := 'CoCreateInstance';
  Result.LastCall.Parameter := ClassNameHint;
  Result.HResult := CoCreateInstance(clsid, nil, ClsContext, Iid, pv);
end;

function ComxCreateInstanceWithFallback;
begin
  Result := ComxCreateInstance(Clsid, Iid, pv, ClassNameHint, ClsContext);

  if not Result.IsSuccess then
    Result := RtlxComCreateInstance(DllName, Clsid, Iid, pv, ClassNameHint);
end;

function ComxCreateCustomActivator;
begin
  Result := ComxCreateInstance(CLSID_ComActivator, IStandardActivator,
    Activator, 'CLSID_ComActivator', CLSCTX_INPROC_SERVER);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'IStandardActivator::QueryInterface';
  Result.LastCall.Parameter := 'ISpecialSystemProperties';
  Result.HResult := Activator.QueryInterface(ISpecialSystemProperties,
    Properties);
end;

function ComxGetClassObjectElevated;
var
  Activator: IStandardActivator;
  Properties: ISpecialSystemProperties;
begin
  Result := ComxCreateCustomActivator(Activator, Properties);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'ISpecialSystemProperties::SetLUARunLevel';
  Result.HResult := Properties.SetLUARunLevel(RunLevel, ParentWindow);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'IStandardActivator::StandardGetClassObject';
  Result.LastCall.Parameter := ClassNameHint;
  Result.HResult := Activator.StandardGetClassObject(Clsid, CLSCTX_LOCAL_SERVER,
    nil, Iid, pv);
end;

function ComxCreateInstanceElevated;
var
  Factory: IClassFactory;
begin
  Result := ComxGetClassObjectElevated(Clsid, IClassFactory, Factory, RunLevel,
    ParentWindow, ClassNameHint);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'IClassFactory::CreateInstance';
  Result.LastCall.Parameter := ClassNameHint;
  Result.HResult := Factory.CreateInstance(nil, Iid, pv);
end;

function ComxGetClassObjectInSession;
var
  Activator: IStandardActivator;
  Properties: ISpecialSystemProperties;
begin
  Result := ComxCreateCustomActivator(Activator, Properties);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'ISpecialSystemProperties::SetSessionId';
  Result.HResult := Properties.SetSessionId(SessionId, UseConsole,
    RemoteThisSessionId);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'IStandardActivator::StandardGetClassObject';
  Result.LastCall.Parameter := ClassNameHint;
  Result.HResult := Activator.StandardGetClassObject(Clsid, CLSCTX_LOCAL_SERVER,
    nil, Iid, pv);
end;

function ComxCreateInstanceInSession;
var
  Factory: IClassFactory;
begin
  Result := ComxGetClassObjectInSession(Clsid, IClassFactory, Factory,
    SessionId, UseConsole, RemoteThisSessionId, ClassNameHint);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'IClassFactory::CreateInstance';
  Result.LastCall.Parameter := ClassNameHint;
  Result.HResult := Factory.CreateInstance(nil, Iid, pv);
end;

function ComxGetSecurity;
var
  Buffer: PSecurityDescriptor;
begin
  Result.Location := 'CoGetSystemSecurityPermissions';
  Result.HResult := CoGetSystemSecurityPermissions(ComSDType, Buffer);

  if Result.IsSuccess then
    IPointer(SecDesc) := CaptureLocalFreePointer(Buffer);
end;

{ IMalloc }

function DeferCoTaskMemFree;
begin
  Result := Auto.Defer(
    procedure
    begin
      CoTaskMemFree(Buffer);
    end
  );
end;

{ Variant helpers }

function VarEmpty;
begin
  VariantInit(Result);
end;

function VarFromWord;
begin
  VariantInit(Result);
  Result.VType := varWord;
  Result.VWord := Value;
end;

function VarFromCardinal;
begin
  VariantInit(Result);
{$IF CompilerVersion >= 32}
  Result.VType := varUInt32;
  Result.VUInt32 := Value;
{$ELSE}
  Result.VType := varLongWord;
  Result.VLongWord := Value;
{$ENDIF}
end;

function VarFromInteger;
begin
  VariantInit(Result);
  Result.VType := varInteger;
  Result.VInteger := Value;
end;

function VarFromIntegerRef;
begin
  VariantInit(Result);
  Result.VType := varInteger or varByRef;
  Result.VPointer := @Value;
end;

function VarFromWideString;
begin
  VariantInit(Result);
  if Value <> '' then
  begin
    Result.VType := varOleStr;
    Result.VOleStr := PWideChar(Value);
  end;
end;

function VarFromIDispatch;
begin
  VariantInit(Result);
  Result.VType := varDispatch;
  Result.VDispatch := Pointer(Value);
end;

function WideStringNonNil;
var
  ResultRaw: Pointer absolute Result;
begin
  if Length(Source) > 0 then
    Result := WideString(Source)
  else
    ResultRaw := SysAllocStringLen('', 0);
end;

{ Binding helpers }

function DispxBindToObject;
var
  BindCtx: IBindCtx;
  Moniker: IMoniker;
  chEaten: Cardinal;
begin
  Result.Location := 'CreateBindCtx';
  Result.HResult := CreateBindCtx(0, BindCtx);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'MkParseDisplayName';
  Result.LastCall.Parameter := ObjectName;
  Result.HResult := MkParseDisplayName(BindCtx, PWideChar(ObjectName), chEaten,
    Moniker);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'IMoniker::BindToObject';
  Result.LastCall.Parameter := ObjectName;
  Result.HResult := Moniker.BindToObject(BindCtx, nil, IDispatch, Dispatch);
end;

{ IDispatch invocation helpers }

function DispxGetNameId;
var
  NameArray: array [0..0] of PWideChar;
begin
  NameArray[0] := PWideChar(Name);

  Result.Location := 'IDispatch::GetIDsOfNames';
  Result.LastCall.Parameter := Name;
  Result.HResult := Dispatch.GetIDsOfNames(GUID_NULL, @NameArray, 1, 0, @DispID);
end;

function DispxInvoke;
var
  ExceptInfo: TExcepInfo;
  ArgErr: Cardinal;
begin
  Result.Location := 'IDispatch::Invoke';
  Result.HResult := Dispatch.Invoke(DispID, GUID_NULL, 0, Flags, Params,
    VarResult, @ExceptInfo, @ArgErr);

  if Result.HResult = DISP_E_EXCEPTION then
  begin
    // Execute deferred exception fill-in if necessary
    if not Assigned(ExceptInfo.pfnDeferredFillIn) or
      ExceptInfo.pfnDeferredFillIn(@ExceptInfo).IsSuccess then
      Result.LastCall.Parameter := ExceptInfo.bstrSource;

    // Prefer more specific error codes
    if not ExceptInfo.scode.IsSuccess then
      Result.HResult := ExceptInfo.scode
    else if ExceptInfo.wCode <> ERROR_SUCCESS then
      Result.Win32Error := ExceptInfo.wCode;
  end;
end;

function DispxInvokeByName;
var
  DispID: TDispID;
begin
  Result := DispxGetNameId(Dispatch, Name, DispID);

  if not Result.IsSuccess then
    Exit;

  Result := DispxInvoke(Dispatch, DispID, Flags, Params, VarResult);

  if Result.HResult <> DISP_E_EXCEPTION then
    Result.LastCall.Parameter := Name;
end;

function DispxGetProperty;
var
  Params: TDispParams;
begin
  Params := Default(TDispParams);
  VariantInit(Value);

  Result := DispxInvoke(Dispatch, DispId, DISPATCH_METHOD or
    DISPATCH_PROPERTYGET, Params, @Value);
end;

function DispxGetPropertyByName;
var
  Params: TDispParams;
begin
  Params := Default(TDispParams);
  VariantInit(Value);

  Result := DispxInvokeByName(Dispatch, Name, DISPATCH_METHOD or
    DISPATCH_PROPERTYGET, Params, @Value);
end;

function DispxSetProperty;
var
  Action: TDispID;
  Params: TDispParams;
begin
  Action := DISPID_PROPERTYPUT;

  // Prepare the parameters
  Params.rgvarg := Pointer(@Value);
  Params.rgdispidNamedArgs := Pointer(@Action);
  Params.cArgs := 1;
  Params.cNamedArgs := 1;

  Result := DispxInvoke(Dispatch, DispId, DISPATCH_PROPERTYPUT, Params, nil);
end;

function DispxSetPropertyByName;
var
  Action: TDispID;
  Params: TDispParams;
begin
  Action := DISPID_PROPERTYPUT;

  // Prepare the parameters
  Params.rgvarg := Pointer(@Value);
  Params.rgdispidNamedArgs := Pointer(@Action);
  Params.cArgs := 1;
  Params.cNamedArgs := 1;

  Result := DispxInvokeByName(Dispatch, Name, DISPATCH_PROPERTYPUT, Params, nil);
end;

function DispxCallMethod;
var
  Params: TDispParams;
begin
  // IDispatch expects method parameters to go from right to left
  Params.cArgs := Length(Parameters);
  Params.rgvarg := Pointer(TArray.Reverse<TVarData>(Parameters));
  Params.cNamedArgs := 0;
  Params.rgdispidNamedArgs := nil;

  if Assigned(VarResult) then
    VariantInit(VarResult^);

  Result := DispxInvoke(Dispatch, DispId, DISPATCH_METHOD, Params, VarResult);
end;

function DispxCallMethodByName;
var
  Params: TDispParams;
begin
  // IDispatch expects method parameters to go from right to left
  Params.cArgs := Length(Parameters);
  Params.rgvarg := Pointer(TArray.Reverse<TVarData>(Parameters));
  Params.cNamedArgs := 0;
  Params.rgdispidNamedArgs := nil;

  if Assigned(VarResult) then
    VariantInit(VarResult^);

  Result := DispxInvokeByName(Dispatch, Name, DISPATCH_METHOD, Params,
    VarResult);
end;

{ WinRT strings }

type
  TRoxAutoString = class (TCustomAutoPointer)
    destructor Destroy; override;
  end;

destructor TRoxAutoString.Destroy;
begin
  if Assigned(FData) and not FDiscardOwnership and LdrxCheckDelayedImport(
    delayed_WindowsDeleteString).IsSuccess then
    WindowsDeleteString(FData);

  inherited;
end;

function RoxCaptureString;
begin
  IPointer(Result) := TRoxAutoString.Capture(Buffer);
end;

function DeferWindowsDeleteString;
begin
  Result := Auto.Defer(
    procedure
    begin
      if LdrxCheckDelayedImport(delayed_WindowsDeleteString).IsSuccess then
        WindowsDeleteString(Buffer);
    end
  );
end;

function RoxCreateString;
var
  Buffer: THString;
begin
  Result := LdrxCheckDelayedImport(delayed_WindowsCreateString);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'WindowsCreateString';
  Result.HResult := WindowsCreateString(PWideChar(Source),
    Length(Source), Buffer);

  if Result.IsSuccess then
    Str := RoxCaptureString(Buffer);
end;

function RoxSaveString;
var
  SourceLength: Cardinal;
begin
  if not LdrxCheckDelayedImport(delayed_WindowsGetStringRawBuffer).IsSuccess then
    Exit('');

  SetString(Result, WindowsGetStringRawBuffer(Str, @SourceLength),
    Integer(SourceLength));
end;

{ WinRT }

procedure RoxUninitialize;
begin
  if LdrxCheckDelayedImport(delayed_RoUninitialize).IsSuccess then
    RoUninitialize;
end;

function RoxInitialize;
begin
  Result := LdrxCheckDelayedImport(delayed_RoInitialize);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'RoInitialize';
  Result.HResultAllowFalse := RoInitialize(InitType);

  // S_FALSE indicates that COM is already initialized; RPC_E_CHANGED_MODE means
  // that someone already initialized COM using a different mode. Use it, since
  // we still need to add a reference.

  if Result.HResult = RPC_E_CHANGED_MODE then
    Result.HResultAllowFalse := RoInitialize(TRoInitType(Cardinal(InitType) xor
      Cardinal(RO_INIT_MULTITHREADED)));
end;

function RoxInitializeAuto;
var
  CallingThread: TThreadId;
begin
  Result := RoxInitialize(InitType);

  if not Result.IsSuccess then
    Exit;

  // Record the calling thread since WinRT init is thread-specific
  CallingThread := NtCurrentTeb.ClientID.UniqueThread;

  Uninitializer := Auto.Defer(
    procedure
    begin
      // Make sure uninitialization runs on the same thread
      if CallingThread = NtCurrentTeb.ClientID.UniqueThread then
        RoxUninitialize;
    end
  );
end;

var
  // We want to release the reference on module unload
  RoxpInitialized: TRtlRunOnce;
  RoxpUninitializer: IDeferredOperation;

function RoxInitializeOnce;
var
  Init: IAcquiredRunOnce;
begin
  if not RtlxRunOnceBegin(@RoxpInitialized, Init) then
    Exit(NtxSuccess);

  Result := RoxInitializeAuto(RoxpUninitializer);

  if Result.IsSuccess then
    Init.Complete;
end;

function RoxGetActivationFactory;
var
  ActivatableClassIdStr: IHString;
begin
  Result := LdrxCheckDelayedImport(delayed_RoGetActivationFactory);

  if not Result.IsSuccess then
    Exit;

  Result := RoxCreateString(ActivatableClassId, ActivatableClassIdStr);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'RoGetActivationFactory';
  Result.HResult := RoGetActivationFactory(ActivatableClassIdStr.Data,
    IActivationFactory, Factory);
end;

function RoxGetActivationFactoryWithFallback;
begin
  Result := RoxGetActivationFactory(ActivatableClassId, Factory);

  if not Result.IsSuccess then
    Result := RtlxComGetActivationFactory(DllName, ActivatableClassId, Factory);
end;

function RoxActivateInstance;
var
  ClassIdString: IHString;
begin
  Result := LdrxCheckDelayedImport(delayed_RoActivateInstance);

  if not Result.IsSuccess then
    Exit;

  Result := RoxCreateString(ActivatableClassId, ClassIdString);

  if not Result.IsSuccess then
    Exit;

  Result.Location := 'RoActivateInstance';
  Result.LastCall.Parameter := ActivatableClassId;
  Result.HResult := RoActivateInstance(ClassIdString.Data, Inspectable);
end;

function RoxActivateInstanceWithFallback;
begin
  Result := RoxActivateInstance(ActivatableClassId, Inspectable);

  if not Result.IsSuccess then
    Result := RtlxComActivateInstance(DllName, ActivatableClassId, Inspectable);
end;

{ ORPC Debug }

function ComxLookupInterfaceName;
var
  hxKey: IHandle;
begin
  Result := NtxOpenKey(hxKey, REG_PATH_MACHINE + '\SOFTWARE\Classes\Interface\'
    + RtlxGuidToString(IID), KEY_QUERY_VALUE);

  if not Result.IsSuccess then
    Exit;

  Result := NtxQueryValueKeyString(hxKey, '', Name);
end;

function ComxFormatInterfaceName;
begin
  if not ComxLookupInterfaceName(IID, Result).IsSuccess then
    Result := RtlxGuidToString(IID);
end;

type
  IOrpcDebugInternal = interface (IAutoReleasable)
    ['{A3E2F55F-0E36-46D7-B86A-B66E9C96BA25}']
    procedure NotifyRegistered;
    function AsInitArgs: POrpcInitArgs;
  end;

  TOrpcDebug = class (TAutoInterfacedObject, IOrpcDebugNotify,
    IOrpcDebugInternal, IAutoReleasable)
    FArgs: TOrpcInitArgs;
    FCallback: TOrpcDebugCallback;
    FMethods: TOrpcDebugMethods;
    FLock: TRtlSRWLock;
    FSerialize: Boolean;
    FRegistered: Boolean;
    procedure InvokeCallback(Method: TOrpcDebugMethod; var OrpcDebugAll: TOrpcDbgAll);
    procedure ClientGetBufferSize(var OrpcDebugAll: TOrpcDbgAll); stdcall;
    procedure ClientFillBuffer(var OrpcDebugAll: TOrpcDbgAll); stdcall;
    procedure ClientNotify(var OrpcDebugAll: TOrpcDbgAll); stdcall;
    procedure ServerNotify(var OrpcDebugAll: TOrpcDbgAll); stdcall;
    procedure ServerGetBufferSize(var OrpcDebugAll: TOrpcDbgAll); stdcall;
    procedure ServerFillBuffer(var OrpcDebugAll: TOrpcDbgAll); stdcall;
    procedure NotifyRegistered;
    function AsInitArgs: POrpcInitArgs;
    constructor Create(Callback: TOrpcDebugCallback; Serialize: Boolean; Methods: TOrpcDebugMethods);
    destructor Destroy; override;
  end;

function TOrpcDebug.AsInitArgs;
begin
  Result := @FArgs;
end;

procedure TOrpcDebug.ClientFillBuffer;
begin
  if dmClientFillBuffer in FMethods then
    InvokeCallback(dmClientFillBuffer, OrpcDebugAll);
end;

procedure TOrpcDebug.ClientGetBufferSize;
begin
  if dmClientGetBufferSize in FMethods then
    InvokeCallback(dmClientGetBufferSize, OrpcDebugAll);
end;

procedure TOrpcDebug.ClientNotify;
begin
  if dmClientNotify in FMethods then
    InvokeCallback(dmClientNotify, OrpcDebugAll);
end;

constructor TOrpcDebug.Create;
begin
  inherited Create;

  FCallback := Callback;
  FMethods := Methods;
  FSerialize := Serialize;

  // Add a weak self-reference to share with COM
  Pointer(FArgs.IntfOrpcDebug) := IOrpcDebugNotify(Self);
end;

destructor TOrpcDebug.Destroy;
begin
  if FRegistered then
  begin
    // Release the weak self reference
    Pointer(FArgs.IntfOrpcDebug) := nil;

    // Unregister
    DllDebugObjectRPCHook(False, nil);
  end;

  inherited;
end;

procedure TOrpcDebug.InvokeCallback;
var
  AcquiredLock: IAutoReleasable;
begin
  if not Assigned(FCallback) then
    Exit;

  if FSerialize then
    AcquiredLock := RtlxAcquireSRWLockExclusive(@FLock);

  try
    FCallback(Method, OrpcDebugAll);
  except
    on E: TObject do
      if not Assigned(AutoExceptionHanlder) or not
        AutoExceptionHanlder(E) then
        raise;
  end;
end;

procedure TOrpcDebug.NotifyRegistered;
begin
  FRegistered := True;
end;

procedure TOrpcDebug.ServerFillBuffer;
begin
  if dmServerFillBuffer in FMethods then
    InvokeCallback(dmServerFillBuffer, OrpcDebugAll);
end;

procedure TOrpcDebug.ServerGetBufferSize;
begin
  if dmServerGetBufferSize in FMethods then
    InvokeCallback(dmServerGetBufferSize, OrpcDebugAll);
end;

procedure TOrpcDebug.ServerNotify;
begin
  if dmServerNotify in FMethods then
    InvokeCallback(dmServerNotify, OrpcDebugAll);
end;

function ComxDebugOrpcMethods;
var
  DebugObj: IOrpcDebugInternal;
begin
  if not Assigned(Callback) then
  begin
    Result.Location := 'ComxDebugOrpcMethods';
    Result.Status := ERROR_INVALID_PARAMETER;
    Exit;
  end;

  // Prepare a wrapper for the anonymous callback
  DebugObj := TOrpcDebug.Create(Callback, Serialize, Methods);

  // Register it
  if DllDebugObjectRPCHook(True, DebugObj.AsInitArgs) then
  begin
    DebugObj.NotifyRegistered;
    Registration := DebugObj;
    Result := NtxSuccess;
  end
  else
  begin
    Result.Location := 'DllDebugObjectRPCHook';
    Result.Status := STATUS_NOT_SUPPORTED;
  end;
end;

end.