首页 > 代码 > 常规代码 > 正文

代码

阅读排行

Fortran连接FTP并下载文件
2016-03-24 16:52:21   来源:Fcode研讨团队   评论:0 点击:

本代码提供Windows下利用API连接FTP,并列举其中文件,实现 cd 切换,ls 列举,get 下载文件和文件夹,remove 删除文件等功能。适合 windows 上大多数编译器。IVF 使用更方便

今日,一个朋友需要连接 FTP 下载数据文件并处理。因此把 windows 下一些 FTP 相关的函数封装成一个 WG_FTP 类,供朋友们使用。

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

相关热词搜索:FTP download

上一篇:Fortran读取BMP图像
下一篇:利用蔡勒公式获得给定日期的星期数

分享到: 收藏