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