!
!  @GLOBAL.SOURCE@ - This file contains methods of the IClassFactory 
!  interface that is used to create instances of the user's classes
!
!  Generated by the Visual Fortran COM Server Wizard on
!  @GLOBAL.DATE@ at @GLOBAL.TIME@.
!
!   DO NOT EDIT THIS FILE!
!
!  This file is re-generated every time the object hierarchy is changed.
!

function IClassFactory_QueryInterface (pData, riid, ppv) result (r)
!DEC$ ATTRIBUTES STDCALL :: IClassFactory_QueryInterface
    use IClassFactory_Types
    use dfwinty
    use dfcom
    use kernel32
    implicit none

    type (IClassFactory_Data) pData
	!dec$ attributes reference :: pData
    type(GUID) riid
	!dec$ attributes reference :: riid
    integer(INT_PTR_KIND()) ppv
	!dec$ attributes reference :: ppv
    integer(LONG) r

    integer(LONG) i

    r = S_OK

    !  Ensure that they are requesting 
    !  the IClassFactory or IUnknown interface
    if ((.not. COMIsEqualGUID(riid, IID_IClassFactory)) .AND. &
        (.not. COMIsEqualGUID(riid, IID_IUnknown))) then
        r = E_UNEXPECTED 
        return
    end if

    i = InterlockedIncrement (loc(pData % refCount)) 
    ppv = loc(pData)

end function 

function IClassFactory_AddRef (pData) result (r)
!DEC$ ATTRIBUTES STDCALL :: IClassFactory_AddRef
    use IClassFactory_Types
    use dfwinty
    use kernel32
    implicit none

    type (IClassFactory_Data) pData
	!dec$ attributes reference :: pData
    integer r

    integer(LONG) i

    i = InterlockedIncrement (loc(pData % refCount)) 
    r = pData % refCount

end function 

function IClassFactory_Release (pData) result (r)
!DEC$ ATTRIBUTES STDCALL :: IClassFactory_Release
    use IClassFactory_Types
    use dfwinty
    use @GLOBAL.NAME@_global
    use kernel32
    implicit none

    type (IClassFactory_Data), target :: pData
	!dec$ attributes reference :: pData
    integer r

    type (IClassFactory_Data),  pointer :: pCFData
    integer status

    call EnterCriticalSection(loc(gGlobalCriticalSection))
    pData % refCount = pData % refCount - 1
    r = pData % refCount
    if (pData % refCount == 0) then
        !  Time to delete ourself....
        deallocate (pData % pVtbl)
        pCFData => pData
        deallocate (pCFData)
        !status = ServerUnlock()
    end if
    call LeaveCriticalSection(loc(gGlobalCriticalSection))

end function 

function IClassFactory_LockServer (pData, bLock) result (r)
!DEC$ ATTRIBUTES STDCALL :: IClassFactory_LockServer
    use IClassFactory_Types
    use dfwinty
    use @GLOBAL.NAME@_global
    implicit none

    type (IClassFactory_Data) pData
	!dec$ attributes reference :: pData
    logical bLock
	!dec$ attributes value :: bLock
    integer(LONG) r

    integer status

    r = S_OK

    if (bLock) then
        status = ServerLock()
    else
        status = ServerUnlock()
    end if

end function 

!  Per class
@#PER CLASS
function IClassFactory_Create@CLASS.NAME@Instance (pData, pUnk, riid, ppv) result (r)
!DEC$ ATTRIBUTES STDCALL :: IClassFactory_Create@CLASS.NAME@Instance
    use IClassFactory_Types
    use dfwinty
    use dfcom
    use @GLOBAL.NAME@_global
    use @CLASS.NAME@_Types
    @#PER INTERFACE
    use @INTERFACE.NAME@_Methods
    @#ENDPER
    implicit none

    type (IClassFactory_Data) pData
	!dec$ attributes reference :: pData
    integer(INT_PTR_KIND()) pUnk
	!dec$ attributes value :: pUnk
    type(GUID) riid
	!dec$ attributes reference :: riid
    integer(INT_PTR_KIND()) ppv
	!dec$ attributes reference :: ppv
    integer(LONG) r

    integer status
    integer(INT_PTR_KIND()) ptr
    type (@CLASS.NAME@_Data),  pointer :: p@CLASS.NAME@Data

    r = S_OK
    ppv = NULL

    !  Ensure that they are requesting a supported interface
    if ((.not. COMIsEqualGUID(riid, IID_IUnknown)) &
        !  Per interface
        @#PER INTERFACE
         .AND. (.not. COMIsEqualGUID(riid, IID_@INTERFACE.NAME@)) &
        @#IFTRUE DUAL
         .AND. (.not. COMIsEqualGUID(riid, IID_IDispatch)) &
        @#ENDIF
        @#ENDPER
        ) then
        r = E_UNEXPECTED 
        return
    end if

	!  Class does not support aggregation
	if (pUnk /= NULL) then
        r = CLASS_E_NOAGGREGATION
        return
	endif

    !  Allocate instance data structure and Vtbl
    allocate (p@CLASS.NAME@Data)

    !  Per interface
    @#PER INTERFACE
    allocate (p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData % pVtbl)
    p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData % pVtbl % QueryInterface = loc(@CLASS.NAME@_QueryInterface)
    p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData % pVtbl % AddRef = loc(@CLASS.NAME@_AddRef)
    p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData % pVtbl % Release = loc(@CLASS.NAME@_Release)
    @#IFTRUE DUAL
    p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData % pVtbl % GetTypeInfoCount = loc(@CLASS.NAME@_GetTypeInfoCount)
    p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData % pVtbl % GetTypeInfo = loc(@CLASS.NAME@_GetTypeInfo)
    p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData % pVtbl % GetIDsOfNames = loc(@CLASS.NAME@_GetIDsOfNames)
    p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData % pVtbl % Invoke = loc(@CLASS.NAME@_Invoke)
    @#ENDIF
    @#PER METHOD
    p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData % pVtbl % @METHOD.NAME@ = loc($@INTERFACE.NAME@_@METHOD.NAME@)
    @#ENDPER
    p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData % pInternalData => p@CLASS.NAME@Data % InternalData
    @#ENDPER
    p@CLASS.NAME@Data % InternalData % pStart => p@CLASS.NAME@Data
    p@CLASS.NAME@Data % InternalData % refCount = 1

    !  Allocate the user-defined instance data structure
    allocate (p@CLASS.NAME@Data % InternalData % pInstanceData)
    !  Call the "constructor"...
    status = @INSTANCETYPE.CONSTRUCTOR@(p@CLASS.NAME@Data % InternalData % pInstanceData)
    if (status /= S_OK) then
        deallocate (p@CLASS.NAME@Data % InternalData % pInstanceData)
        @#PER INTERFACE
        deallocate (p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData % pVtbl)
        @#ENDPER
        deallocate (p@CLASS.NAME@Data)
        r = status
        return
    endif

    !  Increment the server's active object count
    status = ServerLock()

    !  Return the correct interface
    if (COMIsEqualGUID(riid, IID_IUnknown)) then
        ppv = loc(p@CLASS.NAME@Data)
    !  Per interface
    @#PER INTERFACE
    else if (COMIsEqualGUID(riid, IID_@INTERFACE.NAME@)) then
        ppv = loc(p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData)
    @#IFTRUE DUAL
    else if (COMIsEqualGUID(riid, IID_IDispatch)) then
        ppv = loc(p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData)
    @#ENDIF
    @#ENDPER
    end if

end function 
@#ENDPER
