[WK] a VFS that allows creating volumes that are actually mapped using a Tcl command. package provide vfs::map 0.5 package require vfs 1.0 # This works for basic operations, but has not been very debugged. namespace eval vfs::map {} proc vfs::map::Mount {args} { set command [lindex $args end-1] set local [lindex $args end] if {![catch {vfs::filesystem info $command}]} { vfs::unmount $command } eval [concat [list vfs::filesystem mount] [lrange $args 0 end-2] [list $local [list vfs::map::handler $command]]] # Register command to unmount vfs::RegisterMount $local [list ::vfs::map::Unmount $command] return $local } proc vfs::map::Unmount {command local} { vfs::filesystem unmount $local } proc vfs::map::handler {command cmd root relative actualpath args} { if {$cmd == "matchindirectory"} { eval [list $cmd $command $relative $actualpath] $args } else { eval [list $cmd $command $relative] $args } } # If we implement the commands below, we will have a perfect # virtual file system for remote http sites. proc vfs::map::getFileName {name} { upvar mapcommand mapcommand return [eval [concat $mapcommand] [list $name]] } proc vfs::map::stat {mapcommand name} { ::vfs::log "stat $name" file stat [getFileName $name] a return [array get a] } proc vfs::map::access {mapcommand name mode} { ::vfs::log "access $name $mode" vfs::filesystem posixerror $::vfs::posix(EROFS) return 1 } # We've chosen to implement these channels by using a memchan. # The alternative would be to use temporary files. proc vfs::map::open {mapcommand name mode permissions} { set permissions [format 0%03o $permissions] if {$mode == ""} {set mode "r"} ::vfs::log "open $name $mode $permissions" set filed [::open [getFileName $name] $mode $permissions] return [list $filed [list vfs::map::_onclose $mode $mapcommand $filed]] } proc vfs::map::matchindirectory {mapcommand path actualpath pattern type} { ::vfs::log "matchindirectory $path $pattern $type" set rc [list] foreach res [vfs::matchCorrectTypes $type [glob -tails -nocomplain -directory [getFileName $path] $pattern]] { lappend rc [file join $actualpath $res] } return $rc } proc vfs::map::createdirectory {mapcommand name} { ::vfs::log "createdirectory $name" file mkdir [getFileName $name] } proc vfs::map::removedirectory {mapcommand name recursive} { ::vfs::log "removedirectory $name" vfs::filesystem posixerror $::vfs::posix(EROFS) file delete [getFileName $name] } proc vfs::map::deletefile {mapcommand name} { ::vfs::log "deletefile $mapcommand$name" file delete [getFileName $name] } proc vfs::map::fileattributes {mapcommand path args} { ::vfs::log "fileattributes $args" switch -- [llength $args] { 0 { # list strings return [list] } 1 { # get value vfs::filesystem posixerror $::vfs::posix(EROFS) } 2 { # set value vfs::filesystem posixerror $::vfs::posix(EROFS) } } } proc vfs::map::utime {mapcommand path actime mtime} { vfs::filesystem posixerror $::vfs::posix(EROFS) } proc vfs::map::_onclose {mapcommand filename filed} { } # handlers proc vfs::map::handleMultidir {args} { set dirs [::lrange $args 0 end-1] set relativename [::lindex $args end] set split [::file split $relativename] set rc [file join [lindex $dirs 0] $relativename] for {set i 0} {$i < [llength $split]} {incr i} { foreach dir $dirs { set rname [eval [concat [list ::file join $dir] [lrange $split 0 $i]]] if {[file exists $rname]} { set rc [eval [concat [list ::file join $rname] [lrange $split [expr {$i+1}] end]]] } } } return $rc } For example on Windows: vfs::map::Mount -volume [concat [list vfs::map::handleMultidir] [split $::env(PATH) \;]] PATH: and on UNIX: vfs::map::Mount -volume [concat [list vfs::map::handleMultidir] [split $::env(PATH) :]] PATH: Creates a virtual mapping by which you can easily do: if {![file exists PATH:dqkit.exe]} { puts "dqkit.exe not in PATH." } It can also be used to map multiple directories to one virtual directory. Note that globbing does not work as one would expect - it should actually join globs, but it does not. This idea is based on Symbian's ''?:'' virtual mapping.