# $Id: Ftp.xotcl,v 1.1.1.1 2004/05/23 22:50:39 neumann Exp $
package provide xotcl::comm::ftp 0.9
package require xotcl::comm::httpAccess

Class Ftp -superclass NetAccess -parameter {user passwd}
Ftp instproc initialize args {
  #my showCall
  my instvar port caching user passwd loginMsg resp blocksize
  set port 21
  set blocksize 1024
  set caching 0
  set user ftp
  set passwd cineast@
  set loginMsg {}
  set resp(connect)       {220 provideUser}
  set resp(provideUser)   {331 providePasswd}
  set resp(providePasswd) {230 loginFinished}
  set resp(loginFinished) {227 pasv}
  set resp(pasv)          {200 type}
  set resp(type-list)     {150 list}
  set resp(type-retr)     {150 retr 550 retry-retrieve}
  set resp(transfer)      {226 transferDone}
  next
}
Ftp instproc err {state reply} {
  my abort "Error in $state: $reply"
}
Ftp instproc queryServer {query state} {
  my instvar S
  puts $S $query
  flush $S
  fileevent $S readable [::list [self] response $state]
}
Ftp instproc response {state} {
  #my showCall
  my instvar S code msg
  set reply [gets $S]
  #my showVars reply
  if {[regexp {^([0-9]+)[-](.*)$} $reply _ code msg]} {
    fileevent $S readable [::list [self] responseMulti $state]
  } else {
    regexp {^([0-9]+) (.*)$} $reply _ code msg 
    my responseEnd $state
  }
}
Ftp instproc responseMulti {state} {
  # multi line response
  my instvar S code msg 
  set m [gets $S]
  if {[regexp "^$code " $m]} { 
    my responseEnd $state
  } else {
    # try to strip code and dash
    regexp "^$code-(.*)\$" $m _ m
    append msg \n$m
  }
}
Ftp instproc responseEnd {state} {
  my instvar S code msg resp
  fileevent $S readable {}
  #puts stderr "code=$code, msg=<$msg>"
  foreach {c newState} $resp($state) {
    if {$c == $code} { return [my $newState] }
  }
  my err $state "expected=$resp($state), got $code $msg"
}
Ftp instproc GET {} {
  my instvar S  host port url
  regexp {^(.*):([0-9]+)$} $host _ host port
  my running
  # rb running my $url ;# ???
  # proxy ?
  set S [socket -async $host $port]
  fconfigure $S -blocking false -translation {auto crlf}
  fileevent $S readable [::list [self] response connect]
}
Ftp instproc provideUser {} {
  my instvar user msg loginMsg
  set loginMsg $msg
  my queryServer "USER $user" provideUser
}
Ftp instproc providePasswd {} {
  my instvar passwd
#  if {[pwdManager requirePasswd "Ftp $user\@$host" $user password]} {
#    my queryServer "PASS $password" providePasswd
#  }
  my queryServer "PASS $passwd" providePasswd
}
Ftp instproc loginFinished {} {  
  my instvar msg loginMsg
  append  loginMsg \n$msg
  my queryServer "PASV" loginFinished
}
Ftp instproc pasv {} {
  my instvar S D msg
  set d {([0-9]+)}
  if {[regexp "\[(]$d,$d,$d,$d,$d,$d" $msg _ 1 2 3 4 p1 p2]} {
    if {[catch {set D [socket -async $1.$2.$3.$4 [expr {$p1*256 + $p2}]]} err
	]} {
      return [my err $proc $err] 
    }
    fconfigure $D -blocking no -translation binary
  } else {
    return [my err $proc $msg] 
  }
  my queryServer "TYPE I" pasv
}
Ftp instproc type {} {
  my instvar path
  if {$path=={}} {
    my queryServer "LIST" type-list
  } elseif {[regexp /$ $path]} { 
    my queryServer "LIST $path" type-list
  } else {
    my queryServer "RETR $path" type-retr
  }
}
Ftp instproc retry-retrieve {} {
  my instvar path url
  append url /
  my queryServer "LIST $path/" type-list
}
Ftp instproc list {} {
  my instvar S D contentType
  set contentType text/dirlist
  my headerDone
  fileevent $S readable [::list [self] response transfer]
  fileevent $D readable [::list [self] readData]
}
Ftp instproc read {} {
  # the method read is called by the more general method readData
  my instvar D block blocksize
  if {[::eof $D]} {
    set block ""
    close $D
    unset D
  } else {
    #puts stderr blocksize=$blocksize
    set block [::read $D $blocksize]
    #puts stderr read:[string length $block]bytes
  }
}
Ftp instproc transferDone {} {
  my instvar D S
  if {[info exists D]} {
    fileevent $S readable {}
    set block ""
    close $D
    unset D
  } 
  my finish
}
Ftp instproc retr {} {
  my instvar S D msg totalsize contentType path
  regexp {[(]([0-9]+)[ ]+[Bb]ytes} $msg _ totalsize
  set contentType [Mime guessContentType $path]
  my headerDone
  if {[info exists S]} {
    # file dialog was not canceled
    fileevent $S readable [::list [self] response transfer]
    fileevent $D readable [::list [self] readData]
    fconfigure $D -translation binary
  }
}