发新帖我要提问
返回列表
打印
[实用程序源码及工具软件]

Fortran语言调用动态链接库DLL例程源码（独家在21ic发表）

[复制链接]
233|0
手机看帖
扫描二维码
随时随地手机跟帖
跳转到指定楼层
楼主
hotpower|  楼主 | 2023-9-19 14:25 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
AN, FOR, Fortran, 动态链接库, 源码
本帖最后由 hotpower 于 2023-9-20 09:45 编辑
复制
PROGRAM Main 

    USE, INTRINSIC :: ISO_C_BINDING, ONLY: & 

     C_F_PROCPOINTER, C_FUNPTR, C_INTPTR_T, & 

     C_NULL_CHAR, C_CHAR, C_ASSOCIATED, C_DOUBLE, C_INT, C_LONG



    IMPLICIT NONE 



    INTERFACE 

    FUNCTION LoadLibrary(lpFileName) BIND(C,NAME='LoadLibraryA') 

     USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INTPTR_T, C_CHAR 

     IMPLICIT NONE 

     CHARACTER(KIND=C_CHAR) :: lpFileName(*) 

     !GCC$ ATTRIBUTES STDCALL :: LoadLibrary 

     INTEGER(C_INTPTR_T) :: LoadLibrary 

    END FUNCTION LoadLibrary 



    FUNCTION GetProcAddress(hModule, lpProcName) & 

     BIND(C, NAME='GetProcAddress') 

     USE, INTRINSIC :: ISO_C_BINDING, ONLY: & 

      C_FUNPTR, C_INTPTR_T, C_CHAR 

     IMPLICIT NONE 

     !GCC$ ATTRIBUTES STDCALL :: GetProcAddress 

     TYPE(C_FUNPTR) :: GetProcAddress 

     INTEGER(C_INTPTR_T), VALUE :: hModule 

     CHARACTER(C_CHAR) :: lpProcName(*) 

    END FUNCTION GetProcAddress  

    END INTERFACE 



     INTERFACE 

        function PEA256Init() Bind(C, name="PEA256Init")

            USE, INTRINSIC :: ISO_C_BINDING

            logical(C_BOOL) :: PEA256Init

        end function PEA256Init

        function PEA256Open() Bind(C, name="PEA256Open")

            USE, INTRINSIC :: ISO_C_BINDING

            INTEGER(C_INTPTR_T) :: PEA256Open

        end function PEA256Open

        SUBROUTINE PEA256Close(handle) Bind(C, name="PEA256Close")

            USE, INTRINSIC :: ISO_C_BINDING

            INTEGER(C_INTPTR_T), intent(in), VALUE :: handle

        end SUBROUTINE PEA256Close

        function PEA256EncryptUserKey(handle, keystr, keybuff, keyfile) Bind(C, name="PEA256EncryptUserKey")

            USE, INTRINSIC :: ISO_C_BINDING

            INTEGER(C_INTPTR_T), intent(in), VALUE :: handle

            character(C_CHAR), intent(in)::keystr(*)

            character(C_CHAR), intent(in)::keybuff(*)

            character(C_CHAR), intent(in)::keyfile(*)

            INTEGER(kind=4) :: PEA256EncryptUserKey

        end function PEA256EncryptUserKey

        function PEA256DecryptUserKey(handle, keystr, keybuff, keyfile) Bind(C, name="PEA256DecryptUserKey")

            USE, INTRINSIC :: ISO_C_BINDING

            INTEGER(C_INTPTR_T), intent(in), VALUE :: handle

            character(C_CHAR), intent(in)::keystr(*)

            character(C_CHAR), intent(in)::keybuff(*)

            character(C_CHAR), intent(in)::keyfile(*)

            INTEGER(kind=4) :: PEA256DecryptUserKey

        end function PEA256DecryptUserKey

        function PEA256EncryptBytes(handle, bytes, len, subkey) Bind(C, name="PEA256EncryptBytes")

            USE, INTRINSIC :: ISO_C_BINDING

            INTEGER(C_INTPTR_T), intent(in), VALUE :: handle

            character(C_CHAR), intent(inout)::bytes(*)

            INTEGER(kind=4), intent(in), VALUE::len

            INTEGER(kind=4), intent(in), VALUE::subkey

            INTEGER(kind=4) :: PEA256EncryptBytes

        end function PEA256EncryptBytes

        function PEA256DecryptBytes(handle, bytes, len, subkey) Bind(C, name="PEA256DecryptBytes")

            USE, INTRINSIC :: ISO_C_BINDING

            INTEGER(C_INTPTR_T), intent(in), VALUE :: handle

            character(C_CHAR), intent(inout)::bytes(*)

            INTEGER(kind=4), intent(in), VALUE::len

            INTEGER(kind=4), intent(in), VALUE::subkey

            INTEGER(kind=4) :: PEA256DecryptBytes

        end function PEA256DecryptBytes

        function PEA256EncryptBytesEx(handle, inbytes, outbytes, len, subkey) Bind(C, name="PEA256EncryptBytesEx")

            USE, INTRINSIC :: ISO_C_BINDING

            INTEGER(C_INTPTR_T), intent(in), VALUE :: handle

            character(C_CHAR), intent(in)::inbytes(*)

            character(C_CHAR), intent(out)::outbytes(*)

            INTEGER(kind=4), intent(in), VALUE::len

            INTEGER(kind=4), intent(in), VALUE::subkey

            INTEGER(kind=4) :: PEA256EncryptBytesEx

        end function PEA256EncryptBytesEx

        function PEA256DecryptBytesEx(handle, inbytes, outbytes, len, subkey) Bind(C, name="PEA256DecryptBytesEx")

            USE, INTRINSIC :: ISO_C_BINDING

            INTEGER(C_INTPTR_T), intent(in), VALUE :: handle

            character(C_CHAR), intent(in)::inbytes(*)

            character(C_CHAR), intent(out)::outbytes(*)

            INTEGER(kind=4), intent(in), VALUE::len

            INTEGER(kind=4), intent(in), VALUE::subkey

            INTEGER(kind=4) :: PEA256DecryptBytesEx

        end function PEA256DecryptBytesEx

        function PEA256EncryptArrayEx(handle, inbytes, outbytes, index, len, subkey) Bind(C, name="PEA256EncryptArrayEx")

            USE, INTRINSIC :: ISO_C_BINDING

            INTEGER(C_INTPTR_T), intent(in), VALUE :: handle

            character(C_CHAR), intent(in)::inbytes(*)

            character(C_CHAR), intent(out)::outbytes(*)

            INTEGER(kind=4), intent(in), VALUE::index

            INTEGER(kind=4), intent(in), VALUE::len

            INTEGER(kind=4), intent(in), VALUE::subkey

            INTEGER(kind=4) :: PEA256EncryptArrayEx

        end function PEA256EncryptArrayEx

        function PEA256DecryptArrayEx(handle, inbytes, outbytes, index, len, subkey) Bind(C, name="PEA256DecryptArrayEx")

            USE, INTRINSIC :: ISO_C_BINDING

            INTEGER(C_INTPTR_T), intent(in), VALUE :: handle

            character(C_CHAR), intent(in)::inbytes(*)

            character(C_CHAR), intent(out)::outbytes(*)

            INTEGER(kind=4), intent(in), VALUE::index

            INTEGER(kind=4), intent(in), VALUE::len

            INTEGER(kind=4), intent(in), VALUE::subkey

            INTEGER(kind=4) :: PEA256DecryptArrayEx

        end function PEA256DecryptArrayEx

        function PEA256Test() Bind(C, name="PEA256Test")

            USE, INTRINSIC :: ISO_C_BINDING

            logical(C_BOOL):: PEA256Test

        end function PEA256Test

    END INTERFACE 



    INTEGER(C_INTPTR_T) :: hInstLibrary 

    INTEGER(C_INTPTR_T) :: handle 

    INTEGER(kind=4) :: subkey

    INTEGER :: i

    character(C_CHAR), dimension(0:3) :: ArrayByte

    character(C_CHAR), dimension(0:3) :: ArrayEncrypt

    character(C_CHAR), dimension(0:3) :: ArrayDecrypt







    TYPE(C_FUNPTR) :: fnPEA256Init 

    PROCEDURE(PEA256Init), BIND(C), POINTER :: fpPEA256Init 

    TYPE(C_FUNPTR) :: fnPEA256Open 

    PROCEDURE(PEA256Open), BIND(C), POINTER :: fpPEA256Open 

    TYPE(C_FUNPTR) :: fnPEA256Close 

    PROCEDURE(PEA256Close), BIND(C), POINTER :: fpPEA256Close 

    TYPE(C_FUNPTR) :: fnPEA256EncryptUserKey 

    PROCEDURE(PEA256EncryptUserKey), BIND(C), POINTER :: fpPEA256EncryptUserKey 

    TYPE(C_FUNPTR) :: fnPEA256DecryptUserKey 

    PROCEDURE(PEA256DecryptUserKey), BIND(C), POINTER :: fpPEA256DecryptUserKey 

    TYPE(C_FUNPTR) :: fnPEA256EncryptBytes 

    PROCEDURE(PEA256EncryptBytes), BIND(C), POINTER :: fpPEA256EncryptBytes

    TYPE(C_FUNPTR) :: fnPEA256DecryptBytes 

    PROCEDURE(PEA256DecryptBytes), BIND(C), POINTER :: fpPEA256DecryptBytes



    TYPE(C_FUNPTR) :: fnPEA256EncryptBytesEx 

    PROCEDURE(PEA256EncryptBytesEx), BIND(C), POINTER :: fpPEA256EncryptBytesEx

    

    TYPE(C_FUNPTR) :: fnPEA256DecryptBytesEx 

    PROCEDURE(PEA256DecryptBytesEx), BIND(C), POINTER :: fpPEA256DecryptBytesEx



    TYPE(C_FUNPTR) :: fnPEA256EncryptArrayEx 

    PROCEDURE(PEA256EncryptArrayEx), BIND(C), POINTER :: fpPEA256EncryptArrayEx

    TYPE(C_FUNPTR) :: fnPEA256DecryptArrayEx 

    PROCEDURE(PEA256DecryptArrayEx), BIND(C), POINTER :: fpPEA256DecryptArrayEx

    TYPE(C_FUNPTR) :: fnPEA256Test 

    PROCEDURE(PEA256Test), BIND(C), POINTER :: fpPEA256Test 



    !****  



    hInstLibrary = LoadLibrary(trim('D:\\libpea256x64\\libpea256x64.dll') // C_NULL_CHAR) 

    IF (hInstLibrary == 0) STOP 'Unable to load DLL' 



    fnPEA256Init = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256Init' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256Init)) & 

     STOP 'Unable to obtain procedure address' 



    CALL C_F_PROCPOINTER(fnPEA256Init, fpPEA256Init)

    print*, fpPEA256Init() 



    fnPEA256Test = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256Test' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256Test)) & 

     STOP 'Unable to obtain procedure address' 

    CALL C_F_PROCPOINTER(fnPEA256Test, fpPEA256Test) 



    print*, fpPEA256Test() 



    fnPEA256Open = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256Open' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256Open)) & 

     STOP 'Unable to obtain procedure address' 

    CALL C_F_PROCPOINTER(fnPEA256Open, fpPEA256Open)



    fnPEA256Close = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256Close' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256Close)) & 

     STOP 'Unable to obtain procedure address' 



    CALL C_F_PROCPOINTER(fnPEA256Close, fpPEA256Close)



    fnPEA256EncryptUserKey = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256EncryptUserKey' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256EncryptUserKey)) & 

     STOP 'Unable to obtain procedure address' 



    CALL C_F_PROCPOINTER(fnPEA256EncryptUserKey, fpPEA256EncryptUserKey)



    fnPEA256DecryptUserKey = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256DecryptUserKey' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256DecryptUserKey)) & 

     STOP 'Unable to obtain procedure address' 



    CALL C_F_PROCPOINTER(fnPEA256DecryptUserKey, fpPEA256DecryptUserKey)



    fnPEA256EncryptBytes = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256EncryptBytes' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256EncryptBytes)) & 

     STOP 'Unable to obtain procedure address' 



    CALL C_F_PROCPOINTER(fnPEA256EncryptBytes, fpPEA256EncryptBytes)



    fnPEA256DecryptBytes = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256DecryptBytes' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256DecryptBytes)) & 

     STOP 'Unable to obtain procedure address' 



    CALL C_F_PROCPOINTER(fnPEA256DecryptBytes, fpPEA256DecryptBytes)



    fnPEA256EncryptBytesEx = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256EncryptBytesEx' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256EncryptBytesEx)) & 

     STOP 'Unable to obtain procedure address' 



    CALL C_F_PROCPOINTER(fnPEA256EncryptBytesEx, fpPEA256EncryptBytesEx)



    fnPEA256DecryptBytesEx = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256DecryptBytesEx' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256DecryptBytesEx)) & 

     STOP 'Unable to obtain procedure address' 



    CALL C_F_PROCPOINTER(fnPEA256DecryptBytesEx, fpPEA256DecryptBytesEx)



    fnPEA256DecryptArrayEx = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256DecryptArrayEx' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256DecryptArrayEx)) & 

     STOP 'Unable to obtain procedure address' 



    CALL C_F_PROCPOINTER(fnPEA256DecryptArrayEx, fpPEA256DecryptArrayEx)



    fnPEA256EncryptArrayEx = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256EncryptArrayEx' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256EncryptArrayEx)) & 

     STOP 'Unable to obtain procedure address' 



    CALL C_F_PROCPOINTER(fnPEA256EncryptArrayEx, fpPEA256EncryptArrayEx)



    fnPEA256DecryptArrayEx = GetProcAddress(hInstLibrary, & 

     C_CHAR_'PEA256DecryptArrayEx' // C_NULL_CHAR) 

    IF (.NOT. C_ASSOCIATED(fnPEA256DecryptArrayEx)) & 

     STOP 'Unable to obtain procedure address' 



    CALL C_F_PROCPOINTER(fnPEA256DecryptArrayEx, fpPEA256DecryptArrayEx)



    handle = fpPEA256Open()

    if (handle > 0) then

        do i = 0, 3

            ArrayByte(i) = char(i)

            ArrayEncrypt(i) = char(i)

        end do

        print*, ""

        subkey = fpPEA256EncryptUserKey(handle, "123" // C_NULL_CHAR, "" // C_NULL_CHAR, "" // C_NULL_CHAR)

        write (*,"(Z8.8)") subkey

        subkey = fpPEA256EncryptBytes(handle, ArrayByte, 4, subkey)

        do i = 0, 3

            write (*,"( Z2.2$)") ichar(ArrayByte(i))

        end do

        print*, ""

        subkey = fpPEA256DecryptUserKey(handle, "123" // C_NULL_CHAR, "" // C_NULL_CHAR, "" // C_NULL_CHAR)

        write (*,"(Z8.8)") subkey

        subkey = fpPEA256DecryptBytes(handle, ArrayByte, 4, subkey)

        do i = 0, 3

            write (*,"(Z2.2$)")  ichar(ArrayByte(i))

        end do

        print*, ""

        subkey = fpPEA256EncryptUserKey(handle, "" // C_NULL_CHAR, "0123456789ABCDEF0123456789ABCDEF" &

            // C_NULL_CHAR, "" // C_NULL_CHAR)

        write (*,"(Z8.8)") subkey

        subkey = fpPEA256EncryptBytesEx(handle, ArrayEncrypt, ArrayDecrypt, 4, subkey)

        do i = 0, 3

            write (*,"( Z2.2$)") ichar(ArrayDecrypt(i))

        end do

        print*, ""

        subkey = fpPEA256DecryptUserKey(handle, "" // C_NULL_CHAR, "0123456789ABCDEF0123456789ABCDEF" &

            // C_NULL_CHAR, "" // C_NULL_CHAR)

        write (*,"(Z8.8)") subkey

        subkey = fpPEA256DecryptBytesEx(handle, ArrayDecrypt, ArrayEncrypt, 4, subkey)

        do i = 0, 3

            write (*,"(Z2.2$)")  ichar(ArrayEncrypt(i))

        end do

        print*, ""

        subkey = fpPEA256EncryptUserKey(handle, "" // C_NULL_CHAR, "" &

            // C_NULL_CHAR, "123.PEA.KEY" // C_NULL_CHAR)

        write (*,"(Z8.8)") subkey

        subkey = fpPEA256EncryptArrayEx(handle, ArrayEncrypt, ArrayDecrypt, 0, 4, subkey)

        do i = 0, 3

            write (*,"( Z2.2$)") ichar(ArrayDecrypt(i))

        end do

        print*, ""

        subkey = fpPEA256DecryptUserKey(handle, "" // C_NULL_CHAR, "" &

            // C_NULL_CHAR, "123.PEA.KEY" // C_NULL_CHAR)

        write (*,"(Z8.8)") subkey

        subkey = fpPEA256DecryptArrayEx(handle, ArrayDecrypt, ArrayEncrypt, 0, 4, subkey)

        do i = 0, 3

            write (*,"(Z2.2$)")  ichar(ArrayEncrypt(i))

        end do

        print*, ""

        call fpPEA256Close(handle)

    end if 

    print*, "PEA256COM!!!"



END PROGRAM Main


使用特权

评论回复 赏

相关下载

相关帖子

返回列表
发新帖 我要提问
高级模式
B Color Image Link Quote Code 收费 Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

hotpower
个人签名：[url=http://www.21ic.com/tools/HotWC3_V1.23.html]

1538

主题

21697

帖子

506

粉丝