1# -*- Tcl -*- $ 2 3package provide xotcl::comm::ftp 2.0 4package require xotcl::comm::httpAccess 5 6package require XOTcl 2.0 7 8namespace eval ::xotcl::comm::ftp { 9 namespace import ::xotcl::* 10 11 Class Ftp -superclass NetAccess -parameter {user passwd} 12 Ftp instproc initialize args { 13 #my showCall 14 my instvar port caching user passwd loginMsg resp blocksize 15 set port 21 16 set blocksize 1024 17 set caching 0 18 set user ftp 19 set passwd cineast@ 20 set loginMsg {} 21 set resp(connect) {220 provideUser} 22 set resp(provideUser) {331 providePasswd} 23 set resp(providePasswd) {230 loginFinished} 24 set resp(loginFinished) {227 pasv} 25 set resp(pasv) {200 type} 26 set resp(type-list) {150 list} 27 set resp(type-retr) {150 retr 550 retry-retrieve} 28 set resp(transfer) {226 transferDone} 29 next 30 } 31 Ftp instproc err {state reply} { 32 my abort "Error in $state: $reply" 33 } 34 Ftp instproc queryServer {query state} { 35 my instvar S 36 puts $S $query 37 flush $S 38 fileevent $S readable [::list [self] response $state] 39 } 40 Ftp instproc response {state} { 41 #my showCall 42 my instvar S code msg 43 set reply [gets $S] 44 #my showVars reply 45 if {[regexp {^([0-9]+)[-](.*)$} $reply _ code msg]} { 46 fileevent $S readable [::list [self] responseMulti $state] 47 } else { 48 regexp {^([0-9]+) (.*)$} $reply _ code msg 49 my responseEnd $state 50 } 51 } 52 Ftp instproc responseMulti {state} { 53 # multi line response 54 my instvar S code msg 55 set m [gets $S] 56 if {[regexp "^$code " $m]} { 57 my responseEnd $state 58 } else { 59 # try to strip code and dash 60 regexp "^$code-(.*)\$" $m _ m 61 append msg \n$m 62 } 63 } 64 Ftp instproc responseEnd {state} { 65 my instvar S code msg resp 66 fileevent $S readable {} 67 #puts stderr "code=$code, msg=<$msg>" 68 foreach {c newState} $resp($state) { 69 if {$c == $code} { return [my $newState] } 70 } 71 my err $state "expected=$resp($state), got $code $msg" 72 } 73 Ftp instproc GET {} { 74 my instvar S host port url 75 regexp {^(.*):([0-9]+)$} $host _ host port 76 my running 77 # rb running my $url ;# ??? 78 # proxy ? 79 set S [socket -async $host $port] 80 fconfigure $S -blocking false -translation {auto crlf} 81 fileevent $S readable [::list [self] response connect] 82 } 83 Ftp instproc provideUser {} { 84 my instvar user msg loginMsg 85 set loginMsg $msg 86 my queryServer "USER $user" provideUser 87 } 88 Ftp instproc providePasswd {} { 89 my instvar passwd 90 # if {[pwdManager requirePasswd "Ftp $user\@$host" $user password]} { 91 # my queryServer "PASS $password" providePasswd 92 # } 93 my queryServer "PASS $passwd" providePasswd 94 } 95 Ftp instproc loginFinished {} { 96 my instvar msg loginMsg 97 append loginMsg \n$msg 98 my queryServer "PASV" loginFinished 99 } 100 Ftp instproc pasv {} { 101 my instvar S D msg 102 set d {([0-9]+)} 103 if {[regexp "\[(]$d,$d,$d,$d,$d,$d" $msg _ 1 2 3 4 p1 p2]} { 104 if {[catch {set D [socket -async $1.$2.$3.$4 [expr {$p1*256 + $p2}]]} err 105 ]} { 106 return [my err $proc $err] 107 } 108 fconfigure $D -blocking no -translation binary 109 } else { 110 return [my err $proc $msg] 111 } 112 my queryServer "TYPE I" pasv 113 } 114 Ftp instproc type {} { 115 my instvar path 116 if {$path=={}} { 117 my queryServer "LIST" type-list 118 } elseif {[regexp /$ $path]} { 119 my queryServer "LIST $path" type-list 120 } else { 121 my queryServer "RETR $path" type-retr 122 } 123 } 124 Ftp instproc retry-retrieve {} { 125 my instvar path url 126 append url / 127 my queryServer "LIST $path/" type-list 128 } 129 Ftp instproc list {} { 130 my instvar S D contentType 131 set contentType text/dirlist 132 my headerDone 133 fileevent $S readable [::list [self] response transfer] 134 fileevent $D readable [::list [self] readData] 135 } 136 Ftp instproc read {} { 137 # the method read is called by the more general method readData 138 my instvar D block blocksize 139 if {[::eof $D]} { 140 set block "" 141 close $D 142 unset D 143 } else { 144 #puts stderr blocksize=$blocksize 145 set block [::read $D $blocksize] 146 #puts stderr read:[string length $block]bytes 147 } 148 } 149 Ftp instproc transferDone {} { 150 my instvar D S 151 if {[info exists D]} { 152 fileevent $S readable {} 153 set block "" 154 close $D 155 unset D 156 } 157 my finish 158 } 159 Ftp instproc retr {} { 160 my instvar S D msg totalsize contentType path 161 regexp {[(]([0-9]+)[ ]+[Bb]ytes} $msg _ totalsize 162 set contentType [Mime guessContentType $path] 163 my headerDone 164 if {[info exists S]} { 165 # file dialog was not canceled 166 fileevent $S readable [::list [self] response transfer] 167 fileevent $D readable [::list [self] readData] 168 fconfigure $D -translation binary 169 } 170 } 171 172 namespace export Ftp 173} 174 175namespace import ::xotcl::comm::ftp::* 176