COM Aggregation Patch

See attached

It's been tested to the 'works for me' stage in a COM intensive app
(that is currently broken for a reason that seems unrelated). I think it
handles the ref counts as per my understanding of Rogerson and Box. Some
existing methods marked deprecated and should be removed I think.

-------------------------
Antony Blakey
mailto:[hidden email]
Linkuistics Pty Ltd
Adelaide, South Australia

| package |
package := Package name: 'COMAggregation'.
package paxVersion: 0;
        basicComment: ''.


package classNames
        add: #IInnerUnknown;
        add: #UnkInnerAddRefFunction;
        add: #UnkInnerQIFunction;
        add: #UnkInnerReleaseFunction;
        yourself.

package methodNames
        add: #COMClassFactory -> #CreateInstance:riid:ppvObject:;
        add: #COMObjectStub -> #innerQueryInterface:ppvObject:;
        add: #COMObjectStub -> #outerUnknown:;
        add: 'COMInterface class' -> #on:implementor:outerUnknown:;
        add: 'IUnknown class' -> #on:;
        add: 'IUnknown class' -> #on:outerUnknown:;
        yourself.

package binaryGlobalNames: (Set new
        yourself).

package globalAliases: (Set new
        yourself).

package allResourceNames: (Set new
        yourself).

package setPrerequisites: (IdentitySet new
        add: '..\Object Arts\Dolphin\Base\Dolphin';
        add: '..\Object Arts\Dolphin\ActiveX\COM\OLE COM';
        yourself).

package!

"Class Definitions"!

COMFunctionAbstract subclass: #UnkInnerAddRefFunction
        instanceVariableNames: ''
        classVariableNames: 'Descriptor'
        poolDictionaries: ''
        classInstanceVariableNames: ''!
COMFunctionAbstract subclass: #UnkInnerQIFunction
        instanceVariableNames: ''
        classVariableNames: 'Descriptor'
        poolDictionaries: ''
        classInstanceVariableNames: ''!
COMFunctionAbstract subclass: #UnkInnerReleaseFunction
        instanceVariableNames: ''
        classVariableNames: 'Descriptor'
        poolDictionaries: ''
        classInstanceVariableNames: ''!
COMInterface subclass: #IInnerUnknown
        instanceVariableNames: ''
        classVariableNames: ''
        poolDictionaries: ''
        classInstanceVariableNames: ''!

"Global Aliases"!


"Loose Methods"!

!COMClassFactory methodsFor!

CreateInstance: pUnkOuter riid: riid ppvObject: ppvObject
        "Private - Implement IClassFactory::CreateInstance().
        Manufacture an object of the receiver's server class, answering an interface
        of the specified IID on it through ppvObject. ppvObject is nulled if an
        error occurs.
        Answers an HRESULT with success/failure value as appropriate.
        E_NOINTERFACE is returned if the requested interface is not recognised or is
        not implemented by instances of the receiver's server class."

        | object pUnk interfaceClass inst |
        ppvObject value: 0.
        interfaceClass := COMInterface classForIID: riid ifNone: [^E_NOINTERFACE].
        [inst := self createInstance: pUnkOuter]
                on: Error do: [:e | ^e hresult asInteger].
        pUnk := pUnkOuter yourAddress isNull
                ifTrue: [inst queryInterface: interfaceClass ifNone: [^E_NOINTERFACE]]
                ifFalse: [
                        "Aggregation request"
                        riid = IUnknown iid ifFalse: [^E_NOINTERFACE "must request IUnknown when aggregating"].
                        IInnerUnknown on: inst outerUnknown: pUnkOuter].
        ppvObject value: pUnk detach.
        self registerInstance: inst.
        ^S_OK! !
!COMClassFactory categoriesFor: #CreateInstance:riid:ppvObject:!COM Interfaces-IClassFactory!private! !

!COMInterface class methodsFor!

on: server implementor: implementor outerUnknown: pUnkOuter
        "Private - Answer a pointer to a new instance of the receiver suitable for use
        as a reference to an internally implemented interface on the argument, server,
        (assumed to be an exported server Object), but where the interface functions are actually
        implemented in the argument, implementor. This may result in the creation
        and registration of a private COMObject instance which wraps the server object to provide
        basic support for the Common Object Model, such as reference counting, and the boilerplate of
        interface querying (if one does not already exist). The reference count of the
        COMObject will be increased to reflect the existence of the new interface pointer.
        This instantiator is for the case where the server does not implement the COM
        interface functions, but instead relies on an interface implementor which (presumably)
        knows about the server and can call on it to implement the interface."
       
        "This method should not be here - it is not generally applicable, and will only cause grief. Should be removed."
        #deprecated.
        self shouldNotImplement.

        ^(self comObjectClass on: server outerUnknown: pUnkOuter)
                findInterface: self
                ifNoneAdd: [self implementor: implementor]! !
!COMInterface class categoriesFor: #on:implementor:outerUnknown:!instance creation!private! !

!COMObjectStub methodsFor!

innerQueryInterface: pIID ppvObject: ppvOut
        "Private - Return an instance of the requested interface (through the out
        parameter, interface), if the receiver's implementor supports it. Note that this
        is the 'inner' query interface implementation (i.e. without aggregation), and directly
        implements a COM function, hence the nasty parameters and HRESULT codes, and
        is not intended for calling from within Smalltalk (send #queryInterface:[ifNone:] instead).
        The receiver's reference count is incremented (through #AddRef)
        if the query successfully returns the requested interface. Answers S_OK if the
        object supports the requested interface, or E_NOINTERFACE if not.

                HRESULT QueryInterface(
          REFIID iid, (In)
                        void** ppvObject (Out)
                );
       
        There are certain rules of the COM game which are relevant:

        - Querying for IUnknown against a particular object must always answer
                the same interface pointer value (COM may use this as an identity comparison).
        - Querying for any other interface need not yield the same pointer each time.
                [In fact Dolphin cache's all interface pointers, and will answer the same pointer
                for each individual interface type].
        - The set of interfaces which can be queried of an object must be static, not dynamic.
                This means that if query succeeds once, then the same query should succeed again,
                and likewise if it fails the first time, it should fail on all subsequent attempts.
                This is a bit of a shame, as it somewhat limits the possibilities available in Smalltalk, but ...
        - QueryInterface() must be symmetric - i.e. given a pointer to an interface on an object,
                if I query it for the same interface, that call must succeed.
        - QueryInterface() must be reflexive -  i.e. given a pointer to one interface if I can
                successfully query it for another, a query through the new interface for the original
                interface must succeed.
        - QueryInterface() must be transitive - i.e. given a pointer to one interface through which I can
                successfully query for a a second, and through that successfully query for a third, then a query for
                the first interface through the the third must succeed."

        | interfaceClass interface |
        ppvOut value: 0. "must set, even on error"
        "Notification signal: self printString, ': Querying interface ', (IID fromAddress: pIID yourAddress) displayString."
        (outerUnknown notNil and: [pIID = IUnknown iid])
                ifTrue: [interfaceClass := IInnerUnknown]
                ifFalse: [interfaceClass := COMInterface classForIID: pIID ifNone: [^E_NOINTERFACE "IID not recognised"]].
        interface := self queryInterface: interfaceClass ifNone: [^E_NOINTERFACE "interface not supported"].
        "Notification signal: 'Answering interface ', interface printString."
        ppvOut value: interface detach.
        ^S_OK!

outerUnknown: pUnkOuter
        "Private - Set the outer IUnknown of the receiver to the <IUnknown> argument, pUnkOuter."

        outerUnknown := pUnkOuter.

        "We have to Release it here because there is a requirement that we don't retain a counted
        reference to the outerUnknown from the aggregated class. This means that we also need
        to make sure the reference won't be finalized (which would erroneously call a second Release)."
        outerUnknown beUnfinalizable.
        outerUnknown Release! !
!COMObjectStub categoriesFor: #innerQueryInterface:ppvObject:!non delegating unknown!private! !
!COMObjectStub categoriesFor: #outerUnknown:!accessing!private! !

!IUnknown class methodsFor!

on: server
        "Private - Answer a pointer to a new instance of the receiver acting as a (delegating)
        unknown for the object, server.
        Implementation Note: As IUnknown is implemented entirely by the COM object stub
        we have no need of a pointer to the implementor."


        | stub if |
        stub := self comObjectClass on: server.
        if := self newInternal.
        stub addInterface: if.
        ^self fromAddress: if yourAddress!

on: server outerUnknown: pUnkOuter
        "Private - Answer a pointer to a new instance of the receiver acting as a non-delegating
        unknown for the object, server, and whose outer unknown is referenced by the
        argument, pUnkOuter.
        Implementation Note: As IUnknown is implemented entirely by the COM object stub
        we have no need of a pointer to the implementor."

        | stub if |

        "This method should not be here - it is not generally applicable, and will only cause grief. Should be removed."
        #deprecated.
        self shouldNotImplement.

        stub := self comObjectClass on: server.
        if := self newInternal.
        stub
                outerUnknown: pUnkOuter;
                addInterface: if.
        ^self fromAddress: if yourAddress! !
!IUnknown class categoriesFor: #on:!private! !
!IUnknown class categoriesFor: #on:outerUnknown:!instance creation!private! !

"End of package definition"!

"Source Globals"!

"Classes"!

UnkInnerAddRefFunction guid: (GUID fromString: '{AE101C5E-16F7-4050-A8C3-6311C2AA1D81}')!
UnkInnerAddRefFunction comment: ''!
!UnkInnerAddRefFunction categoriesForClass!COM-Implementations! !
!UnkInnerAddRefFunction methodsFor!

callback: stub interface: aCOMInterface withArgumentsAt: pArgs
        "Private - Send an IInnerUnknown::AddRef() call as an #innerAddRef message back to
        the <COMObjectStub>, stub. Answer the resulting reference count.

        Implementation Note: This method is called very frequently, so we have a special function
        class just to improve performance."

        ^stub innerAddRef!

descriptor
        "Private - Answer the descriptor object which described the external function represented
        by the receiver."

        ^Descriptor!

selector
        "Private - Answer the selector sent when the receiver is evaluated."

        ^#innerAddRef! !
!UnkInnerAddRefFunction categoriesFor: #callback:interface:withArgumentsAt:!private! !
!UnkInnerAddRefFunction categoriesFor: #descriptor!private! !
!UnkInnerAddRefFunction categoriesFor: #selector!private! !

!UnkInnerAddRefFunction class methodsFor!

initialize
        "Private - Initialize the receiver's class variables.
                self initialize
        "

        Descriptor := IUnknown descriptorClass
                                callingConvention: IUnknown stdMethodCallType
                                returnType: 'dword'
                                argumentTypes: ''!

uninitialize
        "Private - Uninitialize the receiver as it is about to be removed from the system."

        Descriptor := nil! !
!UnkInnerAddRefFunction class categoriesFor: #initialize!private! !
!UnkInnerAddRefFunction class categoriesFor: #uninitialize!private! !

UnkInnerQIFunction guid: (GUID fromString: '{165F8E5B-80A5-41D9-8F51-F3A1C31768A4}')!
UnkInnerQIFunction comment: ''!
!UnkInnerQIFunction categoriesForClass!COM-Implementations! !
!UnkInnerQIFunction methodsFor!

callback: stub interface: aCOMInterface withArgumentsAt: anAddress
        "Private - Send an IInnerUnknown::QueryInterface() call as a #innerQueryInterface:ppvObject:
        message back to the <COMObjectStub>, stub, with arguments instantiated from the
        machine stack at the <integer> address, pArgs, corresponding to the receiver's argument
        types. Answer the result."

" This is slightly slower since the VM can instantiate the arguments more quickly,
        which more than makes up for the extra overhead of the indirect invocation via #perform.

        | va |
        va := anAddress asExternalAddress.
        ^aCOMObject
                innerQueryInterface: (REFGUID fromAddress: (va dwordAtOffset: 0))
                ppvObject: (LPVOID fromAddress: (va dwordAtOffset: 4))

"

        ^stub perform: #innerQueryInterface:ppvObject: withArgumentsAt: anAddress descriptor: Descriptor!

descriptor
        "Private - Answer the descriptor object which described the external function represented
        by the receiver."

        ^Descriptor!

selector
        "Private - Answer the selector sent when the receiver is evaluated."

        ^#innerQueryInterface:ppvObject:! !
!UnkInnerQIFunction categoriesFor: #callback:interface:withArgumentsAt:!private! !
!UnkInnerQIFunction categoriesFor: #descriptor!private! !
!UnkInnerQIFunction categoriesFor: #selector!private! !

!UnkInnerQIFunction class methodsFor!

initialize
        "Private - Initialize the receiver's class variables.
                self initialize

        N.B. We frequently expect E_NOINTERFACE from QueryInterface() (i.e. it is NOT an exceptional condition),
        therefore we suppress the automatic exception raising provided by the virtual call primitive for
        HRESULTs by declaring QueryInterface as returing a signed integer. This must then be tested explicitly.
        "

        Descriptor := IUnknown descriptorClass
                                callingConvention: IUnknown stdMethodCallType
                                returnType: 'sdword'
                                argumentTypes: 'GUID* void**'!

uninitialize
        "Private - Uninitialize the receiver as it is about to be removed from the system."

        Descriptor := nil! !
!UnkInnerQIFunction class categoriesFor: #initialize!private! !
!UnkInnerQIFunction class categoriesFor: #uninitialize!private! !

UnkInnerReleaseFunction guid: (GUID fromString: '{DEE7F9E8-0DFD-4071-971B-2BC99F07CB83}')!
UnkInnerReleaseFunction comment: ''!
!UnkInnerReleaseFunction categoriesForClass!COM-Implementations! !
!UnkInnerReleaseFunction methodsFor!

callback: stub interface: aCOMInterface withArgumentsAt: pArgs
        "Private - Send an IInnserUnknown::AddRef() call as an #innerAddRef message back to
        the <COMObjectStub>, stub. Answer the resulting reference count.

        Implementation Note: This method is called very frequently, so we have a special function
        class just to improve performance."

        ^stub innerRelease!

descriptor
        "Private - Answer the descriptor object which described the external function represented
        by the receiver."

        ^Descriptor!

selector
        "Private - Answer the selector sent when the receiver is evaluated."

        ^#innerRelease! !
!UnkInnerReleaseFunction categoriesFor: #callback:interface:withArgumentsAt:!private! !
!UnkInnerReleaseFunction categoriesFor: #descriptor!private! !
!UnkInnerReleaseFunction categoriesFor: #selector!private! !

!UnkInnerReleaseFunction class methodsFor!

initialize
        "Private - Initialize the receiver's class variables.
                self initialize
        "

        Descriptor := IUnknown descriptorClass
                                callingConvention: IUnknown stdMethodCallType
                                returnType: 'dword'
                                argumentTypes: ''!

uninitialize
        "Private - Uninitialize the receiver as it is about to be removed from the system."

        Descriptor := nil! !
!UnkInnerReleaseFunction class categoriesFor: #initialize!private! !
!UnkInnerReleaseFunction class categoriesFor: #uninitialize!private! !

IInnerUnknown guid: (IID fromString: '{EB24AF77-5B4D-44D5-8A1C-1DFC4E213CE8}')!
IInnerUnknown comment: ''!
!IInnerUnknown categoriesForClass!COM-Interfaces! !
!IInnerUnknown methodsFor!

_addRef
        "Private - Increment the receiver's reference count"

        self AddRef!

AddRef
        "Invoke the AddRef() method of the COM object wrapped by the receiver.

                unsigned long __stdcall AddRef();
        "

        <virtual stdcall: dword 2>
        ^self invalidCall!

Release
        "Invoke the Release() method of the COM object wrapped by the receiver.

                unsigned long __stdcall Release();
        "

        <virtual stdcall: dword 3>
        ^self invalidCall
! !
!IInnerUnknown categoriesFor: #_addRef!private! !
!IInnerUnknown categoriesFor: #AddRef!public! !
!IInnerUnknown categoriesFor: #Release!public! !

!IInnerUnknown class methodsFor!

defineFunctions
        "Declare the virtual function table for the non-delegating (aggregation) form of the COM interface 'stdole.IUnknown'

        Implementation Note: These functions are the core of COM and are crucial to good performance,
        therefore they are implemented as special classes of function which don't need to use the
        generic Object>>perform:withArgumentsAt:descriptor: primitive."

        functions
                add: UnkInnerQIFunction new;
                add: UnkInnerAddRefFunction new;
                add: UnkInnerReleaseFunction new!

on: server outerUnknown: pUnkOuter
        "Private - Answer a pointer to a new instance of the receiver acting as a non-delegating
        unknown for the object, server, and whose outer unknown is referenced by the
        argument, pUnkOuter.
        Implementation Note: As IInnerUnknown is implemented entirely by the COM object stub
        we have no need of a pointer to the implementor."

        | stub if |
        stub := self comObjectClass on: server.
        if := self newInternal.
        stub
                outerUnknown: pUnkOuter;
                addInterface: if.
        ^self fromAddress: if yourAddress!

uninitialize
        "Private - Uninitialize the receiver prior to its removal from the image."

        VMLibrary default registryAt: self name put: nil! !
!IInnerUnknown class categoriesFor: #defineFunctions!public! !
!IInnerUnknown class categoriesFor: #on:outerUnknown:!private! !
!IInnerUnknown class categoriesFor: #uninitialize!private! !

"Binary Globals"!

"Resources"!