COM/DCOM/COM+ with GNAT: Step 3 - Object Implementation

The process of creating the actual COM object begins with creating implementations of each method of every interface the object will be using. Even though a COM object may support multiple interfaces and it is not necessary, although certainly possible if needed, to repeat the implementations of methods shared by each interface. For example it is not necessary to define multiple instances of the AddRef method. Interfaces are views of the object, and not objects themselves.

Each method must conform to the same signature as the access functions they will be assigned to as they have been defined in the main package. All objects will include implementations for IUnknown and those that are dual interfaces, will also support IDispatch.

Records need to be created for each interface that will contain a table of addresses of each method implementation. For example:

type IGNATStat_Vtbl_Record is
   record
      --  IUnknown
      QueryInterface   : Af_IUnknown_QueryInterface
        := IUnknown_QueryInterface'Access;
      AddRef           : Af_IUnknown_AddRef
        := IUnknown_AddRef'Access;
      Release          : Af_IUnknown_Release
        := IUnknown_Release'Access;

      --  IGNATMessage
      Calls             : Af_IGNATStat_Calls
        := IGNATStat_Calls'Access;
   end record;
pragma Convention (C, IGNATStat_Vtbl_Record);
type IGNATStat_Vtbl_Pointer is access all IGNATMessage_Vtbl_Record;

An instance of each record must be present in memory so that the interface can be passed to clients of the COM object. This is done by creating an aliased object of the record type.

IGNATStat_Vtbl : aliased IGNATStat_Vtbl_Record;

A record representing the instance data for the object is also created and a function to create a new COM object with that data is also needed. This record also contains a reference count for the COM object. Every time any interface reference is adjusted the object’s reference count is also adjusted. When there are no interfaces in use the reference count will reach none and the instance data for the COM object can then be freed.

--  Internal data for the COM object. Notice that there is
--  no Convention pragma on this type. This type is an Ada type.

type GNATCOMClass_Object is record
   Ref_Count : aliased Win32.LONG := 1;
   Data      : Controlled_Information;
   Count     : Integer := 0;
end record;
type GNATCOMClass_Pointer is access all GNATCOMClass_Object;

function New_Object return Interface_Pointer;

The function that creates the COM object returns an access to the objects IUnknown interface to be used bye the objects class factory. Typically the function will be like this one:

function New_Object return Interface_Pointer is
   New_Interface : aliased Interface_Pointer;
   New_Object    : aliased GNATCOMClass_Pointer;
begin
   New_Interface := new Interface;
   New_Object    := new GNATCOMClass_Object;
   New_Interface.CoClass := New_Object.all'Address;
   New_Interface.Vtbl := IGNATMessage_Vtbl'Address;
   return New_Interface;
end New_Object;

COM objects that will support dual interfaces will most likely want to take advantage of the Win32 APIs that implement IDispatch using the objects type library. In order for these APIs to function, they need access to the type library. A sound way of implementing this is using a controlled object that loads the type library when the object is created and frees it when the object is destroyed. For example:

--  Controlled type for handling information that should be
--  processed when the object is created or destroyed.

type Controlled_Information is
  new Ada.Finalization.Controlled with record
      Type_Information : aliased Win32.OleAuto.LPTYPEINFO := null;
  end record;

procedure Initialize (This : in out Controlled_Information);
procedure Finalize (This : in out Controlled_Information);
procedure Adjust (This : in out Controlled_Information);

The implementation of this example uses the Win32 API LoadRegTypeLib to load the type library interface and then uses Adjust and Finalize to handle the reference counting issues related to the interface. Implementation of the IDispatch methods then just call the appropriate Win32 APIs passing the type information interface contained in the controlled object.

Every object will need to implement the IUnknown functions. The Addref and Release methods will be the same for each object.

———————
– IUnknown_AddRef –
———————

function IUnknown_AddRef (This : access Interface)
  return Win32.ULONG
is
   lResult : Win32.Long;
   Object  : GNATCOMClass_Pointer := To_Object_Pointer (This.CoClass);
begin
   --  InterlockedIncrement is a thread protected Win32 API function
   --  to increment a long

   --  Interface reference increment
   lResult :=
     Win32.Winbase.InterlockedIncrement (This.Ref_Count'Access);

   --  Object reference increment
   lResult :=
     Win32.Winbase.InterlockedIncrement (Object.Ref_Count'Access);

   return Win32.ULONG (This.Ref_Count);

end IUnknown_AddRef;

———————-
– IUnknown_Release –
———————-

function IUnknown_Release (This : access Interface)
  return Win32.ULONG
is
   use type Interfaces.C.Long;

   lResult : Win32.Long;
   Object  : GNATCOMClass_Pointer := To_Object_Pointer (This.CoClass);
begin
   --  InterlockedDecrement is a thread protected Win32 API function
   --  to decrement a long
   lResult :=
     Win32.Winbase.InterlockedDecrement (Object.Ref_Count'Access);

   if 
     Win32.Winbase.InterlockedDecrement (This.Ref_Count'Access) /= 0
   then
      return Win32.ULONG (This.Ref_Count);

   else
      --  Last reference to Interface so free it
      Free (This.all'Address);
      return 0;
   end if;

end IUnknown_Release;

The free procedure deallocates the interface instance from memory since the reference counter has reached zero. With in the free procedure the reference count of the object is also decremented. If it reaches zero, the the instance data is also freed destroying the COM object as it is no longer in use.

The implementation of QueryInterface is similar from one object to the next, but needs to be customized to support the interfaces exposed by the COM object. In the example below, an elsif for each supported interface needs to be added after the support for IUnknown. The same pattern is followed, but the assignment of the table of access to functions is changed to the appropriate one for the requested interface.

function IUnknown_QueryInterface
  (This      : access Interface;
   riid      : in     Win32.Objbase.REFIID;
   ppvObject : access Win32.PVOID)
  return HRESULT
is
   use type Win32.Rpcdce.Guid;

   New_Interface : aliased Interface_Pointer;
   lResult       : Win32.LONG;
   Result        : Win32.ULONG;
   Object        : GNATCOMClass_Pointer :=
                        To_Object_Pointer (This.CoClass);
begin
   if riid.all = IID_IUnknown then
      -- Since IUnknown is the parent of every interface, just
      -- return back a pointer to this interface with an additional
      -- reference count and the client will use it as if it was
      -- IUnknown
      ppvObject.all := This.all'Address;
      Result := IUnknown_AddRef (This);

   elsif Riid.all = IID_IDispatch then
      New_Interface := new Interface;
      New_Interface.CoClass := This.CoClass;
      lResult := 
         Win32.Winbase.InterlockedIncrement (Object.Ref_Count'Access);
      New_Interface.Vtbl := IGNATMessage_Vtbl'Address;
      ppvObject.all := New_Interface.all'Address;

   elsif Riid.all = IID_IGNATMessage then
      New_Interface := new Interface;
      New_Interface.CoClass := This.CoClass;
      lResult := 
         Win32.Winbase.InterlockedIncrement (Object.Ref_Count'Access);
      New_Interface.Vtbl := IGNATMessage_Vtbl'Address;
      ppvObject.all := New_Interface.all'Address;

   elsif Riid.all = IID_IGNATStat then
      New_Interface := new Interface;
      New_Interface.CoClass := This.CoClass;
      lResult := 
         Win32.Winbase.InterlockedIncrement (Object.Ref_Count'Access);
      New_Interface.Vtbl := IGNATStat_Vtbl'Address;
      ppvObject.all := New_Interface.all'Address;

   else
      ppvObject.all := System.Null_Address;
      return Win32.Winerror.E_NOINTERFACE;
   end if;

   return Win32.Winerror.S_OK;
end Iunknown_QueryInterface;

Once IUnknown methods have been implemented the only additional work is to implement each interface method. In order to have access to the object instance data, a conversion function is used on the CoClass member of the interface type like this one:

function To_Object_Pointer is
   new Ada.Unchecked_Conversion (System.Address,
                                 GNATCOMClass_Pointer);

function IGNATStat_Calls
  (This          : access Interface;
   NumberOfTimes : access Interfaces.C.int)
  return HRESULT
is
   Object : GNATCOMClass_Pointer := To_Object_Pointer (This.CoClass);
begin
   Message_Box("Calls", Integer'Image (Object.Count));
   NumberOfTimes.all := Interfaces.C.int (Object.Count);

   return Win32.Winerror.S_OK;
end IGNATStat_Calls;

5.1.3 Step 3 - Object Implementation