1 2package provide vfs::ftp 1.0 3 4package require vfs 1.0 5package require ftp 6 7namespace eval vfs::ftp {} 8 9proc vfs::ftp::Mount {dirurl local} { 10 set dirurl [string trim $dirurl] 11 ::vfs::log "ftp-vfs: attempt to mount $dirurl at $local" 12 if {[string index $dirurl end] != "/"} { 13 ::vfs::log "ftp-vfs: adding missing directory delimiter to mount point" 14 append dirurl "/" 15 } 16 17 set urlRE {(?:ftp://)?(?:([^@:]*)(?::([^@]*))?@)?([^/:]+)(?::([0-9]*))?/(.*/)?$} 18 if {![regexp $urlRE $dirurl - user pass host port path]} { 19 return -code error "Sorry I didn't understand\ 20 the url address \"$dirurl\"" 21 } 22 23 if {![string length $user]} { 24 set user anonymous 25 } 26 27 if {![string length $port]} { 28 set port 21 29 } 30 31 set fd [::ftp::Open $host $user $pass -port $port -output ::vfs::ftp::log] 32 if {$fd == -1} { 33 error "Mount failed" 34 } 35 36 if {$path != ""} { 37 if {[catch { 38 ::ftp::Cd $fd $path 39 } err]} { 40 ftp::Close $fd 41 error "Opened ftp connection, but then received error: $err" 42 } 43 } 44 45 if {![catch {vfs::filesystem info $dirurl}]} { 46 # unmount old mount 47 ::vfs::log "ftp-vfs: unmounted old mount point at $dirurl" 48 vfs::unmount $dirurl 49 } 50 ::vfs::log "ftp $host, $path mounted at $fd" 51 vfs::filesystem mount $local [list vfs::ftp::handler $fd $path] 52 # Register command to unmount 53 vfs::RegisterMount $local [list ::vfs::ftp::Unmount $fd] 54 return $fd 55} 56 57# Need this because vfs::log takes just one argument 58proc vfs::ftp::log {args} { 59 ::vfs::log $args 60} 61 62proc vfs::ftp::Unmount {fd local} { 63 vfs::filesystem unmount $local 64 ::ftp::Close $fd 65} 66 67proc vfs::ftp::handler {fd path cmd root relative actualpath args} { 68 if {$cmd == "matchindirectory"} { 69 eval [list $cmd $fd $relative $actualpath] $args 70 } else { 71 eval [list $cmd $fd $relative] $args 72 } 73} 74 75proc vfs::ftp::attributes {fd} { return [list "state"] } 76proc vfs::ftp::state {fd args} { 77 vfs::attributeCantConfigure "state" "readwrite" $args 78} 79 80# If we implement the commands below, we will have a perfect 81# virtual file system for remote ftp sites. 82 83proc vfs::ftp::stat {fd name} { 84 ::vfs::log "stat $name" 85 if {$name == ""} { 86 return [list type directory mtime 0 size 0 mode 0777 ino -1 \ 87 depth 0 name "" dev -1 uid -1 gid -1 nlink 1] 88 } 89 # get information on the type of this file 90 set ftpInfo [_findFtpInfo $fd $name] 91 if {$ftpInfo == ""} { 92 vfs::filesystem posixerror $::vfs::posix(ENOENT) 93 } 94 ::vfs::log $ftpInfo 95 set perms [lindex $ftpInfo 0] 96 if {[string index $perms 0] == "d"} { 97 lappend res type directory size 0 98 set mtime 0 99 } else { 100 lappend res type file size [ftp::FileSize $fd $name] 101 set mtime [ftp::ModTime $fd $name] 102 } 103 lappend res dev -1 uid -1 gid -1 nlink 1 depth 0 \ 104 atime $mtime ctime $mtime mtime $mtime mode 0777 105 return $res 106} 107 108proc vfs::ftp::access {fd name mode} { 109 ::vfs::log "ftp-access $name $mode" 110 if {$name == ""} { return 1 } 111 set info [_findFtpInfo $fd $name] 112 if {[string length $info]} { 113 return 1 114 } else { 115 vfs::filesystem posixerror $::vfs::posix(ENOENT) 116 } 117} 118 119# We've chosen to implement these channels by using a memchan. 120# The alternative would be to use temporary files. 121proc vfs::ftp::open {fd name mode permissions} { 122 ::vfs::log "open $name $mode $permissions" 123 # return a list of two elements: 124 # 1. first element is the Tcl channel name which has been opened 125 # 2. second element (optional) is a command to evaluate when 126 # the channel is closed. 127 switch -glob -- $mode { 128 "" - 129 "r" { 130 ftp::Get $fd $name -variable tmp 131 132 set filed [vfs::memchan] 133 fconfigure $filed -translation binary 134 puts -nonewline $filed $tmp 135 136 fconfigure $filed -translation auto 137 seek $filed 0 138 return [list $filed] 139 } 140 "a" { 141 # Try to append nothing to the file 142 if {[catch [list ::ftp::Append $fd -data "" $name] err] || !$err} { 143 error "Can't open $name for appending" 144 } 145 146 set filed [vfs::memchan] 147 return [list $filed [list ::vfs::ftp::_closing $fd $name $filed Append]] 148 } 149 "w*" { 150 # Try to write an empty file 151 if {[catch [list ::ftp::Put $fd -data "" $name] err] || !$err} { 152 error "Can't open $name for writing" 153 } 154 155 set filed [vfs::memchan] 156 return [list $filed [list ::vfs::ftp::_closing $fd $name $filed Put]] 157 } 158 default { 159 return -code error "illegal access mode \"$mode\"" 160 } 161 } 162} 163 164proc vfs::ftp::_closing {fd name filed action} { 165 seek $filed 0 166 set contents [read $filed] 167 set trans [fconfigure $filed -translation] 168 if {$trans == "binary"} { 169 set oldType [::ftp::Type $fd] 170 ::ftp::Type $fd binary 171 } 172 if {![::ftp::$action $fd -data $contents $name]} { 173 # Would be better if we could be more specific here, with 174 # one of ENETRESET ENETDOWN ENETUNREACH or whatever. 175 vfs::filesystem posixerror $::vfs::posix(EIO) 176 #error "Failed to write to $name" 177 } 178 if {[info exists oldType]} { 179 ::ftp::Type $fd $oldType 180 } 181} 182 183proc vfs::ftp::_findFtpInfo {fd name} { 184 ::vfs::log "findFtpInfo $fd $name" 185 set ftpList [ftp::List $fd [file dirname $name]] 186 foreach p $ftpList { 187 foreach {pname other} [_parseListLine $p] {} 188 if {$pname == [file tail $name]} { 189 return $other 190 } 191 } 192 return "" 193} 194 195# Currently returns a list of name and a list of other 196# information. The other information is currently a 197# list of: 198# () permissions 199# () size 200proc vfs::ftp::_parseListLine {line} { 201 # Check for filenames with spaces 202 if {[regexp {([^ ]|[^0-9] )+$} $line name]} { 203 # Check for links 204 if {[set idx [string first " -> " $name]] != -1} { 205 incr idx -1 206 set name [string range $name 0 $idx] 207 } 208 } 209 regsub -all "\[ \t\]+" $line " " line 210 set items [split $line " "] 211 212 if {![info exists name]} {set name [lindex $items end]} 213 lappend other [lindex $items 0] 214 if {[string is integer [lindex $items 4]]} { 215 lappend other [lindex $items 4] 216 } 217 218 return [list $name $other] 219} 220 221proc vfs::ftp::matchindirectory {fd path actualpath pattern type} { 222 ::vfs::log "matchindirectory $fd $path $actualpath $pattern $type" 223 set res [list] 224 if {![string length $pattern]} { 225 # matching a single file 226 set ftpInfo [_findFtpInfo $fd $path] 227 if {$ftpInfo != ""} { 228 # Now check if types match 229 set perms [lindex $ftpInfo 0] 230 if {[string index $perms 0] == "d"} { 231 if {[::vfs::matchDirectories $type]} { 232 lappend res $actualpath 233 } 234 } else { 235 if {[::vfs::matchFiles $type]} { 236 lappend res $actualpath 237 } 238 } 239 } 240 } else { 241 # matching all files in the given directory 242 set ftpList [ftp::List $fd $path] 243 ::vfs::log "ftpList: $ftpList" 244 245 foreach p $ftpList { 246 foreach {name perms} [_parseListLine $p] {} 247 if {![string match $pattern $name]} { 248 continue 249 } 250 if {[::vfs::matchDirectories $type]} { 251 if {[string index $perms 0] == "d"} { 252 lappend res [file join $actualpath $name] 253 } 254 } 255 if {[::vfs::matchFiles $type]} { 256 if {[string index $perms 0] != "d"} { 257 lappend res [file join $actualpath $name] 258 } 259 } 260 261 } 262 } 263 264 return $res 265} 266 267proc vfs::ftp::createdirectory {fd name} { 268 ::vfs::log "createdirectory $name" 269 if {![ftp::MkDir $fd $name]} { 270 # Can we be more specific here? 271 vfs::filesystem posixerror $::vfs::posix(EACCES) 272 } 273} 274 275proc vfs::ftp::removedirectory {fd name recursive} { 276 ::vfs::log "removedirectory $name $recursive" 277 if {![ftp::RmDir $fd $name]} { 278 # Can we be more specific here? 279 if {$recursive} { 280 vfs::filesystem posixerror $::vfs::posix(EACCES) 281 } else { 282 vfs::filesystem posixerror $::vfs::posix(EACCES) 283 } 284 } 285} 286 287proc vfs::ftp::deletefile {fd name} { 288 ::vfs::log "deletefile $name" 289 if {![ftp::Delete $fd $name]} { 290 # Can we be more specific here? 291 vfs::filesystem posixerror $::vfs::posix(EACCES) 292 } 293} 294 295proc vfs::ftp::fileattributes {fd path args} { 296 ::vfs::log "fileattributes $args" 297 switch -- [llength $args] { 298 0 { 299 # list strings 300 return [list] 301 } 302 1 { 303 # get value 304 set index [lindex $args 0] 305 vfs::filesystem posixerror $::vfs::posix(ENODEV) 306 } 307 2 { 308 # set value 309 set index [lindex $args 0] 310 set val [lindex $args 1] 311 vfs::filesystem posixerror $::vfs::posix(ENODEV) 312 } 313 } 314} 315 316proc vfs::ftp::utime {fd path actime mtime} { 317 # Will throw an error if ftp package is old and only 318 # handles 2 arguments. But that is ok -- Tcl will give the 319 # user an appropriate error message. 320 ftp::ModTime $fd $path $mtime 321} 322 323