该类用到了 WinINet 这个 windows 的库，IVF可能没有提供接口，因此手写了一部分常见函数的接口。见下方代码。
有范例代码，相信不难看懂。范例中连接了本站 FTP 地址，并尝试下载了 Notepad2 ，由于没有删除权限，因此删除文件会失败。
程序运行结果 如下：
大图
主程序如下：
Program www_fcode_cn
use FTPClass
Type(WG_FTP) :: fcode_ftp
logical :: b
b = fcode_ftp%Init() !// 初始化
write(*,*) '初始化，结果：' , b
!// 连接FTP,port也可忽略,如无密码，password也可忽略
b = fcode_ftp%Conn( "pub.fcode.cn" , username = "root" , password="fcode.cn", port=21 )
write(*,*) '连接FTP服务器，结果：' , b
If ( b ) then
write(*,*) '列出根目录文件：'
call fcode_ftp%ls( "*" , showls ) !// 列出所有文件。支持通配符，调用 showls 函数
b = fcode_ftp%cd( "Tools" ) !// 切换当前目录到 Tools 下。返回上一级用 cd( ".." )
write(*,*) '列出Tools文件夹下文件：'
call fcode_ftp%ls( "*" , showls ) !// 列出所有文件，调用 showls 函数
write(*,*) '正在下载 Notepad2...'
b = fcode_ftp%GetFile( "notepad2.zip" )
write(*,*) '下载 Notepad2，结果：' , b
write(*,*) '正在删除 Notepad2...'
b = fcode_ftp%Remove( File = "notepad2.zip" )
write(*,*) '删除 Notepad2，结果：' , b
End If
call fcode_ftp%DisConn()
write(*,*) '已退出 FTP，再见！'
contains
Subroutine showls( filename , bDir , nSize )
Character(len=*) :: filename
Logical :: bDir
Integer(kind=8) :: nSize
write(*,'("文件名：",a,6x,"大小：",g0)') filename , nSize
End Subroutine showls
End Program www_fcode_cn
所用到的module 代码如下：
!DEC$ IF .NOT. DEFINED (WININET_ )
!DEC$ DEFINE xWININET_
module WinINet
use ifwinty
use ISO_C_Binding
Implicit None
!DEC$OBJCOMMENT LIB:"WININET.LIB"
Integer , parameter :: INTERNET_SERVICE_FTP =1
Integer , parameter :: INTERNET_SERVICE_GOPHER =2
Integer , parameter :: INTERNET_SERVICE_HTTP =3
Integer , parameter :: FTP_TRANSFER_TYPE_UNKNOWN = 0
Integer , parameter :: FTP_TRANSFER_TYPE_ASCII = 1
Integer , parameter :: FTP_TRANSFER_TYPE_BINARY = 2
Integer , parameter :: INTERNET_OPTION_CALLBACK =1
Integer , parameter :: INTERNET_OPTION_CONNECT_TIMEOUT =2
Integer , parameter :: INTERNET_OPTION_CONNECT_RETRIES =3
Integer , parameter :: INTERNET_OPTION_CONNECT_BACKOFF =4
Integer , parameter :: INTERNET_OPTION_SEND_TIMEOUT =5
!Integer , parameter :: INTERNET_OPTION_CONTROL_SEND_TIMEOUT =INTERNET_OPTION_SEND_TIMEOUT
Integer , parameter :: INTERNET_OPTION_RECEIVE_TIMEOUT =6
!Integer , parameter :: INTERNET_OPTION_CONTROL_RECEIVE_TIMEOUT =INTERNET_OPTION_RECEIVE_TIMEOUT
Integer , parameter :: INTERNET_OPTION_DATA_SEND_TIMEOUT =7
Integer , parameter :: INTERNET_OPTION_DATA_RECEIVE_TIMEOUT =8
Integer , parameter :: INTERNET_OPTION_HANDLE_TYPE =9
Integer , parameter :: INTERNET_OPTION_LISTEN_TIMEOUT =11
Integer , parameter :: INTERNET_OPTION_READ_BUFFER_SIZE =12
Integer , parameter :: INTERNET_OPTION_WRITE_BUFFER_SIZE =13
Integer , parameter :: INTERNET_FLAG_TRANSFER_ASCII = FTP_TRANSFER_TYPE_ASCII
Integer , parameter :: INTERNET_FLAG_TRANSFER_BINARY = FTP_TRANSFER_TYPE_BINARY
Integer , parameter :: INTERNET_FLAG_PASSIVE = z'08000000' !// used for FTP connections
Integer(Kind=WORD) , parameter :: INTERNET_DEFAULT_FTP_PORT = 21 !// default for FTP servers
Integer , parameter :: INTERNET_DEFAULT_GOPHER_PORT = 70 !// " " gopher "
Integer , parameter :: INTERNET_DEFAULT_HTTP_PORT = 80 !// " " HTTP "
Integer , parameter :: INTERNET_DEFAULT_HTTPS_PORT = 443 !// " " HTTPS "
Integer , parameter :: INTERNET_DEFAULT_SOCKS_PORT = 1080 !// default for SOCKS firewall servers.
Integer , parameter :: INTERNET_OPEN_TYPE_PRECONFIG = 0 !// use registry configuration
Integer , parameter :: INTERNET_OPEN_TYPE_DIRECT = 1 !// direct to net
Integer , parameter :: INTERNET_OPEN_TYPE_PROXY = 3 !// via named proxy
Integer , parameter :: INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4 !// prevent using java/script/INS
!
INTERFACE
FUNCTION InternetOpen( lpszAgent , dwAccessType , lpszProxyName , lpszProxyBypass , dwFlags )
import
integer(BOOL) :: InternetOpen ! BOOL
!DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'InternetOpenA' :: InternetOpen
!DEC$ ATTRIBUTES REFERENCE, ALLOW_NULL :: lpszAgent , lpszProxyName , lpszProxyBypass
Integer :: dwAccessType , dwFlags
Character(len=*) :: lpszAgent , lpszProxyName , lpszProxyBypass
END FUNCTION InternetOpen
FUNCTION InternetSetOption( hInternet , dwOption , lpBuffer , dwBufferLength )
import
integer(BOOL) :: InternetSetOption! BOOL
!DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'InternetSetOptionA' :: InternetSetOption
!DEC$ ATTRIBUTES REFERENCE :: lpBuffer
Integer :: hInternet , dwOption , lpBuffer , dwBufferLength
END FUNCTION InternetSetOption
FUNCTION InternetConnect( hInternet , lpszServerName , nServerPort , lpszUsername , &
lpszPassword , dwService , dwFlags , dwContext )
import
integer(BOOL) :: InternetConnect ! BOOL
!DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'InternetConnectA' :: InternetConnect
!DEC$ ATTRIBUTES REFERENCE, ALLOW_NULL :: lpszServerName , lpszUsername
type(C_PTR) :: lpszPassword
Integer :: hInternet , dwFlags , dwContext , dwService
Integer(kind=WORD) :: nServerPort
Character(len=*) :: lpszServerName , lpszUsername
END FUNCTION InternetConnect
FUNCTION FtpGetFile( hConnect , lpszRemoteFile , lpszNewFile , fFailIfExists , &
dwFlagsAndAttributes , dwFlags , dwContext )
import
integer(BOOL) :: FtpGetFile ! BOOL
!DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'FtpGetFileA' :: FtpGetFile
!DEC$ ATTRIBUTES REFERENCE, ALLOW_NULL :: lpszRemoteFile , lpszNewFile
Integer :: hConnect , fFailIfExists , dwFlagsAndAttributes , dwFlags , dwContext
Character(len=*) :: lpszRemoteFile , lpszNewFile
END FUNCTION FtpGetFile
FUNCTION FtpSetCurrentDirectory( hConnect , lpszDirectory )
import
integer(BOOL) :: FtpSetCurrentDirectory ! BOOL
!DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'FtpSetCurrentDirectoryA' :: FtpSetCurrentDirectory
!DEC$ ATTRIBUTES REFERENCE, ALLOW_NULL :: lpszDirectory
Integer :: hConnect
Character(len=*) :: lpszDirectory
END FUNCTION FtpSetCurrentDirectory
FUNCTION FtpDeleteFile( hConnect , lpszFileName )
import
integer(BOOL) :: FtpDeleteFile ! BOOL
!DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'FtpDeleteFileA' :: FtpDeleteFile
!DEC$ ATTRIBUTES REFERENCE, ALLOW_NULL :: lpszFileName
Integer :: hConnect
Character(len=*) :: lpszFileName
END FUNCTION FtpDeleteFile
FUNCTION FtpRemoveDirectory( hConnect , lpszDirectory )
import
integer(BOOL) :: FtpRemoveDirectory ! BOOL
!DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'FtpRemoveDirectoryA' :: FtpRemoveDirectory
!DEC$ ATTRIBUTES REFERENCE, ALLOW_NULL :: lpszDirectory
Integer :: hConnect
Character(len=*) :: lpszDirectory
END FUNCTION FtpRemoveDirectory
FUNCTION InternetCloseHandle( hConnect )
import
integer(BOOL) :: InternetCloseHandle ! BOOL
!DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'InternetCloseHandle' :: InternetCloseHandle
Integer :: hConnect
END FUNCTION InternetCloseHandle
FUNCTION FtpFindFirstFile( hConnect , lpszSearchFile , lpFindFileData , dwFlags , dwContext )
import
integer(BOOL) :: FtpFindFirstFile ! BOOL
!DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'FtpFindFirstFileA' :: FtpFindFirstFile
!DEC$ ATTRIBUTES REFERENCE, ALLOW_NULL :: lpszSearchFile
Type( C_PTR ) , value :: lpFindFileData
Integer :: hConnect , dwFlags , dwContext
Character(len=*) :: lpszSearchFile
END FUNCTION FtpFindFirstFile
FUNCTION InternetFindNextFile( hFind , lpvFindData )
import
integer(BOOL) :: InternetFindNextFile ! BOOL
!DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'InternetFindNextFileA' :: InternetFindNextFile
Integer :: hFind
Type( C_PTR ) , value :: lpvFindData
End Function InternetFindNextFile
END INTERFACE
end module WinINet
!DEC$ ENDIF ! /* WININET_ */
Module FTPClass
Use WinINET
use , intrinsic :: ISO_C_BINDING
Implicit None
private
Type , public :: WG_FTP
integer :: hInternet , hConn
Character(len=512) :: cPath
Contains
Procedure :: Init
Procedure :: Conn
Procedure :: CD
Procedure :: LS
Procedure :: GetFile
Procedure :: GetDirectory
Procedure :: Remove
Procedure :: DisConn
End Type WG_FTP
Interface
Subroutine FTP_LS_CALLBACK( filename , bDir , nSize )
Character(len=*) :: filename
Logical :: bDir
Integer(kind=8) :: nSize
End Subroutine FTP_LS_CALLBACK
End Interface
contains
Logical Function Init( this )
Class( WG_FTP ) :: this
integer :: n
Init = .false.
this%hInternet = InternetOpen( 'FCODE_FTP'//c_null_char , INTERNET_OPEN_TYPE_DIRECT , NULL , NULL , 0 )
if ( this%hInternet == 0 ) return
n = 30*1000
Init = InternetSetOption( this%hInternet , INTERNET_OPTION_CONNECT_TIMEOUT , n , 4 )
End Function Init
Logical Function Conn( this , IP , port , username , password )
!DEC$ ATTRIBUTES ALLOW_NULL :: username , password
Class( WG_FTP ) :: this
Character(len=*) :: username
Character(len=*) :: IP
Integer(kind=2) , optional :: port
Character(len=*) , optional :: password
!character(len=*) :: IP
Type(C_PTR) :: tpass
integer(kind=2) :: ftpport
tpass = C_NULL_PTR
ftpport = INTERNET_DEFAULT_FTP_PORT
if ( present( password ) ) tpass = c_loc(password)
if ( present( port ) ) ftpport = port
this%hConn = InternetConnect( this%hInternet , trim(IP)//c_null_char , ftpport , trim(username)//c_null_char , &
tpass , INTERNET_SERVICE_FTP , INTERNET_FLAG_PASSIVE , NULL )
Conn = ( this%hConn /= 0 )
this%cPath = "/"
End Function Conn
Logical Function CD( this , dir )
Class( WG_FTP ) :: this
Integer :: iRes
Character(len=*) :: dir
Character(len=512) :: tmp
If ( dir(1:2) == '..' ) then
iRes = index( this%cPath , '/' , back = .true. )
if ( iRes > 1 ) then
tmp = this%cPath(:iRes-1)
else
tmp = "/"
end if
ElseIf ( dir(1:2) == '. ' ) then
CD = .true.
return
Else
if ( this%cPath == "/" ) then
tmp = "/"//trim(dir)
else
tmp = trim(this%cPath)//"/"//trim(dir)
end if
End If
iRes = FtpSetCurrentDirectory( this%hConn , trim(tmp)//c_null_char )
CD = ( iRes /= 0 )
if ( CD ) this%cPath = tmp
End Function CD
Subroutine LS( this , wildcard , callBack )
Class( WG_FTP ) :: this
Procedure( FTP_LS_CALLBACK ) :: callBack
Character(len=*) :: wildcard
type( T_WIN32_FIND_DATA ) :: findData
integer :: iRes , h , l
logical :: bDir
character(len=8):: tempsize
integer(kind=8) :: nSize
h = FtpFindFirstFile( this%hConn , wildcard , c_loc(findData) , 0 , 0 )
if ( h == 0 ) return
iRes = 1
Do while( iRes /= 0 )
bDir = Iand( findData%dwFileAttributes , FILE_ATTRIBUTE_DIRECTORY ) /= 0
tempsize(1:4) = transfer( findData%nFileSizeLow , tempsize(1:4) )
tempsize(5:8) = transfer( findData%nFileSizeHigh , tempsize(5:8) )
nSize = transfer( tempsize , nSize )
l = index( findData%cFilename , c_null_char )
call callBack( findData%cFilename(:l-1) , bDir , nSize )
iRes = InternetFindNextFile( h , c_loc(findData) )
End Do
iRes = InternetCloseHandle( h )
End Subroutine LS
Integer Function GetFile( this , file )
Class( WG_FTP ) :: this
Character(len=*) :: file
Integer :: iRes
GetFile = -1
iRes = FtpGetFile( this%hConn , trim(file)//c_null_char , trim(file)//c_null_char , .FALSE. , FILE_ATTRIBUTE_NORMAL , &
FTP_TRANSFER_TYPE_BINARY , 0 )
if ( iRes /= 0 ) GetFile = 1
End Function GetFile
Logical Function Remove( this , FILE , DIR )
Class( WG_FTP ) :: this
Character(len=*) , Optional :: FILE , DIR
integer :: i
If ( present( FILE ) ) then
i = FtpDeleteFile( this%hConn , trim(FILE)//c_null_char )
Else
i = FtpRemoveDirectory( this%hConn , trim(DIR)//c_null_char )
End If
Remove = ( i /= 0 )
End Function Remove
Subroutine GetDirectory( this , cDir , callBack , bExit )
Class( WG_FTP ) :: this
Procedure( FTP_LS_CALLBACK ) :: callBack
Character(len=*) :: cDir
type( T_WIN32_FIND_DATA ) :: findData
integer :: iRes , h , cnt
logical :: bDir , bExit
character(len=8):: tempsize
integer(kind=8) :: nSize
h = FtpFindFirstFile( this%hConn , trim(cDir)//'/*'//c_null_char , c_loc(findData) , 0 , 0 )
if ( h == 0 ) return
iRes = 1
cnt = 0
Do while( iRes /= 0 )
cnt = cnt + 1
iRes = InternetFindNextFile( h , c_loc(findData) )
End Do
iRes = InternetCloseHandle( h )
call callBack( "" , .true. , cnt*1_8 )
h = FtpFindFirstFile( this%hConn , trim(cDir)//'/*'//c_null_char , c_loc(findData) , 0 , 0 )
iRes = 1
Do while( iRes /= 0 )
bDir = Iand( findData%dwFileAttributes , FILE_ATTRIBUTE_DIRECTORY ) /= 0
tempsize(1:4) = transfer( findData%nFileSizeLow , tempsize(1:4) )
tempsize(5:8) = transfer( findData%nFileSizeHigh , tempsize(5:8) )
nSize = transfer( tempsize , nSize )
if ( .not.bDir ) then
call callBack( findData%cFilename , .false. , nSize )
iRes = this%GetFile( trim(cDir)//'/'//findData%cFilename )
end if
if ( bExit ) Exit
iRes = InternetFindNextFile( h , c_loc(findData) )
End Do
iRes = InternetCloseHandle( h )
End Subroutine GetDirectory
Subroutine DisConn( this )
Class( WG_FTP ) :: this
integer :: iRes
iRes = InternetCloseHandle( this%hInternet )
this%hInternet = 0 ; this%hConn = 0
End Subroutine DisConn
End Module FTPClass
