Patch title: Release 93 bulk changes
Abstract:
File: /protocol/ftp/client.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

module "/pliant/language/unsafe.pli"
module "/pliant/language/context.pli"
module "/pliant/language/stream.pli"
module "/pliant/language/stream/filesystembase.pli"
module "/pliant/language/stream/openmode.pli"
module "/pliant/language/stream/listmode.pli"
module "/pliant/language/stream/multi.pli"


constant ftp_auto_deconnect_after 30

(gvar TraceSlot ftp_trace) configure "FTP client"


#----------------------------------------------------------------------
# connections pool to ftp servers


gvar List connections_list
gvar Dictionary connections_hash
gvar Sem csem
gvar CBool auto_deconnect_running := false


type FtpConnection
  field Stream command_stream
  field TraceSession log
  field Str host user syst ; field Int port
  field CBool inuse
  field DateTime keepuntil 
  field Str data_stream_name
  field Stream data_stream 
  field CBool passive <- true


method ftp command cmd 
  arg_rw FtpConnection ftp ; arg Str cmd
  ftp:command_stream writeline cmd
  ftp:command_stream flush anytime
  ftp:log trace "query " cmd

method ftp status -> s
  arg_rw FtpConnection ftp ; arg Int s
  var Str ack := ftp:command_stream readline
  ftp:log trace "answer " ack
  if (ack 3 1)="-"
    var Str code := ack 0 3
    var CBool done := false
    while not done
      ack := ftp:command_stream readline
      ftp:log trace "answer " ack
      done := (ack 0 4)=code+" "
  if not ((ack 0 3) parse s)
    s := 599
  
method ftp status2 -> s
  arg_rw FtpConnection ftp ; arg Str s
  s := ftp:command_stream readline
  ftp:log trace "answer " s
  

method ftp open_data_stream
  arg_rw FtpConnection ftp
  if ftp:passive
    ftp command "PASV"
    var Str l := ftp status2
    var Int i1 i2 i3 i4 p1 p2
    if (l parse any "(" i1 "," i2 "," i3 "," i4 "," p1 "," p2 ")" any)
      ftp data_stream_name := "tcp://"+string:i1+"."+string:i2+"."+string:i3+"."+string:i4+"/client/"+(string p1*256+p2)
    else
      ftp data_stream_name := ""
      ftp passive := false
  if not ftp:passive
    ftp:data_stream open "tcp:/server/any" "noautoconnect" in+out+safe
    var Str ip_address := ftp:command_stream query "local_ip_address"
    (ftp:data_stream query "local_ip_port") parse (var Int ip_port)
    ftp command "PORT "+(replace ip_address "." ",")+","+(string ip_port\256)+","+(string ip_port%256)
    if ftp:status>=500
      ftp:data_stream close
  
method ftp connect_data_stream1
  arg_rw FtpConnection ftp
  if ftp:passive
    ftp:data_stream open ftp:data_stream_name in+out+safe
    
method ftp connect_data_stream2
  arg_rw FtpConnection ftp
  if not ftp:passive
    ftp:data_stream safe_configure "connect"
    
method ftp close_data_stream
  arg_rw FtpConnection ftp
  ftp:data_stream close
  

#----------------------------------------------------------------------


function connect host port user password reuse -> cc
  arg Str host ; arg Int port ; arg Str user password ; arg CBool reuse ; arg Link:FtpConnection cc
  if reuse
    csem request
    var Str key := host+" "+user
    var Pointer:Arrow cur :> connections_hash first key
    while cur<>null
      var Pointer:FtpConnection c :> cur map FtpConnection
      if c:host=host and c:port=port and c:user=user and not c:inuse
        c inuse := true
        cc :> c
        csem release
        return
      cur :> connections_hash next key cur
    csem release
  cc :> new FtpConnection
  cc:log bind ftp_trace
  cc:command_stream open "tcp://"+host+"/client/"+string:port in+out+safe+cr+lf
  cc status
  if user<>""
    cc command "USER "+user ; cc status
  if password<>""
    cc command "PASS "+password ; cc status
  cc command "TYPE I" ; cc status
  if cc:command_stream=failure
    cc :> null map FtpConnection
    return
  cc host := host
  cc port := port
  cc user := user
  cc inuse := true
  if reuse
    csem request
    connections_hash insert key true addressof:cc
    connections_list append addressof:cc
    if not auto_deconnect_running
      auto_deconnect_running := true
      thread
        var CBool continue := true
        while continue
          sleep 15
          csem request
          var Pointer:Arrow cur :> connections_list first
          if cur<>null
            var DateTime now := datetime
            while cur<>null
              var Pointer:FtpConnection c :> cur map FtpConnection
              if not c:inuse and now>=c:keepuntil
                connections_hash remove c:host+" "+c:user cur
                cur :> connections_list remove cur
              else
                cur :> connections_list next cur
          else
            continue := false
            auto_deconnect_running := false
          csem release
    csem release


function deconnect ftp
  arg_rw FtpConnection ftp
  ftp:log flush
  csem rd_request
  ftp:keepuntil seconds := datetime:seconds + ftp_auto_deconnect_after
  ftp inuse := false
  csem rd_release


#----------------------------------------------------------------------


type FtpStreamDriver
  field Link:FtpConnection connection
  field Link:StreamDriver socket
StreamDriver maybe FtpStreamDriver


method ftp read buf mini maxi -> red
  arg_rw FtpStreamDriver ftp ; arg Address buf ; arg Int mini maxi red
  red := ftp:socket read buf mini maxi


method ftp write buf mini maxi -> written
  arg_rw FtpStreamDriver ftp ; arg Address buf ; arg Int mini maxi written
  written := ftp:socket write buf mini maxi


method ftp flush level -> status
  arg_rw FtpStreamDriver ftp ; arg Int level ; arg Status status
  status := ftp:socket flush level


method ftp close -> status
  arg_rw FtpStreamDriver ftp ; arg ExtendedStatus status
  ftp socket :> null map StreamDriver
  ftp:connection close_data_stream
  status := shunt ftp:connection:status<400 success failure
  deconnect ftp:connection


#----------------------------------------------------------------------


type FtpFileSystem
  void
FileSystem maybe FtpFileSystem


function list name sub options flags files
  arg Str name sub options ; arg Int flags ; arg_rw List files
  if (name parse "//" any:(var Str server) "/" any:(var Str path))
    path := "/"+path
  eif (name parse "/" any:(var Str path))
    server := "localhost" ; path := "/"+path
  else
    return
  var Int port
  if (server eparse any:(var Str server1) ":" port)
    server := server1
  else
    port := 21
  var Str user := options option "user" Str
  var Str password := options option "password" Str
  if not (options option "user")
    user := "anonymous"
  if not (options option "password")
    password := computer_name+"@"+computer_domain
  var CBool eccentric := options option "eccentric"
  var CBool lowercase := options option "lower"
  var Link:FtpConnection ftp :> connect server port user password not (options option "no_connection_cache")
  if not exists:ftp
    return
  if ftp:syst=""
    ftp command "SYST"
    var Str syst := lower ftp:status2
    if syst="200 pliant ftp server version 1.00"
      ftp syst := "Pliant OS/2"
    eif (syst parse word:"200" word:"pliant" word:"ftp" word:"server" any)
      ftp syst := "Pliant"
    eif (syst search "unix" -1)>=0
      ftp syst := "Unix"
    else
      ftp syst := "Unknown"
  ftp command "CWD "+path
  if ftp:status>=400
    return
  var List names info
  ftp open_data_stream
  if not eccentric                     
    ftp command "LIST"+(shunt ftp:syst="Pliant" and (flags .and. extended)<>0 " -extended" ftp:syst="Unix" " -A --full-time" "")+(shunt sub<>"" " "+sub "")
    ftp connect_data_stream1
    if ftp:status>=400
      ftp close_data_stream
      deconnect ftp
      return
    ftp connect_data_stream2
    while not (ftp:data_stream atend)
      var Str l := ftp:data_stream readline
      ftp:log trace "list " l
      var Str filename dir rights ascii_month opt
      var Intn size ; var DateTime dt1
      var Int year month day hour minute second
      if ftp:syst="Pliant" and (l parse filename size dt1 any:opt)
        var Link:FileInfo f :> new FileInfo
        f name := name+filename
        f size := size
        f datetime := dt1
        if ("[dq]"+opt+"[dq]" parse (var Str opt2))
          f options := opt2
        f status := success
        files append addressof:f
      if ftp:syst="Unix" and (l parse any:rights _ any _ any _ any _ size _ any _ any:ascii_month _ day _ hour ":" minute ":" second _ year _ any:filename)
        if filename<>"./" and filename<>"../"
          var Link:FileInfo f :> new FileInfo
          if (filename parse any:(var Str filename1) "->" any:(var Str link))
            filename := filename1
            if link:len>0 and (link link:len-1 1)="/"
              filename := filename+"/"
            f options := "link "+string:link
          if filename:len>0 and (filename filename:len-1 1)="*"
            filename := filename 0 filename:len-1
          f name := name+filename
          f size := size
          month := ("XXX Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec" search ascii_month 0)\4
          if month>0
            f datetime := datetime year month day hour minute second 0
          f status := success
          files append addressof:f
      eif ftp:syst="Pliant OS/2" and (l parse day "/" month "/" year _ hour ":" minute ":" second _ size _ any:filename)
        var Link:FileInfo f :> new FileInfo
        if lowercase
          f name := shunt (filename parse word:"DIR" any:dir) name+lower:dir+"/" name+lower:filename
        else
          f name := shunt (filename parse word:"DIR" any:dir) name+dir+"/" name+filename
        f size := size
        f datetime := datetime year month day hour minute second 0
        f status := success
        files append addressof:f
      eif (l parse any:rights _ any _  any _ any _ size _ any:ascii_month _ day _ hour ":" minute _ any:filename) or (l parse any:rights _ any _  any _ any _ size _ any:ascii_month _ day _ year _ any:filename)
        # Unix ls -l format
        if filename<>"." and filename<>".."
          var Link:FileInfo f :> new FileInfo
          if (filename parse any:(var Str filename1) "->" any:(var Str link))
            filename := filename1
            if link:len>0 and (link link:len-1 1)="/"
              filename := filename+"/"
            f options := "link "+string:link
          f name := name+filename+(shunt (rights 0 1)="d" "/" "")
          f size := size
          f status := success
          files append addressof:f
          if not f:is_directory
            names append addressof:(new Str filename)
            info append addressof:f
      else
        ftp:log trace "unsupported listing"
  else
    ftp command "NLST"+(shunt sub<>"" " "+sub "")
    ftp connect_data_stream1
    if ftp:status>=400
      ftp close_data_stream
      deconnect ftp
      return
    ftp connect_data_stream2
    while not (ftp:data_stream atend)
      var Str l := ftp:data_stream readline
      var Link:FileInfo f :> new FileInfo
      f name := name+l
      f status := success
      files append addressof:f
      names append addressof:(new Str filename)
      info append addressof:f
  ftp close_data_stream
  ftp status
  var Pointer:Arrow c1 :> names first
  var Pointer:Arrow c2 :> info first
  while c1<>null
    var Pointer:Str name2 :> c1 map Str
    var Pointer:FileInfo info2 :> c2 map FileInfo
    ftp command "MDTM "+path+name2
    if (ftp:status2 parse (var Int retcode) _ any:(var Str dt)) and retcode<400
      if ((dt 0 4) parse year) and ((dt 4 2) parse month) and ((dt 6 2) parse day) and ((dt 8 2) parse hour) and ((dt 10 2) parse minute) and ((dt 12 2) parse second)
        info2 datetime := datetime year month day hour minute second 0
    if eccentric
      ftp command "SIZE "+path+name2
      if (ftp:status2 parse (var Int retcode) _ size) and retcode<400
        info2 size := size
      ftp command "CWD "+path+name2
      if ftp:status<300
        info2 name += "/"
    c1 :> names next c1  
    c2 :> info next c2
  deconnect ftp

method fs query name options flags info -> status 
  arg_rw FtpFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw FileInfo info ; arg ExtendedStatus status
  var Int i := name search_last "/" -1
  list (name 0 i+1) (name i+1 name:len) options flags (var List files)
  var Pointer:Arrow c :> files first
  while c<>null
    if (c map FileInfo):name=name
      (c map FileInfo) name := info name
      info := c map FileInfo
      return success
    c :> files next c
  return failure

method fs list name options flags files -> supported_flags
  arg_rw FtpFileSystem fs ; arg Str name options ; arg Int flags supported_flags ; arg_rw List files
  supported_flags := 0
  list name "" options flags files


method fs open name options flags stream support -> status
  arg_rw FtpFileSystem fs ; arg Str name options ; arg Int flags ; arg_rw Stream stream support ; arg ExtendedStatus status
  if (name parse "//" any:(var Str server) "/" any:(var Str path))
    path := "/"+path
  eif (name parse "/" any:(var Str path))
    server := "localhost" ; path := "/"+path
  else
    return failure
  var Int port
  if (server eparse any:(var Str server1) ":" port)
    server := server1
  else
    port := 21
  var Str user := options option "user" Str
  var Str password := options option "password" Str
  if not (options option "user")
    user := "anonymous"
  if not (options option "password")
    password := computer_name+"@"+computer_domain
  if (flags .and. in_out)<>in and (flags .and. in_out)<>out
    return failure
  var Link:FtpConnection ftp :> connect server port user password not (options option "no_connection_cache")
  if not exists:ftp
    return failure
  ftp passive := not (options option "active")
  ftp open_data_stream
  ftp command (shunt (flags .and. in_out)=in "RETR " "STOR ")+path
  ftp connect_data_stream1
  if ftp:status<400
    ftp connect_data_stream2
    var Link:FtpStreamDriver drv :> new FtpStreamDriver
    drv connection :> ftp
    drv socket :> ftp:data_stream:stream_driver
    stream stream_driver :> drv
    stream stream_handle := ftp:data_stream stream_handle
    status := success
  else
    ftp close_data_stream
    deconnect ftp
    status := failure


method fs configure filename options command -> status
  arg_rw FtpFileSystem fs ; arg Str filename options command ; arg ExtendedStatus status
  if (filename parse "//" any:(var Str server) "/" any:(var Str path))
    path := "/"+path
  eif (filename parse "/" any:(var Str path))
    server := "localhost" ; path := "/"+path
  else
    return failure
  var Int port
  if (server eparse any:(var Str server1) ":" port)
    server := server1
  else
    port := 21
  var Str user := options option "user" Str
  var Str password := options option "password" Str
  if not (options option "user")
    user := "anonymous"
  if not (options option "password")
    password := computer_name+"@"+computer_domain
  var Link:FtpConnection ftp :> connect server port user password not (options option "no_connection_cache")
  if not exists:ftp
    return failure
  status := success
  var CBool some := false
  if (command option "mkdir")
    some := true
    ftp command "MKD "+path
    if ftp:status>=400
      status := failure
  if (command option "rmdir")
    some := true
    ftp command "RMD "+path
    if ftp:status>=400
      status := failure
  if (command option "delete")
    some := true
    ftp command "DELE "+path
    if ftp:status>=400
      status := failure
  if not some
    status := failure
  deconnect ftp


#----------------------------------------------------------------


gvar FtpFileSystem ftp_file_system
pliant_multi_file_system mount "ftp:" "" ftp_file_system