该类用到了 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