!
!  @GLOBAL.SOURCE@ - This file contains helper functions for the COM server
!
!  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.
!

!
!  M O D U L E S
!

!  Module containing helper functions for the exported functions

module ServerHelper

    interface

        !  Redefine RegCreateKeyEx so that we can pass NULL for the 
        !  SECURITY_ATTRIBUTES and lpClass
        integer(4) function  RegCreateKeyEx_Local (hKey ,lpSubKey , &
            Reserved ,lpClass ,dwOptions ,samDesired , &
            lpSecurityAttributes ,phkResult ,lpdwDisposition  ) 
            !DEC$ ATTRIBUTES DEFAULT :: RegCreateKeyEx_Local
            !DEC$ IF DEFINED(_X86_)
            !DEC$ ATTRIBUTES STDCALL, ALIAS : '_RegCreateKeyExA@36'   :: RegCreateKeyEx_Local
            !DEC$ ELSE
            !DEC$ ATTRIBUTES STDCALL, ALIAS :  'RegCreateKeyExA'      :: RegCreateKeyEx_Local
            !DEC$ ENDIF
            !DEC$ ATTRIBUTES REFERENCE :: lpSubKey
            !DEC$ ATTRIBUTES REFERENCE :: phkResult
            !DEC$ ATTRIBUTES REFERENCE :: lpdwDisposition   
            use dfwinty
            integer                     hKey
            character*(*)               lpSubKey
            integer                     Reserved
            integer                     lpClass
            integer                     dwOptions
            integer                     samDesired
            integer                     lpSecurityAttributes
            integer                     phkResult
            integer                     lpdwDisposition   
        end function RegCreateKeyEx_Local

    end interface

    integer, parameter :: SELFREG_E_CLASS = #80040201 

  contains

    !********************************************************************
    !   ROUTINE: CopyCStr
    !
    !   PURPOSE: Copies a null terminated C string to a F90 string
    !
    !*********************************************************************

    subroutine CopyCStr( cstr, fstr )
      byte, dimension(*), intent(in)  :: cstr
      character*(*), intent(out) :: fstr

        integer i
        ! scan up to the terminating null
        i = 1
        do while( cstr(i) .ne. 0 )
          fstr(i:i) = CHAR(cstr(i))
          i = i + 1
        end do
        ! pad the rest with blanks
        do while( i .le. len(fstr) )
          fstr(i:i) = ' '
          i = i + 1
        end do
    end subroutine CopyCStr

    !********************************************************************
    !   ROUTINE: LenCStr
    !
    !   PURPOSE: Returns the length of a null terminated C string
    !            (not including the NULL character)
    !
    !*********************************************************************

    integer function LenCStr( cstr )
      byte, dimension(*), intent(in)  :: cstr

        integer i
        ! scan up to the terminating null
        i = 1
        do while( cstr(i) .ne. 0 )
          i = i + 1
        end do
        LenCStr = i-1
    end function LenCStr

    !********************************************************************
    !   ROUTINE: CopyFStr
    !
    !   PURPOSE: Copies a F90 string to a null terminated C string
    !
    !*********************************************************************

    integer function CopyFStr( fstr, cstr )
      character*(*), intent(in)  :: fstr
      character*(*), intent(out) :: cstr

        !  Search for the last non-blank character in the F90 string
        !  and replace the next character with a terminating 0
        integer l
        l = len_trim(fstr)
        if (l > 0) then
            cstr(:l) = fstr(:l)
        end if 
        cstr(l+1:l+1) = char(0)
        CopyFStr = l
    end function CopyFStr

    !********************************************************************
    !   ROUTINE: RegisterClass
    !
    !   PURPOSE: Registers a CoClass with the system.  Creates keys
    !            under HKEY_CLASSES_ROOT that enable COM to create
    !            an instance of the class.
    !
    !*********************************************************************

    function RegisterClass(ProgID, Version, ClassName, ThreadingModel, &
                         CLSID_GUID, Typelib_GUID, modname, bDual) result (r)
        use @GLOBAL.NAME@_global
        use dfwinty
        use dfnls
        use advapi32
        use kernel32
        implicit none

        character*(*) ProgID
        character*(*) Version
        character*(*) ClassName  
        character*(*) ThreadingModel
        type (GUID)   CLSID_GUID
        type (GUID)   Typelib_GUID
        character*(*) modname
        logical       bDual
        integer(LONG) r

        character(MAX_PATH) temp
        character(MAX_PATH) temp_C
        character(38) CLSID
        character(38) TypelibGUID

        integer status1, status2
        integer(HANDLE) htopKey
        integer(HANDLE) h2Key
        integer disposition
        integer slen

        !  Get the string versions of the GUIDs
        call COMStringFromGUID(CLSID_GUID, CLSID, status1)
        call COMStringFromGUID(Typelib_GUID, TypelibGUID, status1)

        !  Create the ProgID keys
        htopKey = 0
        h2Key = 0
        temp = ProgID 
        slen = CopyFStr( temp, temp_C )
        status1 = RegCreateKeyEx_Local  (HKEY_CLASSES_ROOT, temp_C, 0, &
            NULL, REG_OPTION_NON_VOLATILE, &
            IOR(KEY_WRITE, KEY_QUERY_VALUE), 0, htopKey, disposition)
        if (status1 /= ERROR_SUCCESS) goto 99999
        slen = CopyFStr( ClassName, temp_C )
        status1 = RegSetValueEx( htopKey, ""C, 0, REG_SZ, &
               %loc(temp_C), slen+1 )
        if (status1 /= ERROR_SUCCESS) goto 99999
        status1 = RegCreateKeyEx_Local  (htopKey, "CLSID"C, 0, &
            NULL, REG_OPTION_NON_VOLATILE, &
            IOR(KEY_WRITE, KEY_QUERY_VALUE), 0, h2Key, disposition)
        if (status1 /= ERROR_SUCCESS) goto 99999
        slen = CopyFStr( CLSID, temp_C )
        status1 = RegSetValueEx( h2Key, ""C, 0, REG_SZ, &
               %loc(temp_C), slen+1 )
        if (status1 /= ERROR_SUCCESS) goto 99999
        status2 = RegCloseKey(h2Key)
        h2Key = 0
        status1 = RegCreateKeyEx_Local  (htopKey, "CurVer"C, 0, &
            NULL, REG_OPTION_NON_VOLATILE, &
            IOR(KEY_WRITE, KEY_QUERY_VALUE), 0, h2Key, disposition)
        if (status1 /= ERROR_SUCCESS) goto 99999
        temp = ProgID // "." // Version
        slen = CopyFStr( temp, temp_C )
        status1 = RegSetValueEx( h2Key, ""C, 0, REG_SZ, &
               %loc(temp_C), slen+1 )
        if (status1 /= ERROR_SUCCESS) goto 99999
        status2 = RegCloseKey(htopKey)
        htopKey = 0

        status1 = RegCreateKeyEx_Local  (HKEY_CLASSES_ROOT, temp_C, 0, &
            NULL, REG_OPTION_NON_VOLATILE, &
            IOR(KEY_WRITE, KEY_QUERY_VALUE), 0, htopKey, disposition)
        if (status1 /= ERROR_SUCCESS) goto 99999
        slen = CopyFStr( ClassName, temp_C )
        status1 = RegSetValueEx( htopKey, ""C, 0, REG_SZ, &
               %loc(temp_C), slen+1 )
        if (status1 /= ERROR_SUCCESS) goto 99999
        status1 = RegCreateKeyEx_Local  (htopKey, "CLSID"C, 0, &
            NULL, REG_OPTION_NON_VOLATILE, &
            IOR(KEY_WRITE, KEY_QUERY_VALUE), 0, h2Key, disposition)
        if (status1 /= ERROR_SUCCESS) goto 99999
        slen = CopyFStr( CLSID, temp_C )
        status1 = RegSetValueEx( h2Key, ""C, 0, REG_SZ, &
               %loc(temp_C), slen+1 )
        if (status1 /= ERROR_SUCCESS) goto 99999
        status2 = RegCloseKey(h2Key)
        h2Key = 0
        status2 = RegCloseKey(htopKey)
        htopKey = 0

        !  Create the CLSID sub-keys
        temp = "CLSID\" // CLSID 
        slen = CopyFStr( temp, temp_C )
        status1 = RegCreateKeyEx_Local  (HKEY_CLASSES_ROOT, temp_C, 0, &
            NULL, REG_OPTION_NON_VOLATILE, &
            IOR(KEY_WRITE, KEY_QUERY_VALUE), 0, htopKey, disposition)
        if (status1 /= ERROR_SUCCESS) goto 99999
        slen = CopyFStr( ClassName, temp_C )
        status1 = RegSetValueEx( htopKey, ""C, 0, REG_SZ, &
               %loc(temp_C), slen+1 )
        if (status1 /= ERROR_SUCCESS) goto 99999
        status1 = RegCreateKeyEx_Local  (htopKey, "ProgID"C, 0, &
            NULL, REG_OPTION_NON_VOLATILE, &
            IOR(KEY_WRITE, KEY_QUERY_VALUE), 0, h2Key, disposition)
        if (status1 /= ERROR_SUCCESS) goto 99999
        temp = ProgID // "." // Version
        slen = CopyFStr( temp, temp_C )
        status1 = RegSetValueEx( h2Key, ""C, 0, REG_SZ, &
               %loc(temp_C), slen+1 )
        if (status1 /= ERROR_SUCCESS) goto 99999
        status2 = RegCloseKey(h2Key)
        h2Key = 0
        status1 = RegCreateKeyEx_Local  (htopKey, "VersionIndependentProgID"C, 0, &
            NULL, REG_OPTION_NON_VOLATILE, &
            IOR(KEY_WRITE, KEY_QUERY_VALUE), 0, h2Key, disposition)
        if (status1 /= ERROR_SUCCESS) goto 99999
        temp = ProgID
        slen = CopyFStr( temp, temp_C )
        status1 = RegSetValueEx( h2Key, ""C, 0, REG_SZ, &
               %loc(temp_C), slen+1 )
        if (status1 /= ERROR_SUCCESS) goto 99999
        status2 = RegCloseKey(h2Key)
        h2Key = 0
        if (bDual) then
            status1 = RegCreateKeyEx_Local  (htopKey, "Programmable"C, 0, &
                NULL, REG_OPTION_NON_VOLATILE, &
                IOR(KEY_WRITE, KEY_QUERY_VALUE), 0, h2Key, disposition)
            if (status1 /= ERROR_SUCCESS) goto 99999
            status2 = RegCloseKey(h2Key)
            h2Key = 0
        end if
        status1 = RegCreateKeyEx_Local  (htopKey, "TypeLib"C, 0, &
            NULL, REG_OPTION_NON_VOLATILE, &
            IOR(KEY_WRITE, KEY_QUERY_VALUE), 0, h2Key, disposition)
        if (status1 /= ERROR_SUCCESS) goto 99999
        slen = CopyFStr( TypelibGuid, temp_C )
        status1 = RegSetValueEx( h2Key, ""C, 0, REG_SZ, &
               %loc(temp_C), slen+1 )
        if (status1 /= ERROR_SUCCESS) goto 99999
        status2 = RegCloseKey(h2Key)
        h2Key = 0
@#IFTRUE EXESERVER
        status1 = RegCreateKeyEx_Local  (htopKey, "LocalServer32"C, 0, &
            NULL, REG_OPTION_NON_VOLATILE, &
            IOR(KEY_WRITE, KEY_QUERY_VALUE), 0, h2Key, disposition)
@#ELSE
        status1 = RegCreateKeyEx_Local  (htopKey, "InprocServer32"C, 0, &
            NULL, REG_OPTION_NON_VOLATILE, &
            IOR(KEY_WRITE, KEY_QUERY_VALUE), 0, h2Key, disposition)
@#ENDIF
        if (status1 /= ERROR_SUCCESS) goto 99999
        slen = CopyFStr( modname, temp_C )
        status1 = RegSetValueEx( h2Key, ""C, 0, REG_SZ, &
               %loc(temp_C), slen+1 )
        if (status1 /= ERROR_SUCCESS) goto 99999
@#IFTRUE EXESERVER
@#ELSE
        slen = CopyFStr( ThreadingModel, temp_C )
        status1 = RegSetValueEx( h2Key, "ThreadingModel"C, 0, REG_SZ, &
               %loc(temp_C), slen+1 )
        if (status1 /= ERROR_SUCCESS) goto 99999
@#ENDIF
        status2 = RegCloseKey(h2Key)
        h2Key = 0
        status2 = RegCloseKey(htopKey)
        htopKey = 0

        r = S_OK
        return

    99999   r = E_FAIL
        if (htopKey /= 0) status2 = RegCloseKey(htopKey)
        if (h2Key /= 0) status2 = RegCloseKey(h2Key)
        return

    end function

    !********************************************************************
    !   ROUTINE: DeleteRegKeyAndSubKeys
    !
    !   PURPOSE: Deletes a registry key and all subkeys.
    !
    !*********************************************************************

    recursive function DeleteRegKeyAndSubKeys(hRootKey, SubKey) result (r)
        use dfwinty
        use advapi32
        implicit none

        integer(HANDLE) hRootKey
        character*(*) SubKey        ! String must be null-terminated
        integer(LONG) r

        integer(HANDLE) hKey
        integer(LONG) status
        character*(MAX_PATH) subkeyname
        character*(MAX_PATH) classname
        integer(DWORD) valueSize
        type(T_FILETIME) filetime

        ! Open the key and recursively delete all subkeys, starting
        ! with the "leaves"
        status = ERROR_SUCCESS
        do while (status == ERROR_SUCCESS)
            status = RegOpenKeyEx(hRootKey, SubKey, 0, &
                KEY_ALL_ACCESS, loc(hKey))
            if (status == ERROR_SUCCESS) then
                valueSize = MAX_PATH
                status = RegEnumKeyEx(hKey, 0, subkeyname, loc(valueSize), &
                        NULL, classname, loc(valuesize), filetime)
                if (status == ERROR_NO_MORE_ITEMS) then
                    status = RegCloseKey(hKey)
                    status = RegDeleteKey(hRootKey, SubKey)
                else
                    status = DeleteRegKeyAndSubKeys(hKey, subkeyname)
                    status = RegCloseKey(hKey)
                end if
            end if
        end do

        r = S_OK
        return
    end function

    !********************************************************************
    !   ROUTINE: UnregisterClass
    !
    !   PURPOSE: Unregisters a CoClass with the system.  Removes the
    !            keys under HKEY_CLASSES_ROOT that were created by
    !            RegisterClass.
    !
    !*********************************************************************

    function UnregisterClass(ProgID, Version, CLSID_GUID ) result (r)
        use dfwinty
        use advapi32
        implicit none

        character*(*) ProgID
        character*(*) Version
        type (GUID)   CLSID_GUID
        integer(LONG) r

        character(MAX_PATH) temp
        character(MAX_PATH) temp_C
        character(38) CLSID
        integer(HANDLE) hKey
        integer(LONG) status
        integer slen

        r = S_OK

        !  Get the string versions of the GUIDs
        call COMStringFromGUID(CLSID_GUID, CLSID, status)

        !  Remove the keys under HKEY_CLASSES_ROOT that were created by
        !  RegisterClass.
        temp = ProgID 
        slen = CopyFStr( temp, temp_C )
        status = DeleteRegKeyAndSubKeys(HKEY_CLASSES_ROOT, temp_C)
        if (status /= S_OK) r = E_FAIL
        temp = ProgID // "." // Version
        slen = CopyFStr( temp, temp_C )
        status = DeleteRegKeyAndSubKeys(HKEY_CLASSES_ROOT, temp_C)
        if (status /= S_OK) r = E_FAIL
        status = RegOpenKeyEx(HKEY_CLASSES_ROOT, "CLSID"C, 0, &
            KEY_READ, loc(hKey))
        if (status == ERROR_SUCCESS) then
            status = DeleteRegKeyAndSubKeys(hKey, CLSID)
            if (status /= S_OK) r = E_FAIL
            status = RegCloseKey(hKey)
        else
            r = E_FAIL
        end if

        return
    end function

    !********************************************************************
    !   ROUTINE: RegisterServer(VOID)
    !
    !   PURPOSE:  RegisterServer is called to have the server
    !             register itself.  
    !
    !*********************************************************************

    function RegisterServer () result (r)
        use @GLOBAL.NAME@_global
        use dfnls
        use dfwinty
        use dfcom
        use oleaut32
        @#PER CLASS
        use @CLASS.NAME@_Types
        @#ENDPER
        implicit none

        integer(LONG) r

        integer(LONG) status
        integer(LONG) res
        character(MAX_PATH) temp_C
        byte modname_C (MAX_PATH)
        equivalence(temp_C, modname_C)
        character(MAX_PATH) modname
        integer(2), dimension(MAX_PATH) :: unicodestr
        integer(LPVOID) ITypelibPtr
        logical bDual

        r = SELFREG_E_CLASS 
        status = GetModuleFileName(ghinst, temp_C, MAX_PATH)
        if (status == 0) return
        call CopyCStr(modname_C, modname)

        !  Per class
        @#PER CLASS
        bDual = .FALSE.
        @#PER INTERFACE
        @#IFTRUE DUAL
        bDual = .TRUE.
        @#ENDIF
        @#ENDPER
        status = RegisterClass(@CLASS.NAME@_PROGID, @CLASS.NAME@_VERSION, &
                    @CLASS.NAME@_CLASS_NAME, @CLASS.NAME@_THREADING_MODEL, &
                    CLSID_@CLASS.NAME@, GUID_TypeLib_@GLOBAL.NAME@, modname, &
                    bDual)
        if (status /= S_OK) return
        @#ENDPER

        !  Register the type library
        modname = trim(modname) // "\1"
        res = len_trim(modname) + 1
        status = MBConvertMBToUnicode(trim(modname), unicodestr)
        unicodestr(res) = 0         ! Null terminate
        status = LoadTypeLib(%loc(unicodestr), ITypelibPtr)
        if (status /= S_OK) then
            r = status
            return
        end if
        status = RegisterTypeLib(ITypelibPtr, %loc(unicodestr), NULL)
        res = COMReleaseObject(ITypelibPtr)
        if (status /= S_OK) then
            r = status
            return
        end if

        r = S_OK
        return

    end function RegisterServer

    !********************************************************************
    !   ROUTINE: UnregisterServer(VOID)
    !
    !   PURPOSE:  UnregisterServer is called to have the server
    !             remove its registration information.  
    !
    !*********************************************************************

    function UnregisterServer () result (r)
        use @GLOBAL.NAME@_global
        use dfwinty
        @#PER CLASS
        use @CLASS.NAME@_Types
        @#ENDPER
        implicit none

        integer(LONG) r

        integer slen
        integer(LONG) status
        character(MAX_PATH) temp
        character(MAX_PATH) temp_C
        character(38) TypelibGUID

        r = S_OK
        !  Per class
        @#PER CLASS
        status = UnregisterClass(@CLASS.NAME@_PROGID, @CLASS.NAME@_VERSION, &
                    CLSID_@CLASS.NAME@)
        if (status /= S_OK) r = SELFREG_E_CLASS 
        @#ENDPER

        !  UnRegister the type library
        !  UnRegisterTypeLib is not present on Win 95 unless DCOM 1.2
        !  is installed
        !status = UnRegisterTypeLib(GUID_TypeLib_@GLOBAL.NAME@, ...)
        !  Remove the \TYPELIB sub-keys
        call COMStringFromGUID(GUID_TypeLib_@GLOBAL.NAME@, TypelibGUID, status)
        temp = "TYPELIB\" // TypelibGUID
        slen = CopyFStr( temp, temp_C )
        status = DeleteRegKeyAndSubKeys(HKEY_CLASSES_ROOT, temp_C)
        if (status /= S_OK) r = SELFREG_E_CLASS 

        return

    end function UnregisterServer

end module ServerHelper

