1#/usr/bin/env tclsh 2 3if 0 { 4######################## 5 6templatevfs.tcl -- 7 8Written by Stephen Huntley (stephen.huntley@alum.mit.edu) 9License: Tcl license 10Version 1.5.4 11 12The template virtual filesystem is designed as a prototype on which to build new virtual 13filesystems. Only a few simple, abstract procedures have to be overridden to produce a new 14vfs, requiring no knowledge of the Tclvfs API. 15 16In addition, several behind-the-scenes functions are provided to make new vfs's more stable and 17scalable, including file information caching and management of close callback errors. 18 19The template vfs provides a useful function of its own, it mirrors a real directory to a 20virtual location, analogous to a Unix-style link. 21 22Usage: mount ?-cache <number>? ?-volume? <existing directory> <virtual directory> 23 24Options: 25 26-cache 27Sets number of seconds file stat and attributes information will dwell in cache after 28being retrieved. Default is 2. Setting value of 0 will essentially disable caching. This 29value is viewable and editable after mount by calling "file attributes <virtual directory> -cache ?value?" 30 31-volume 32Volume specified in virtual directory pathname will be mounted as a virtual volume. 33 34The above options are inherited by all virtual filesystems built using the template. 35 36Side effects: Files whose names begin with ".vfs_" will be ignored and thus invisible to the 37user unless the variable ::vfs::template::vfs_retrieve exists. 38 39Sourcing this file will run code that overloads the exit command with 40a procedure that ensures that all vfs's are explicitly unmounted before the 41shell terminates. 42 43When a vfs built on the template vfs is mounted, the mount command options are stored in an array named 44vfs::template::mount with the virtual mount point as the array index name. Thus a vfs can be re-mounted 45by executing "eval" on the contents of the array element whose index is the vfs's virtual mount point. 46 47######################## 48} 49 50package require vfs 1.0 51 52# force sourcing of vfsUtils.tcl: 53set vfs::posix(load) x 54vfs::posixError load 55unset vfs::posix(load) 56 57package provide vfs::template 1.5.4 58 59namespace eval ::vfs::template { 60 61if 0 { 62######################## 63 64In order to create a new virtual filesystem: 65 661. copy the contents of this namespace eval statement to a 67new namespace eval statement with a unique new namespace defined 68 692. rewrite the copied procedures to retrieve and handle virtual filesystem 70information as desired and return it in the same format as the given native 71file commands. 72 73######################## 74} 75 76package require vfs::template 1.5 77 78# read template procedures into current namespace. Do not edit: 79foreach templateProc [namespace eval ::vfs::template {info procs}] { 80 set infoArgs [info args ::vfs::template::$templateProc] 81 set infoBody [info body ::vfs::template::$templateProc] 82 proc $templateProc $infoArgs $infoBody 83} 84 85# edit following procedures: 86 87# Do not close channel within this procedure (will cause error). Simply 88# read info from channel as needed and return. 89proc close_ {channel} {return} 90 91# Variable $time is always defined. These procs only set time values. 92proc file_atime {file time} {file atime $file $time} 93proc file_mtime {file time} {file mtime $file $time} 94 95# Variables $attribute and $args may or may not be empty. 96# If $attribute is empty so is $args (retrieve all attributes and values). 97# If $args only is empty, retrieve value of specified attribute. 98# If $args has a value, set it as value of specified attribute. 99proc file_attributes {file {attribute {}} args} {eval file attributes \$file $attribute $args} 100 101# Variable $file may be a file or directory. 102# This proc only called if it is certain that deletion is the correct action. 103proc file_delete {file} {file delete -force -- $file} 104 105proc file_executable {file} {file executable $file} 106proc file_exists {file} {file exists $file} 107proc file_mkdir {file} {file mkdir $file} 108proc file_readable {file} {file readable $file} 109proc file_stat {file array} {upvar $array fs ; file stat $file fs} 110proc file_writable {file} {file writable $file} 111 112# All variables are always defined. 113# Return list of filenames only, not full pathnames. 114proc glob_ {directory dir nocomplain tails types typeString dashes pattern} {glob -directory $dir -nocomplain -tails -types $typeString -- $pattern} 115proc open_ {file mode} {open $file $mode} 116 117 118# MountProcedure is called once each time a vfs is newly mounted. 119proc MountProcedure {args} { 120 upvar volume volume 121 122# take real and virtual directories from command line args. 123 set to [lindex $args end] 124 if [string equal $volume {}] {set to [::file normalize $to]} 125 set path [::file normalize [lindex $args end-1]] 126 127# make sure mount location exists: 128 ::file mkdir $path 129 130# add custom handling for new vfs args here. 131 132# return two-item list consisting of real and virtual locations. 133 lappend pathto $path 134 lappend pathto $to 135 return $pathto 136} 137 138 139proc UnmountProcedure {path to} { 140# add custom unmount handling of new vfs elements here. 141 142 return 143} 144 145} 146# end namespace ::vfs::template 147 148 149# Below are template API procedures; there should be no need to edit them. 150 151namespace eval ::vfs::template { 152 153proc mount {args} { 154 155# handle template command line args: 156 set volume [lindex $args [lsearch $args "-volume"]] 157 set cache 2 158 if {[set cacheIndex [lsearch $args "-cache"]] != -1} {set cache [lindex $args [incr cacheIndex]]} 159 set args [string map "\" -volume \" { } \" -cache $cache \" { }" " $args "] 160# run unmount procedure if mount exists: 161 set to [lindex $args end] 162 if [info exists ::vfs::_unmountCmd($to)] {$::vfs::_unmountCmd($to) $to} 163 164# call custom mount procedure: 165 # ensure files named ".vfs_*" can be opened 166 set ::vfs::template::vfs_retrieve 1 167 168 set pathto [eval MountProcedure $args] 169 170 # re-hide ".vfs_*" files 171 unset -nocomplain ::vfs::template::vfs_retrieve 172 173 set path [lindex $pathto 0] 174 set to [lindex $pathto 1] 175 if [string equal $volume {}] {set to [file normalize $to]} 176 177# preserve mount info for later duplication if desired: 178 set ::vfs::template::mount($to) "[namespace current]::mount $volume -cache $cache $args" 179 180# if virtual location still mounted, unmount it by force: 181 if {[lsearch [::vfs::filesystem info] $to] != -1} {::vfs::filesystem unmount $to} 182 array unset ::vfs::_unmountCmd $to 183 184# set file info cache dwell time value: 185 set [namespace current]::cache($to) $cache 186 187# register location with Tclvfs package: 188 set div {} 189 if {$volume ne {}} { 190 if {[string index $to end] ne "/"} { 191 set div / 192 } 193 } 194 eval ::vfs::filesystem mount $volume \$to$div \[list [namespace current]::handler \$path\] 195 ::vfs::RegisterMount $to [list [namespace current]::unmount] 196 197# ensure close callback background error appears at script execution level: 198 trace remove execution ::close leave ::vfs::template::CloseTrace 199 trace remove execution ::file leave ::vfs::template::FileTrace 200 trace add execution ::close leave vfs::template::CloseTrace 201 trace add execution ::file leave vfs::template::FileTrace 202 203 return $to 204} 205 206# undo Tclvfs API hooks: 207proc unmount {to} { 208 if {[lsearch [::vfs::filesystem info] $to] < 0} { 209 set to [::file normalize $to] 210 } 211 set path [lindex [::vfs::filesystem info $to] end] 212 213# call custom unmount procedure: 214 set ::vfs::template::vfs_retrieve 1 215 UnmountProcedure $path $to 216 unset -nocomplain ::vfs::template::vfs_retrieve 217 218 ::vfs::filesystem unmount $to 219 array unset ::vfs::_unmountCmd [::file normalize $to] 220 221# clear file info caches: 222 CacheClear $to 223} 224 225# vfshandler command required by Tclvfs API: 226proc handler {path cmd root relative actualpath args} { 227# puts [list $path $root $relative $cmd $args [namespace current]] 228 229 set fileName [::file join $path $relative] 230 set virtualName [::file join $root $relative] 231 switch -- $cmd { 232 access { 233 set mode [lindex $args 0] 234 set error [catch {Access $path $root $relative $actualpath $mode}] 235 if $error {::vfs::filesystem posixerror $::vfs::posix(EACCES) ; return -code error $::vfs::posix(EACCES)} 236 } 237 createdirectory { 238 CreateDirectory $path $root $relative $actualpath 239 CacheClear $virtualName 240 } 241 deletefile { 242 DeleteFile $path $root $relative $actualpath 243 CacheClear $virtualName 244 } 245 fileattributes { 246 set index [lindex $args 0] 247 if {[llength $args] > 1} {set value [lindex $args 1]} 248 set extra {} 249 if [string equal $relative {}] {eval set extra \"-cache \$[namespace current]::cache(\$root)\"} 250 251 # try to get values from cache first: 252 array set attributes [CacheGet [namespace current]::attributes $virtualName [set [namespace current]::cache($root)]] 253 # if not in cache, get them from file: 254 if [string equal [array get attributes] {}] { 255 array set attributes "[FileAttributes $path $root $relative $actualpath] $extra" 256 CacheSet [namespace current]::attributes $virtualName [array get attributes] 257 } 258 259 set attribute [lindex [lsort [array names attributes]] $index] 260 261 # if value given in args, set it and return: 262 if [info exists value] { 263 if [string equal $attribute "-cache"] { 264 set [namespace current]::cache($root) $value 265 } else { 266 FileAttributesSet $path $root $relative $actualpath $attribute $value 267 } 268 CacheClear $virtualName 269 return 270 } 271 272 # if attribute given in args, return its value: 273 if ![string equal $index {}] { 274 return $attributes($attribute) 275 } 276 # otherwise, just return all attribute names 277 return [lsort [array names attributes]] 278 } 279 matchindirectory { 280 set pattern [lindex $args 0] 281 set types [lindex $args 1] 282 return [MatchInDirectory $path $root $relative $actualpath $pattern $types] 283 } open { 284 # ensure files named ".vfs_*" can't be opened ordinarily: 285 if {![string first ".vfs_" [file tail $relative]] && ![info exists ::vfs::template::vfs_retrieve]} {vfs::filesystem posixerror $::vfs::posix(EACCES)} 286 287 set mode [lindex $args 0] 288 if {$mode == {}} {set mode r} 289 290 # workaround: Tclvfs can't handle channels in write-only modes; see Tclvfs bug #1004273 291 if {$mode == "w"} {set mode w+} 292 if {$mode == "a"} {set mode a+} 293 294 set permissions [lindex $args 1] 295 set channelID [Open $path $root $relative $actualpath $mode $permissions] 296 297 # ensure channel settings match file command defaults 298 set eofChar {{} {}} 299 if [string equal $::tcl_platform(platform) "windows"] {set eofChar "\x1a {}"} 300 fconfigure $channelID -encoding [encoding system] -eofchar $eofChar -translation auto 301 switch -glob -- $mode { 302 "" - 303 "r*" - 304 "w*" { 305 seek $channelID 0 306 } 307 "a*" { 308 seek $channelID 0 end 309 } 310 default { 311 ::vfs::filesystem posixerror $::vfs::posix(EINVAL) 312 return -code error $::vfs::posix(EINVAL) 313 } 314 } 315 316 set result $channelID 317 # designate handler as close callback command 318 lappend result [list [namespace current]::handler $path close $root $relative $actualpath $channelID $mode] 319 320 321 # make sure all interpreters can catch errors in close callback: 322 foreach int [interp slaves] { 323 InterpSeed $int 324 } 325 326 CacheClear $virtualName 327 return $result 328 } close { 329 set channelID [lindex $args 0] 330 set mode [lindex $args 1] 331 if [string equal $mode "r"] {return} 332 # never use real close command here, custom overloaded proc only. 333 set err [catch {close_ $channelID} result] 334 if $err {::vfs::template::closeerror $::errorInfo ; error $::errorInfo} 335 return 336 } 337 removedirectory { 338 set recursive [lindex $args 0] 339 if !$recursive { 340 if {[MatchInDirectory $path $root $relative $actualpath * 0] != {}} { 341 ::vfs::filesystem posixerror $::vfs::posix(EEXIST) 342 return -code error $::vfs::posix(EEXIST) 343 } 344 } 345 if {$relative == {}} {unmount $root ; return} 346 RemoveDirectory $path $root $relative $actualpath 347 CacheClear $virtualName 348 } 349 stat { 350 set stat [CacheGet [namespace current]::stat $virtualName [set [namespace current]::cache($root)]] 351 if ![string equal $stat ""] { 352 return $stat 353 } 354 set stat [Stat $path $root $relative $actualpath] 355 CacheSet [namespace current]::stat $virtualName $stat 356 return $stat 357 } 358 utime { 359 set atime [lindex $args 0] 360 set mtime [lindex $args 1] 361 Utime $path $root $relative $actualpath $atime $mtime 362 array unset [namespace current]::stat $virtualName,time ; array unset [namespace current]::stat $virtualName,value 363 } 364 } 365} 366 367# following commands carry out information processing requirements for each vfshandler subcommand: 368# note that all calls to file commands are redirected to simplified API procs at top of this script 369 370proc Access {path root relative actualpath mode} { 371 set fileName [::file join $path $relative] 372 set virtualName [::file join $root $relative] 373 set modeString [::vfs::accessMode $mode] 374 set modeString [split $modeString {}] 375 set modeString [string map "F exists R readable W writable X executable" $modeString] 376 set secs [clock seconds] 377 foreach mode $modeString { 378 set result [CacheGet [namespace current]::$mode $virtualName [set [namespace current]::cache($root)] $secs] 379 if [string equal $result ""] { 380 set result [eval file_$mode \$fileName] 381 CacheSet [namespace current]::$mode $virtualName $result $secs 382 } 383 if !$result {error error} 384 } 385 return 386} 387 388proc CreateDirectory {path root relative actualpath} { 389 file_mkdir [::file join $path $relative] 390} 391 392proc DeleteFile {path root relative actualpath} { 393 set fileName [::file join $path $relative] 394# file delete -force -- $fileName 395 file_delete $fileName 396} 397 398proc FileAttributes {path root relative actualpath} { 399 set fileName [::file join $path $relative] 400 return [file_attributes $fileName] 401} 402 403proc FileAttributesSet {path root relative actualpath attribute value} { 404 set fileName [::file join $path $relative] 405 file_attributes $fileName $attribute $value 406} 407 408proc MatchInDirectory {path root relative actualpath pattern types} { 409# special case: check for existence (see Tclvfs bug #1405317) 410 if [string equal $pattern {}] { 411 if ![::vfs::matchDirectories $types] {return {}} 412 return [::file join $root $relative] 413 } 414 415# convert types bitstring back to human-readable alpha string: 416 foreach {type shift} {b 0 c 1 d 2 p 3 f 4 l 5 s 6} { 417 if [expr {$types == 0 ? 1 : $types & (1<<$shift)}] {lappend typeString $type} 418 } 419 set pathName [::file join $path $relative] 420 421# get non-hidden files: 422 set globList [glob_ -directory $pathName -nocomplain -tails -types $typeString -- $pattern] 423# if underlying location is not itself a vfs, get hidden files (Tclvfs doesn't pass "hidden" type to handler) 424 if [catch {::vfs::filesystem info $path}] {set globList [concat $globList [glob_ -directory $pathName -nocomplain -tails -types "$typeString hidden" -- $pattern]]} 425 426# convert real path to virtual path: 427 set newGlobList {} 428 foreach gL $globList { 429 if {![string first ".vfs_" $gL] && ![info exists ::vfs::template::vfs_retrieve]} {continue} 430 set gL [::file join $root $relative $gL] 431 lappend newGlobList $gL 432 } 433 set newGlobList [lsort -unique $newGlobList] 434 return $newGlobList 435} 436 437proc Open {path root relative actualpath mode permissions} { 438 set fileName [::file join $path $relative] 439 set newFile 0 440 if ![file exists $fileName] {set newFile 1} 441 set channelID [open_ $fileName $mode] 442 if $newFile {catch {file_attributes $fileName -permissions $permissions}} 443 return $channelID 444} 445 446proc RemoveDirectory {path root relative actualpath} { 447 set fileName [::file join $path $relative] 448# file delete -force -- $fileName 449 file_delete $fileName 450} 451 452proc Stat {path root relative actualpath} { 453 file_stat [::file join $path $relative] fs 454 return [array get fs] 455} 456 457proc Utime {path root relative actualpath atime mtime} { 458 set fileName [::file join $path $relative] 459 file_atime $fileName $atime 460 file_mtime $fileName $mtime 461} 462 463# check value of ::errorInfo to ensure close callback didn't generate background 464# error; if it did, force error break. 465proc CloseTrace {commandString code result op} { 466 if {[info exists ::vfs::template::vfs_error] && ($::vfs::template::vfs_error != {})} { 467 set vfs_error $::vfs::template::vfs_error 468 closeerror {} 469 error $vfs_error 470 } 471 return 472} 473 474# file copy and file rename may trigger close callbacks internally, so check for close errors 475# after these commands complete. 476proc FileTrace {commandString code result op} { 477 if {[string map {copy {} rename {}} [lindex $commandString 1]] != {}} {return} 478 if {[info exists ::vfs::template::vfs_error] && ($::vfs::template::vfs_error != {})} { 479 set vfs_error $::vfs::template::vfs_error 480 closeerror {} 481 error $vfs_error 482 } 483 return 484} 485 486# ensure ::errorInfo from background errors makes it into every child interpreter 487# so CloseTrace and FileTrace can intercept it. 488 489proc closeerror {errorInfo} { 490 set ::vfs::template::vfs_error $errorInfo 491 foreach int [interp slaves] { 492 InterpSeed $int set ::vfs::template::vfs_error $::vfs::template::vfs_error 493 } 494} 495 496# seed all interpreters with trace structures necessary to intercept close callback errors: 497proc InterpSeed {interp args} { 498 interp eval $interp {namespace eval ::vfs::template {}} 499 $interp alias ::vfs::template::closeerror ::vfs::template::closeerror 500 $interp alias ::vfs::template::FileTrace ::vfs::template::FileTrace 501 $interp alias ::vfs::template::CloseTrace ::vfs::template::CloseTrace 502 interp eval $interp trace remove execution ::file leave ::vfs::template::FileTrace 503 interp eval $interp trace remove execution ::close leave ::vfs::template::CloseTrace 504 505 interp eval $interp trace add execution ::close leave ::vfs::template::CloseTrace 506 interp eval $interp trace add execution ::file leave ::vfs::template::FileTrace 507 508 interp eval $interp $args 509 foreach int [interp slaves $interp] { 510 InterpSeed $int $args 511 } 512} 513 514# cache management functions: 515proc CacheClear {file} { 516 foreach arr {exists readable writable executable stat attributes} { 517 array unset [namespace current]::$arr $file,time 518 array unset [namespace current]::$arr $file,value 519 array unset [namespace current]::$arr $file/* 520 } 521} 522 523proc CacheGet {array file cache args} { 524 if [string equal [array names $array $file,time] {}] {return} 525 if ![string equal $args {}] {set secs $args} else {set secs [clock seconds]} 526 set fileTime [lindex [array get $array $file,time] 1] 527 if {[expr $secs - $fileTime] < $cache} {return [lindex [array get $array $file,value] 1]} 528 array unset $array $file,time ; array unset $array $file,value 529 return 530} 531 532proc CacheSet {array file value args} { 533 if ![string equal $args {}] {set secs $args} else {set secs [clock seconds]} 534 set fileTime $file,time 535 array set $array [list $fileTime $secs] 536 set fileValue $file,value 537 array set $array [list $fileValue $value] 538} 539 540# map built-in file selection dialogs to pure Tk equivalents, so virtual 541# filesystems can be browsed with same-looking code: 542proc tk_getOpenFile {args} { 543 eval [eval list ::tk::dialog::file:: open $args] 544} 545 546proc tk_getSaveFile {args} { 547 eval [eval list ::tk::dialog::file:: save $args] 548} 549 550proc tk_chooseDirectory {args} { 551 eval [eval list ::tk::dialog::file::chooseDir:: $args] 552} 553 554# workaround for bug in tclkit: 555proc memchan {args} { 556 if {$::tcl_platform(platform) == "windows"} { 557 package require Memchan 558 set chan [uplevel 1 ::memchan $args] 559 return $chan 560 } else { 561 return [eval [linsert $args 0 ::vfs::memchan]] 562 } 563} 564 565} 566# end namespace eval ::vfs::template 567 568# overload exit command so that all vfs's are explicitly 569# unmounted before program termination: 570 571catch {rename ::exit ::vfs::template::exit} 572 573proc ::exit {args} { 574 foreach vfs [::vfs::filesystem info] { 575 if [catch {$::vfs::_unmountCmd([file normalize $vfs]) $vfs} result] { 576 puts "$vfs: $result" 577 } 578 } 579 ::vfs::template::exit [lindex $args 0] 580} 581 582