SEH -- 12/22/04:
# fishvfs.tcl -- # # A "FIles transferred over SHell" virtual filesystem # This is not an official "FISH" protocol client as described at: # http://mini.net/tcl/12792 # but it utilizes the same concept of turning any computer that offers # access via ssh, rsh or similar shell into a file server. # # This code requires that the template vfs (http://mini.net/tcl/11938) procedures # have already been sourced into tclsh. # # Usage: Mount ?-volume? \ # <remote directory> \ # an existing directory on the remote filesystem # ?-transport <protocol>? \ # can be ssh, rsh or plink # ?-user <username>? \ # remote computer login name # ?-password <password>? \ # remote computer login password # ?-host <remote hostname>? \ # remote computer domain name # ?-port <port number>? \ # override default port # <virtual mount dir or URL> # # examples: # # Mount / -transport ssh -user root -host tcl.tk /mnt/vfs/tcl # # Mount -volume /home/foo rsh://foo@localcomp # # Mount -volume / -password foopass plink://[email protected]:2323/remotemount # # The vfs can be mounted as a local directory, or as a URL in conjunction with # the "-volume" option. # # The URL can be of the form: # # transport://[user[:password]@]host[:port][/filename] # # Option switches can be used in conjunction with a URL to specify connection # information; the option switch values will override the URL values. # # After a channel opened for writing is closed, if a file named ~/.fish_close # exists on the remote computer it will be executed as a shell script in the # background (with the name of the file written as a command line argument), # allowing post-write processing. For example, .fish_close could be a script # that commits changes to a CVS repository. # # client configuration: # # The shell client must be in the PATH and configured for non-interactive # (no password prompt) use. # # The value of the -transport option is assumed to be the name of a handler # procedure which is called to handle the specifics of the particular client. # Handlers for the supported transports (ssh, rsh, plink) already exist. # New clients can be added simply by providing a suitable handler procedure. # # server configuration: # # The remote computer is assumed to have a bourne-type shell and the standard # GNU fileutils, but otherwise no configuration is needed. package require vfs 1 namespace eval ::vfs::template::fish {} proc ::vfs::template::fish::Mount {args} { eval [info body ::vfs::template::Mount] } namespace eval ::vfs::template::fish { proc MountProcedure {args} { foreach templateProc "Mount Unmount CloseTrace handler Access CreateDirectory DeleteFile FileAttributes FileAttributesSet MatchInDirectory Open RemoveDirectory Stat Utime" { set infoArgs [info args ::vfs::template::$templateProc] set infoBody [info body ::vfs::template::$templateProc] proc $templateProc $infoArgs $infoBody } if {[lindex $args 0] == "-volume"} { set args [lrange $args 1 end] set to [lindex $args end] } else { set to [file normalize [lindex $args end]] } set path [lindex $args 0] if [info exists ::vfs::_unmountCmd($to)] {::vfs::unmount $to} array unset ::vfs::_unmountCmd $to array set params [FileTransport $to] if {[llength $args] > 2} { set args [lrange $args 1 end-1] set argsIndex [llength $args] for {set i 0} {$i < $argsIndex} {incr i} { set arg [lindex $args $i] if {[string index $arg 0] == "-"} { set arg [string range $arg 1 end] set params($arg) [lindex $args [incr i]] } } } set [namespace current]::transport($to) [array get params] file mkdir $path lappend pathto $path lappend pathto $to return $pathto } proc UnmountProcedure {path to} { unset [namespace current]::transport($to) array unset ::vfs::_unmountCmd $to return } proc Close {channelID path root relative actualpath mode} { # Do not close the channel in the close callback! # It will crash Tcl! Honest! # The core will close the channel after you've taken what info you need from it. if [string equal $mode "r"] {return} # Ha ha ha! Try and stop me! close $channelID return } proc close {channelID} { upvar 1 root root upvar 1 path path upvar 1 relative relative set fileName [file join $path $relative] fconfigure $channelID -translation binary seek $channelID 0 end set channelSize [tell $channelID] set command "cat>'$fileName'\;cat>/dev/null" FileCommand $root $command stdin $channelID set command "ls -l '$fileName' | ( read a b c d x e\; echo \$x )" set fileSize [FileCommand $root $command] if {$channelSize != $fileSize} {error "couldn't save \"$fileName\": Input/output error" "Input/output error" {POSIX EIO {Input/output error}}} set command "nohup ~/.fish_close '$fileName' &" catch {FileCommand $root $command} return } proc file {args} { switch -- [lindex $args 0] { join - normalize - split - volume { return [eval ::file $args] } } upvar 1 to fileTo upvar 1 root fileRoot if [info exists fileTo] {set root $fileTo} if [info exists fileRoot] {set root $fileRoot} set fileName [lindex $args 1] set tail [::file tail $fileName] if [string equal $tail {}] {set tail $fileName} switch -- [lindex $args 0] { atime { set atime [lindex $args 2] set command "find '$fileName' -maxdepth 1 -name '$tail' -printf %A@\\\\n" if ![string equal $atime {}] { set atime [clock format $atime -format %Y%m%d%H%M.%S] set command "touch -a -c -t $atime '$fileName'" } } attributes { set attribute [lindex $args 2] set value [lindex $args 3] if {([string equal $attribute {}]) || ([string equal $value {}])} { set command "find $fileName -maxdepth 1 -name '$tail' -printf '%u %g %m\\n'" } elseif ![string first $attribute "-group"] { set command "chgrp $value $fileName" } elseif ![string first $attribute "-owner"] { set command "chown $value $fileName" } elseif ![string first $attribute "-permissions"] { set command "chmod $value $fileName" } } delete { set command "rm -f '$fileName'" if [string equal $fileName "-force"] { set dirName [lindex $args 2] set command "rm -rf '$dirName'" } } executable - exists - readable - writable { set type [string map {executable x exists e readable r writable w} [lindex $args 0]] set command "if \[ -$type '$fileName' \]\; then echo 1\; else echo 0\; fi" } mkdir { set command "mkdir -p '$fileName'" } mtime { set mtime [lindex $args 2] set command "find '$fileName' -maxdepth 1 -name '$tail' -printf %T@\\\\n" if ![string equal $mtime {}] { set mtime [clock format $mtime -format %Y%m%d%H%M.%S] set command "touch -c -m -t $mtime '$fileName'" } } stat { set arrayName [lindex $args 2] set command "find '$fileName' -maxdepth 1 -name '$tail' -printf '%A@ %C@ %G %i %m %T@ %n %s %U\\n' \; if \[ -d '$fileName' \]\; then echo 1\; else echo 0\; fi" if [info exists ::vfs::template::fish::stat($fileName)] { set returnValue $::vfs::template::fish::stat($fileName) unset ::vfs::template::fish::stat($fileName) } } } if ![info exists returnValue] {set returnValue [FileCommand $root $command]} set returnValue [string trim $returnValue] switch -- [lindex $args 0] { atime - mtime { if [string equal [lindex $args 2] {}] { return $returnValue } } attributes { if [string equal $attribute {}] { return "-group [lindex $returnValue 1] -owner [lindex $returnValue 0] -permissions [lindex $returnValue 2]" } if [string equal $value {}] { if ![string first $attribute "-group"] { return [lindex $returnValue 1] } elseif ![string first $attribute "-owner"] { return [lindex $returnValue 0] } elseif ![string first $attribute "-permissions"] { return [lindex $returnValue 2] } } } executable - exists - readable - writable { return $returnValue } stat { eval upvar 1 $arrayName\(mtime) mtime $arrayName\(gid) gid $arrayName\(nlink) nlink $arrayName\(atime) atime $arrayName\(mode) mode $arrayName\(type) type $arrayName\(ctime) ctime $arrayName\(uid) uid $arrayName\(ino) ino $arrayName\(size) size $arrayName\(dev) dev set atime [lindex $returnValue 0] set ctime [lindex $returnValue 1] set gid [lindex $returnValue 2] set ino [lindex $returnValue 3] set mode [lindex $returnValue 4] set mtime [lindex $returnValue 5] set nlink [lindex $returnValue 6] set size [lindex $returnValue 7] set uid [lindex $returnValue 8] set dir [lindex $returnValue 9] if $dir {set type directory} else {set type file} set dev 0 } } return } proc glob {args} { upvar 1 path path upvar 1 root root upvar 1 relative relative set pattern [lindex $args end] set args [string map {-nocomplain {}} $args] array set argsArray [lrange $args 0 end-1] set hidden 0 if {[lindex $argsArray(-types) end] == "hidden"} { set hidden 1 set argsArray(-types) [lrange $argsArray(-types) 0 end-1] } if $hidden {eval return \$[namespace current]::hidden(\$argsArray(-directory))} array unset [namespace current]::hidden $argsArray(-directory) set command "find '$argsArray(-directory)' -maxdepth 1 -mindepth 1 -type d -printf '%A@ %C@ %G %i %m %T@ %n %s %U \{%f\}\\n' \; echo / \; find '$argsArray(-directory)' -maxdepth 1 -type f -printf '%A@ %C@ %G %i %m %T@ %n %s %U \{%f\}\\n'" set returnValue [FileCommand $root $command] set returnValue [split $returnValue /] set dirs [lindex $returnValue 0] set dirs [string trim $dirs] set dirs [split $dirs \n] foreach dir $dirs { set dir [linsert $dir end-1 1] lappend newDirs $dir } set dirs $newDirs unset newDirs set files [lindex $returnValue 1] set files [string trim $files] set files [split $files \n] foreach file $files { set file [linsert $file end-1 0] lappend newFiles $file } set files $newFiles unset newFiles set dir [lsearch $argsArray(-types) "d"] set file [lsearch $argsArray(-types) "f"] incr dir ; incr file if $dir {set values $dirs} if $file {set values $files} if {$dir && $file} {set values [concat $dirs $files]} foreach fileName $values { set stat [lrange $fileName 0 end-1] set fileName [lindex $fileName end] set ::vfs::template::fish::stat([file join $path $relative $fileName]) $stat if [string equal $fileName ".fish_close"] {continue} if ![string match $pattern $fileName] {continue} if {[string index $fileName 0] == "."} {lappend ::vfs::template::fish::hidden($argsArray(-directory)) [file join $path $relative $fileName] ; continue} lappend fileNames [file join $path $relative $fileName] } return $fileNames } proc open {fileName mode} { upvar 1 root root set command "ls -l '$fileName' | ( read a b c d x e\; echo \$x )" if {([catch {set fileSize [FileCommand $root $command]}]) && ($mode == "r")} {error "couldn't open \"$fileName\": no such file or directory" "no such file or directory" {POSIX ENOENT {no such file or directory}}} set channelID [::vfs::memchan] set command "touch -a '$fileName'" FileCommand $root $command if [string equal $mode w] {return $channelID} fconfigure $channelID -translation binary set command "cat '$fileName'" FileCommand $root $command stdout $channelID seek $channelID 0 end set channelSize [tell $channelID] if {[info exists $fileSize] && ($channelSize != $fileSize)} {error "Input/output error" "Input/output error" {POSIX EIO {Input/output error}}} return $channelID } proc FileCommand {root command args} { array set params $::vfs::template::fish::transport($root) array set params $args set params(command) $command if ![info exists params(transport)] {set params(transport) local} set commandLine [eval ::vfs::template::fish::transport::\$params(transport) [array get params]] if [string equal $commandLine {}] {return} if [info exists params(stdin)] { set execID [eval ::open \"|$commandLine\" w] fconfigure $execID -translation binary seek $params(stdin) 0 puts -nonewline $execID [read $params(stdin)] ::close $execID return } if [info exists params(stdout)] { set execID [eval ::open \"|$commandLine\" r] fconfigure $execID -translation binary seek $params(stdout) 0 puts -nonewline $params(stdout) [read $execID] ::close $execID return } eval exec $commandLine } proc FileTransport {filename} { if {[string first : $filename] < 0} {return [list transport {} user {} password {} host {} port {} filename [file normalize $filename]]} if {[string first [string range $filename 0 [string first : $filename]] [file volume]] > -1} {return [list transport {} user {} password {} host {} port {} filename [file normalize $filename]]} set filename $filename/f set transport {} ; set user {} ; set password {} ; set host {} ; set port {} set transport {} ; set user {} ; set password {} ; set host {} ; set port {} regexp {(^[^:]+)://} $filename trash transport regsub {(^[^:]+://)} $filename "" userpasshost set userpass [lindex [split $userpasshost @] 0] set user $userpass regexp {(^[^:]+):(.+)$} $userpass trash user password if {[string first @ $userpasshost] == -1} {set user {} ; set password {}} regsub {([^/]+)(:[^/]+)(@[^/]+)} $filename \\1\\3 filename if [regexp {(^[^:]+)://([^/:]+)(:[^/:]*)*(.+$)} $filename trash transport host port filename] { regexp {([0-9]+)} $port trash port if {[string first [lindex [file split $filename] 1] [file volume]] > -1} {set filename [string range $filename 1 end]} } else { set host [lindex [split $filename /] 0] set filename [string range $filename [string length $host] end] set port [lindex [split $host :] 1] set host [lindex [split $host :] 0] } regexp {^.+@(.+)} $host trash host set filename [string range $filename 0 end-2] return [list transport $transport user $user password $password host $host port $port filename $filename ] } } # end namespace eval ::vfs::template::fish namespace eval ::vfs::template::fish::transport { proc local {command args} { return $command } proc plink {args} { array set params $args set port {} if ![string equal $params(port) {}] {set port "-P $params(port)"} return "plink -ssh $port -l $params(user) -batch -pw $params(password) $params(host) \$command" } proc rsh {args} { array set params $args set user {} if ![string equal $params(user) {}] {set user "-l $params(user)"} return "rsh $user $params(host) \"$params(command)\"" } proc ssh {args} { array set params $args set port {} if ![string equal $params(port) {}] {set port "-p $params(port)"} set user {} if ![string equal $params(user) {}] {set user "-l $params(user)"} return "ssh $port $user $params(host) \"$params(command)\"" } } # end namespace eval ::vfs::template::fish::transport
LV Any thought of submitting this to the tclvfs project?
SEH -- I don't know what the submission process is, but I would be happy to see it included if the tclvfs maintainers are interested.
LV I suspect that if you visit the sf.net web site for the package, you should find something like a web forum, mailing list, or feature request space for submitting suggestions like this.
12nov05 jcw - There's not really a mechanism in place to submit/accept VFS drivers in the TclVFS project. Would it be an idea to add VFS drivers to tcllib, instead of creating a new area? The question is really: is it ok to add packages to Tcllib which depend on TclVFS? (given that TcVFS, or some rewrite of it, is likely to become more central in Tcl anyway)
CL thinks it's OK to add packages to Tcllib which depend on TclVFS.
CL in fact looks forward to it.