!
!  @GLOBAL.SOURCE@ - This module contains definitions of the @CLASS.NAME@ class
!
!  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.
!

module @CLASS.NAME@_Types

    use @INSTANCETYPE.USE@
    use dfwinty

    !  Strings used in registering class
    character*@(= GetCStrLen(CLASS.DESCRIPTION)@), parameter :: @CLASS.NAME@_CLASS_NAME = ("@[@CLASS.DESCRIPTION@@]")
    character*@(= GetStrLen(CLASS.PROGID)@), parameter :: @CLASS.NAME@_PROGID = ("@CLASS.PROGID@")
    character*@(= GetStrLen(CLASS.VERSION)@),  parameter :: @CLASS.NAME@_VERSION = ("@{@CLASS.VERSION@@|1.0@}")
    character*@(= GetCStrLen(CLASS.THREADINGMODEL)@), parameter :: @CLASS.NAME@_THREADING_MODEL = ("@CLASS.THREADINGMODEL@")

    ! CLSIDs        
    TYPE (GUID), PARAMETER :: CLSID_@CLASS.NAME@ = &
        @(= TypeGUID(CLASS.CLSID)@)
                                                
    ! IIDs      
    ! Per Interface
    @#PER INTERFACE
    TYPE (GUID), PARAMETER :: IID_@INTERFACE.NAME@ = &
        @(= TypeGUID(INTERFACE.IID)@)
    @#ENDPER

    !  This is the per-instance data of the class
    ! Per Interface
    @#PER INTERFACE
    type @INTERFACE.NAME@_Ptr
        sequence
        type (@INTERFACE.NAME@_Vtbl), pointer :: pVtbl
        type (@CLASS.NAME@_InternalData), pointer :: pInternalData
    end type @INTERFACE.NAME@_Ptr
    @#ENDPER

    type @CLASS.NAME@_InternalData
        sequence
        type (@INSTANCETYPE.NAME@), pointer :: pInstanceData
        type (@CLASS.NAME@_Data), pointer :: pStart
        integer refCount
    end type @CLASS.NAME@_InternalData

    type @CLASS.NAME@_Data
        sequence
    ! Per Interface
        @#PER INTERFACE
        type (@INTERFACE.NAME@_ptr) @INTERFACE.NAME@_InternalData
        @#ENDPER
        type (@CLASS.NAME@_InternalData) InternalData
    end type @CLASS.NAME@_Data

    ! Per Interface
    !  All methods must return integer(LONG) (an HRESULT)
    !  All methods must take as their first argument, the instance
    !  data type by reference
    @#PER INTERFACE
    type @INTERFACE.NAME@_Vtbl
        sequence
        ! IUnknown Methods
        integer(INT_PTR_KIND()) QueryInterface
        integer(INT_PTR_KIND()) AddRef
        integer(INT_PTR_KIND()) Release
        @#IFTRUE DUAL
        ! IDispatch Methods
        integer(INT_PTR_KIND()) GetTypeInfoCount
        integer(INT_PTR_KIND()) GetTypeInfo
        integer(INT_PTR_KIND()) GetIDsOfNames
        integer(INT_PTR_KIND()) Invoke
        @#ENDIF
        !  @INTERFACE.NAME@ Methods
        @#PER METHOD
        integer(INT_PTR_KIND()) @METHOD.NAME@
        @#ENDPER
    end type @INTERFACE.NAME@_Vtbl
    @#ENDPER

  contains

    !  IUnknown implementation for all interfaces of the class

    function @CLASS.NAME@_QueryInterface (pData, riid, ppv) result (r)
    !DEC$ ATTRIBUTES STDCALL :: @CLASS.NAME@_QueryInterface
        use dfwinty
        use dfcom
        implicit none

        type (@INTERFACE.NAME@_Ptr) pData
        !dec$ attributes reference :: pData
        type(GUID), INTENT(IN) :: riid
        !dec$ attributes reference :: riid
        integer(INT_PTR_KIND()), INTENT(OUT) :: ppv
        !dec$ attributes reference :: ppv
        integer(LONG) r

        r = S_OK
        ppv = NULL

        !  Ensure that they are requesting a supported interface
        !  NOTE:  All requests for IUnknown MUST return the same pointer (per COM)
        if (COMIsEqualGUID(riid, IID_IUnknown)) then
            ppv = loc(pData % pInternalData % pStart % @INTERFACE.NAME@_InternalData)
        !  Per interface
        @#PER INTERFACE
        else if (COMIsEqualGUID(riid, IID_@INTERFACE.NAME@)) then
            ppv = loc(pData % pInternalData % pStart % @INTERFACE.NAME@_InternalData)
        @#IFTRUE DUAL
        else if (COMIsEqualGUID(riid, IID_IDispatch)) then
            ppv = loc(pData % pInternalData % pStart % @INTERFACE.NAME@_InternalData)
        @#ENDIF
        @#ENDPER
        end if

        if (ppv == NULL) then
            r = E_UNEXPECTED 
            return
        end if

        pData % pInternalData % refCount = &
            pData % pInternalData % refCount + 1

    end function 

    function @CLASS.NAME@_AddRef (pData) result (r)
    !DEC$ ATTRIBUTES STDCALL :: @CLASS.NAME@_AddRef
        use dfwinty
        implicit none

        type (@INTERFACE.NAME@_Ptr) pData
        !dec$ attributes reference :: pData
        integer r

        pData % pInternalData % refCount = &
            pData % pInternalData % refCount + 1
        r = pData % pInternalData % refCount

    end function 

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

        type (@INTERFACE.NAME@_Ptr) pData
        !dec$ attributes reference :: pData
        integer r

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

        pData % pInternalData % refCount = &
            pData % pInternalData % refCount - 1
        r = pData % pInternalData % refCount
        if (pData % pInternalData % refCount == 0) then
            !  Time to delete ourself....
            p@CLASS.NAME@Data => pData % pInternalData % pStart
            !  Call the "destructor"
            call @INSTANCETYPE.DESTRUCTOR@(p@CLASS.NAME@Data % InternalData % pInstanceData)
            !  Per interface
            @#PER INTERFACE
            deallocate (p@CLASS.NAME@Data % @INTERFACE.NAME@_InternalData % pVtbl)
            @#ENDPER
            deallocate (p@CLASS.NAME@Data % InternalData % pInstanceData)
            deallocate (p@CLASS.NAME@Data)
            status = ServerUnlock()
        end if

    end function 

    @#PER INTERFACE
    @#IFTRUE DUAL

    !  IDispatch implementation for @INTERFACE.NAME@

    function @CLASS.NAME@_GetTypeInfoCount(pData, pctinfo) result (hresult)
        !DEC$ ATTRIBUTES STDCALL :: @CLASS.NAME@_GetTypeInfoCount
        implicit none
        type (@INTERFACE.NAME@_Ptr) pData
        !dec$ attributes reference :: pData
        integer(LONG), INTENT(OUT) :: pctinfo
        !dec$ attributes reference :: pctinfo
        integer(LONG) hresult

        hresult = S_OK
        pctinfo = 1

    end function

    function @CLASS.NAME@_GetTypeInfo(pData, iTInfo, lcid, ppTInfo) result (hresult)
        !DEC$ ATTRIBUTES STDCALL :: @CLASS.NAME@_GetTypeInfo
        use dfwinty
        use @GLOBAL.NAME@_global
        use kernel32
        use oleaut32
        use dfcom
        implicit none
        type (@INTERFACE.NAME@_Ptr) pData
        !dec$ attributes reference :: pData
        integer, INTENT(IN) :: iTInfo
        !dec$ attributes value :: iTInfo
        integer, INTENT(IN) :: lcid
        !dec$ attributes value :: lcid
        integer(INT_PTR_KIND()), INTENT(OUT) :: ppTInfo
        !dec$ attributes reference :: ppTInfo
        integer(LONG) hresult

        interface
            function GetTypeInfoOfGuid(pITypeLib, rguid, ppTInfo) result (hresult)
            !DEC$ ATTRIBUTES DEFAULT :: GetTypeInfoOfGuid
            !DEC$IF DEFINED(_X86_)
            !DEC$ ATTRIBUTES STDCALL, ALIAS:'_GetTypeInfoOfGuid@8' :: GetTypeInfoOfGuid
            !DEC$ ELSE
            !DEC$ ATTRIBUTES STDCALL, ALIAS:'GetTypeInfoOfGuid' :: GetTypeInfoOfGuid
            !DEC$ ENDIF
                use dfwinty
                integer(INT_PTR_KIND()) pITypeLib
                !dec$ attributes value :: pITypeLib
                TYPE (GUID), INTENT(IN) :: rguid 
                !dec$ attributes reference :: rguid
                integer(INT_PTR_KIND()), INTENT(OUT) :: ppTInfo
                !dec$ attributes reference :: ppTInfo
                integer(LONG) hresult
            end function
        end interface
		POINTER(GetTypeInfoOfGuid_PTR, GetTypeInfoOfGuid)	! routine pointer

        integer(INT_PTR_KIND()) pITypeLib    ! ITypeLib*
		INTEGER(INT_PTR_KIND()) $VTBL		 ! ITypeLib Function Table
		POINTER($VPTR, $VTBL)
        integer res

        hresult = S_OK
        if (iTInfo /= 0) then
            hresult = TYPE_E_ELEMENTNOTFOUND
            return
        end if
        ppTInfo = g@CLASS.NAME@ITypeInfo
        
        !  Get the type information if we don't already have it
        !  NOTE:  This code will always return the ITypeInfo of the
        !         first LCID that is found
        if (g@CLASS.NAME@ITypeInfo == NULL) then
            call EnterCriticalSection(loc(gGlobalCriticalSection))
            if (g@CLASS.NAME@ITypeInfo == NULL) then
                hresult = LoadRegTypeLib(GUID_TypeLib_@GLOBAL.NAME@, @{@(=GetVersionMajor(GLOBAL.TYPELIB_VERSION)@)@|1@}, @{@(=GetVersionMinor(GLOBAL.TYPELIB_VERSION)@)@|0@}, lcid, pITypeLib)
                if (hresult < 0) then
                    call LeaveCriticalSection(loc(gGlobalCriticalSection))
                    return
                end if
				$VPTR = pITypeLib
				$VPTR = $VTBL + (6 * INT_PTR_KIND()) ! Add GetTypeInfoOfGuid routine offset
				GetTypeInfoOfGuid_PTR = $VTBL
                hresult = GetTypeInfoOfGuid(pITypeLib, IID_@INTERFACE.NAME@, g@CLASS.NAME@ITypeInfo)
                res = COMReleaseObject(pITypelib)
                if (hresult < 0) then
                    call LeaveCriticalSection(loc(gGlobalCriticalSection))
                    return
                end if
            end if
            call LeaveCriticalSection(loc(gGlobalCriticalSection))
            ppTInfo = g@CLASS.NAME@ITypeInfo
        end if
        res = COMAddObjectReference(g@CLASS.NAME@ITypeInfo)

    end function

    function @CLASS.NAME@_GetIDsOfNames(pData, riid, rgszNames, cNames, lcid, rgDispID) result (hresult)
        !DEC$ ATTRIBUTES STDCALL :: @CLASS.NAME@_GetIDsOfNames
        use dfwinty
        use @GLOBAL.NAME@_global
        use dfcom
        implicit none
        type (@INTERFACE.NAME@_Ptr) pData
        !dec$ attributes reference :: pData
        TYPE (GUID), INTENT(IN)    :: riid 
        !dec$ attributes reference :: riid
        integer(INT_PTR_KIND()), INTENT(IN) :: rgszNames
        !dec$ attributes value :: rgszNames
        integer, INTENT(IN) :: cNames
        !dec$ attributes value :: cNames
        integer, INTENT(IN) :: lcid
        !dec$ attributes value :: lcid
        integer(LONG), DIMENSION(:), INTENT(OUT) :: rgDispID
        !dec$ attributes reference :: rgDispID
        integer(LONG) hresult

        interface
            function DispGetIDsOfNames(pITypeInfo, rgszNames, cNames, rgDispID) result (hresult)
            !DEC$ ATTRIBUTES DEFAULT :: DispGetIDsOfNames
            !DEC$IF DEFINED(_X86_)
            !DEC$ ATTRIBUTES STDCALL, ALIAS:'_DispGetIDsOfNames@16' :: DispGetIDsOfNames
            !DEC$ ELSE
            !DEC$ ATTRIBUTES STDCALL, ALIAS:'DispGetIDsOfNames' :: DispGetIDsOfNames
            !DEC$ ENDIF
                use dfwinty
                integer(INT_PTR_KIND()) pITypeInfo
                !dec$ attributes value :: pITypeInfo
                integer(INT_PTR_KIND()), INTENT(IN) :: rgszNames
                !dec$ attributes value :: rgszNames
                integer, INTENT(IN) :: cNames
                !dec$ attributes value :: cNames
                integer(LONG), DIMENSION(:), INTENT(OUT) :: rgDispID
                !dec$ attributes reference :: rgDispID
                integer(LONG) hresult
            end function
        end interface

   		TYPE (GUID), PARAMETER :: IID_NULL = &
			GUID(#00000000, #0000, #0000, &
			  CHAR('00'X)//CHAR('00'X)//CHAR('00'X)//CHAR('00'X)// &
			  CHAR('00'X)//CHAR('00'X)//CHAR('00'X)//CHAR('00'X))
        integer(INT_PTR_KIND()) pTInfo 
        integer res

        hresult = S_OK

        !  The riid argument must be IID_NULL
        if (.not. COMIsEqualGUID(riid, IID_NULL)) then
            hresult = DISP_E_UNKNOWNINTERFACE
            return
        end if

        !  Get the ITypeInfo pointer
        hresult = @CLASS.NAME@_GetTypeInfo(pData, 0, lcid, pTInfo)
        if (hresult < 0) return

        !  Call DispGetIDsOfNames
        hresult = DispGetIDsOfNames(pTInfo, rgszNames, cNames, rgDispID)
        res = COMReleaseObject(pTInfo)

    end function

    function @CLASS.NAME@_Invoke(pData, dispidMember, riid, lcid, &
        wFlags, pparams, pvarResult, pexcepinfo, puArgErr) result (hresult)
        !DEC$ ATTRIBUTES STDCALL :: @CLASS.NAME@_Invoke
        use dfwinty
        use @GLOBAL.NAME@_global
        use dfcom
        implicit none
        type (@INTERFACE.NAME@_Ptr) pData
        !dec$ attributes reference :: pData
        integer(LONG), INTENT(IN) :: dispidMember
        !dec$ attributes value :: dispidMember
        TYPE (GUID), INTENT(IN)    :: riid 
        !dec$ attributes reference :: riid
        integer, INTENT(IN) :: lcid
        !dec$ attributes value :: lcid
        integer(2), INTENT(IN) :: wFlags
        !dec$ attributes value :: wFlags
        TYPE(T_DISPPARAMS), INTENT(INOUT) :: pparams
        !dec$ attributes reference :: pparams
        TYPE(VARIANT), INTENT(OUT) :: pvarResult
        !dec$ attributes reference :: pvarResult
        TYPE(T_EXCEPINFO), INTENT(OUT) :: pexcepinfo
        !dec$ attributes reference :: pexcepinfo
        integer, INTENT(OUT) :: puArgErr
        !dec$ attributes reference :: puArgErr
        integer(LONG) hresult

        interface
            function DispInvoke(pInterface, pTInfo, dispidMember, &
                wFlags, pparams, pvarResult, pexcepinfo, puArgErr) result (hresult)
            !DEC$ ATTRIBUTES DEFAULT :: DispInvoke
            !DEC$IF DEFINED(_X86_)
            !DEC$ ATTRIBUTES STDCALL, ALIAS:'_DispInvoke@32' :: DispInvoke
            !DEC$ ELSE
            !DEC$ ATTRIBUTES STDCALL, ALIAS:'DispInvoke' :: DispInvoke
            !DEC$ ENDIF
                use dfwinty
                integer(INT_PTR_KIND()) pInterface
                !dec$ attributes value :: pInterface
                integer(INT_PTR_KIND()) pTInfo
                !dec$ attributes value :: pTInfo
                integer(LONG), INTENT(IN) :: dispidMember
                !dec$ attributes value :: dispidMember
                integer(2), INTENT(IN) :: wFlags
                !dec$ attributes value :: wFlags
                TYPE(T_DISPPARAMS), INTENT(INOUT) :: pparams
                !dec$ attributes reference :: pparams
                TYPE(VARIANT), INTENT(OUT) :: pvarResult
                !dec$ attributes reference :: pvarResult
                TYPE(T_EXCEPINFO), INTENT(OUT) :: pexcepinfo
                !dec$ attributes reference :: pexcepinfo
                integer, INTENT(OUT) :: puArgErr
                !dec$ attributes reference :: puArgErr
                integer(LONG) hresult
            end function
        end interface

   		TYPE (GUID), PARAMETER :: IID_NULL = &
			GUID(#00000000, #0000, #0000, &
			  CHAR('00'X)//CHAR('00'X)//CHAR('00'X)//CHAR('00'X)// &
			  CHAR('00'X)//CHAR('00'X)//CHAR('00'X)//CHAR('00'X))
        integer(INT_PTR_KIND()) pTInfo 
        integer res

        hresult = S_OK

        !  The riid argument must be IID_NULL
        if (.not. COMIsEqualGUID(riid, IID_NULL)) then
            hresult = DISP_E_UNKNOWNINTERFACE
            return
        end if

        !  Get the ITypeInfo pointer
        hresult = @CLASS.NAME@_GetTypeInfo(pData, 0, lcid, pTInfo)
        if (hresult < 0) return

        !  Call DispInvoke
        hresult = DispInvoke(loc(pdata), pTInfo, dispidMember, &
                wFlags, pparams, pvarResult, pexcepinfo, puArgErr)
        res = COMReleaseObject(pTInfo)

    end function
    @#ENDIF
    @#ENDPER

end module

@($INSTANCENAME = CopyStr(INSTANCETYPE.NAME)@)
@#PER INTERFACE
@#template "ccccim.f90|@INTERFACE.NAME@.f90"
@#ENDPER
