[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://foo@bar.org: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 "-group" $attribute ] {
				set command "chgrp $value $fileName"
			} elseif ![string first "-owner" $attribute ] {
				set command "chown $value $fileName"
			} elseif ![string first "-permissions" $attribute ] {
				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 "-group" $attribute ] {
					return [lindex $returnValue 1]
				} elseif ![string first "-owner" $attribute ] {
					return [lindex $returnValue 0]
				} elseif ![string first "-permissions" $attribute ] {
					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 {}
	
	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)"}

	set command [string map {> \">\" | \"|\"} $params(command)]
	return "rsh $user $params(host) $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)"}

	set command [string map {> \">\" | \"|\"} $params(command)]
	return "ssh $port $user $params(host) $command"
 }

 }
 # end namespace eval ::vfs::template::fish::transport
----
[Category VFS]