1# mk4vfs.tcl -- Mk4tcl Virtual File System driver 2# Copyright (C) 1997-2003 Sensus Consulting Ltd. All Rights Reserved. 3# Matt Newman <matt@sensus.org> and Jean-Claude Wippler <jcw@equi4.com> 4# 5# $Id: mk4vfs.tcl,v 1.43 2008/12/22 01:19:34 patthoyts Exp $ 6# 7# 05apr02 jcw 1.3 fixed append mode & close, 8# privatized memchan_handler 9# added zip, crc back in 10# 28apr02 jcw 1.4 reorged memchan and pkg dependencies 11# 22jun02 jcw 1.5 fixed recursive dir deletion 12# 16oct02 jcw 1.6 fixed periodic commit once a change is made 13# 20jan03 jcw 1.7 streamed zlib decompress mode, reduces memory usage 14# 01feb03 jcw 1.8 fix mounting a symlink, cleanup mount/unmount procs 15# 04feb03 jcw 1.8 whoops, restored vfs::mk4::Unmount logic 16# 17mar03 jcw 1.9 start with mode translucent or readwrite 17# 18oct05 jcw 1.10 add fallback to MK Compatible Lite driver (vfs::mkcl) 18 19# Removed provision of the backward compatible name. Moved to separate 20# file/package. 21package provide vfs::mk4 1.10.1 22package require vfs 23 24# need this so init failure in interactive mode does not mess up errorInfo 25if {[info exists env(VFS_DEBUG)] && [info commands history] == ""} { 26 proc history {args} {} 27} 28 29namespace eval vfs::mk4 { 30 proc Mount {mkfile local args} { 31 # 2005-10-19 switch to MK Compatible Lite driver if there is no Mk4tcl 32 if {[catch { package require Mk4tcl }]} { 33 package require vfs::mkcl 34 return [eval [linsert $args 0 vfs::mkcl::Mount $mkfile $local]] 35 } 36 37 if {$mkfile != ""} { 38 # dereference a symlink, otherwise mounting on it fails (why?) 39 catch { 40 set mkfile [file join [file dirname $mkfile] \ 41 [file readlink $mkfile]] 42 } 43 set mkfile [file normalize $mkfile] 44 } 45 set db [eval [list ::mk4vfs::_mount $mkfile] $args] 46 ::vfs::filesystem mount $local [list ::vfs::mk4::handler $db] 47 ::vfs::RegisterMount $local [list ::vfs::mk4::Unmount $db] 48 return $db 49 } 50 51 proc Unmount {db local} { 52 vfs::filesystem unmount $local 53 ::mk4vfs::_umount $db 54 } 55 56 proc attributes {db} { return [list "state" "commit"] } 57 58 # Can use this to control commit/nocommit or whatever. 59 # I'm not sure yet of what functionality jcw needs. 60 proc commit {db args} { 61 switch -- [llength $args] { 62 0 { 63 if {$::mk4vfs::v::mode($db) == "readonly"} { 64 return 0 65 } else { 66 # To Do: read the commit state 67 return 1 68 } 69 } 70 1 { 71 set val [lindex $args 0] 72 if {$val != 0 && $val != 1} { 73 return -code error \ 74 "invalid commit value $val, must be 0,1" 75 } 76 # To Do: set the commit state. 77 } 78 default { 79 return -code error "Wrong num args" 80 } 81 } 82 } 83 84 proc state {db args} { 85 switch -- [llength $args] { 86 0 { 87 return $::mk4vfs::v::mode($db) 88 } 89 1 { 90 set val [lindex $args 0] 91 if {[lsearch -exact [::vfs::states] $val] == -1} { 92 return -code error \ 93 "invalid state $val, must be one of: [vfs::states]" 94 } 95 set ::mk4vfs::v::mode($db) $val 96 ::mk4vfs::setupCommits $db 97 } 98 default { 99 return -code error "Wrong num args" 100 } 101 } 102 } 103 104 proc handler {db cmd root relative actualpath args} { 105 #puts stderr "handler: $db - $cmd - $root - $relative - $actualpath - $args" 106 if {$cmd == "matchindirectory"} { 107 eval [list $cmd $db $relative $actualpath] $args 108 } elseif {$cmd == "fileattributes"} { 109 eval [list $cmd $db $root $relative] $args 110 } else { 111 eval [list $cmd $db $relative] $args 112 } 113 } 114 115 proc utime {db path actime modtime} { 116 ::mk4vfs::stat $db $path sb 117 118 if { $sb(type) == "file" } { 119 mk::set $sb(ino) date $modtime 120 } 121 } 122 123 proc matchindirectory {db path actualpath pattern type} { 124 set newres [list] 125 if {![string length $pattern]} { 126 # check single file 127 if {[catch {access $db $path 0}]} { 128 return {} 129 } 130 set res [list $actualpath] 131 set actualpath "" 132 } else { 133 set res [::mk4vfs::getdir $db $path $pattern] 134 } 135 foreach p [::vfs::matchCorrectTypes $type $res $actualpath] { 136 lappend newres [file join $actualpath $p] 137 } 138 return $newres 139 } 140 141 proc stat {db name} { 142 ::mk4vfs::stat $db $name sb 143 144 set sb(ino) 0 145 array get sb 146 } 147 148 proc access {db name mode} { 149 if {$mode & 2} { 150 if {$::mk4vfs::v::mode($db) == "readonly"} { 151 vfs::filesystem posixerror $::vfs::posix(EROFS) 152 } 153 } 154 # We can probably do this more efficiently, can't we? 155 ::mk4vfs::stat $db $name sb 156 } 157 158 proc open {db file mode permissions} { 159 # return a list of two elements: 160 # 1. first element is the Tcl channel name which has been opened 161 # 2. second element (optional) is a command to evaluate when 162 # the channel is closed. 163 switch -glob -- $mode { 164 {} - 165 r { 166 ::mk4vfs::stat $db $file sb 167 168 if { $sb(csize) != $sb(size) } { 169 if {$::mk4vfs::zstreamed} { 170 set fd [mk::channel $sb(ino) contents r] 171 set fd [vfs::zstream decompress $fd $sb(csize) $sb(size)] 172 } else { 173 set fd [vfs::memchan] 174 fconfigure $fd -translation binary 175 set s [mk::get $sb(ino) contents] 176 puts -nonewline $fd [vfs::zip -mode decompress $s] 177 178 fconfigure $fd -translation auto 179 seek $fd 0 180 } 181 } elseif { $::mk4vfs::direct } { 182 set fd [vfs::memchan] 183 fconfigure $fd -translation binary 184 puts -nonewline $fd [mk::get $sb(ino) contents] 185 186 fconfigure $fd -translation auto 187 seek $fd 0 188 } else { 189 set fd [mk::channel $sb(ino) contents r] 190 } 191 return [list $fd] 192 } 193 a { 194 if {$::mk4vfs::v::mode($db) == "readonly"} { 195 vfs::filesystem posixerror $::vfs::posix(EROFS) 196 } 197 if { [catch {::mk4vfs::stat $db $file sb }] } { 198 # Create file 199 ::mk4vfs::stat $db [file dirname $file] sb 200 set tail [file tail $file] 201 set fview $sb(ino).files 202 if {[info exists mk4vfs::v::fcache($fview)]} { 203 lappend mk4vfs::v::fcache($fview) $tail 204 } 205 set now [clock seconds] 206 set sb(ino) [mk::row append $fview \ 207 name $tail size 0 date $now ] 208 209 if { [string match *z* $mode] || $mk4vfs::compress } { 210 set sb(csize) -1 ;# HACK - force compression 211 } else { 212 set sb(csize) 0 213 } 214 } 215 216 set fd [vfs::memchan] 217 fconfigure $fd -translation binary 218 set s [mk::get $sb(ino) contents] 219 220 if { $sb(csize) != $sb(size) && $sb(csize) > 0 } { 221 append mode z 222 puts -nonewline $fd [vfs::zip -mode decompress $s] 223 } else { 224 if { $mk4vfs::compress } { append mode z } 225 puts -nonewline $fd $s 226 #set fd [mk::channel $sb(ino) contents a] 227 } 228 fconfigure $fd -translation auto 229 seek $fd 0 end 230 return [list $fd [list mk4vfs::do_close $db $fd $mode $sb(ino)]] 231 } 232 w* { 233 if {$::mk4vfs::v::mode($db) == "readonly"} { 234 vfs::filesystem posixerror $::vfs::posix(EROFS) 235 } 236 if { [catch {::mk4vfs::stat $db $file sb }] } { 237 # Create file 238 ::mk4vfs::stat $db [file dirname $file] sb 239 set tail [file tail $file] 240 set fview $sb(ino).files 241 if {[info exists mk4vfs::v::fcache($fview)]} { 242 lappend mk4vfs::v::fcache($fview) $tail 243 } 244 set now [clock seconds] 245 set sb(ino) [mk::row append $fview \ 246 name $tail size 0 date $now ] 247 } 248 249 if { [string match *z* $mode] || $mk4vfs::compress } { 250 append mode z 251 set fd [vfs::memchan] 252 } else { 253 set fd [mk::channel $sb(ino) contents w] 254 } 255 return [list $fd [list mk4vfs::do_close $db $fd $mode $sb(ino)]] 256 } 257 default { 258 error "illegal access mode \"$mode\"" 259 } 260 } 261 } 262 263 proc createdirectory {db name} { 264 mk4vfs::mkdir $db $name 265 } 266 267 proc removedirectory {db name recursive} { 268 mk4vfs::delete $db $name $recursive 269 } 270 271 proc deletefile {db name} { 272 mk4vfs::delete $db $name 273 } 274 275 proc fileattributes {db root relative args} { 276 switch -- [llength $args] { 277 0 { 278 # list strings 279 return [::vfs::listAttributes] 280 } 281 1 { 282 # get value 283 set index [lindex $args 0] 284 return [::vfs::attributesGet $root $relative $index] 285 286 } 287 2 { 288 # set value 289 if {$::mk4vfs::v::mode($db) == "readonly"} { 290 vfs::filesystem posixerror $::vfs::posix(EROFS) 291 } 292 set index [lindex $args 0] 293 set val [lindex $args 1] 294 return [::vfs::attributesSet $root $relative $index $val] 295 } 296 } 297 } 298} 299 300namespace eval mk4vfs { 301 variable compress 1 ;# HACK - needs to be part of "Super-Block" 302 variable flush 5000 ;# Auto-Commit frequency 303 variable direct 0 ;# read through a memchan, or from Mk4tcl if zero 304 variable zstreamed 0 ;# decompress on the fly (needs zlib 1.1) 305 306 namespace eval v { 307 variable seq 0 308 variable mode ;# array key is db, value is mode 309 # (readwrite/translucent/readonly) 310 variable timer ;# array key is db, set to afterid, periodicCommit 311 312 array set cache {} 313 array set fcache {} 314 315 array set mode {exe translucent} 316 } 317 318 proc init {db} { 319 mk::view layout $db.dirs \ 320 {name:S parent:I {files {name:S size:I date:I contents:M}}} 321 322 if { [mk::view size $db.dirs] == 0 } { 323 mk::row append $db.dirs name <root> parent -1 324 } 325 } 326 327 proc _mount {{file ""} args} { 328 set db mk4vfs[incr v::seq] 329 330 if {$file == ""} { 331 mk::file open $db 332 init $db 333 set v::mode($db) "translucent" 334 } else { 335 eval [list mk::file open $db $file] $args 336 337 init $db 338 339 set mode 0 340 foreach arg $args { 341 switch -- $arg { 342 -readonly { set mode 1 } 343 -nocommit { set mode 2 } 344 } 345 } 346 if {$mode == 0} { 347 periodicCommit $db 348 } 349 set v::mode($db) [lindex {translucent readwrite readwrite} $mode] 350 } 351 return $db 352 } 353 354 proc periodicCommit {db} { 355 variable flush 356 set v::timer($db) [after $flush [list ::mk4vfs::periodicCommit $db]] 357 mk::file commit $db 358 return ;# 2005-01-20 avoid returning a value 359 } 360 361 proc _umount {db args} { 362 catch {after cancel $v::timer($db)} 363 array unset v::mode $db 364 array unset v::timer $db 365 array unset v::cache $db,* 366 array unset v::fcache $db.* 367 mk::file close $db 368 } 369 370 proc stat {db path {arr ""}} { 371 set sp [::file split $path] 372 set tail [lindex $sp end] 373 374 set parent 0 375 set view $db.dirs 376 set type directory 377 378 foreach ele [lrange $sp 0 end-1] { 379 if {[info exists v::cache($db,$parent,$ele)]} { 380 set parent $v::cache($db,$parent,$ele) 381 } else { 382 set row [mk::select $view -count 1 parent $parent name $ele] 383 if { $row == "" } { 384 vfs::filesystem posixerror $::vfs::posix(ENOENT) 385 } 386 set v::cache($db,$parent,$ele) $row 387 set parent $row 388 } 389 } 390 391 # Now check if final comp is a directory or a file 392 # CACHING is required - it can deliver a x15 speed-up! 393 394 if { [string equal $tail "."] || [string equal $tail ":"] \ 395 || [string equal $tail ""] } { 396 set row $parent 397 398 } elseif { [info exists v::cache($db,$parent,$tail)] } { 399 set row $v::cache($db,$parent,$tail) 400 } else { 401 # File? 402 set fview $view!$parent.files 403 # create a name cache of files in this directory 404 if {![info exists v::fcache($fview)]} { 405 # cache only a limited number of directories 406 if {[array size v::fcache] >= 10} { 407 array unset v::fcache * 408 } 409 set v::fcache($fview) {} 410 mk::loop c $fview { 411 lappend v::fcache($fview) [mk::get $c name] 412 } 413 } 414 set row [lsearch -exact $v::fcache($fview) $tail] 415 #set row [mk::select $fview -count 1 name $tail] 416 #if {$row == ""} { set row -1 } 417 if { $row != -1 } { 418 set type file 419 set view $view!$parent.files 420 } else { 421 # Directory? 422 set row [mk::select $view -count 1 parent $parent name $tail] 423 if { $row != "" } { 424 set v::cache($db,$parent,$tail) $row 425 } else { 426 vfs::filesystem posixerror $::vfs::posix(ENOENT) 427 } 428 } 429 } 430 431 if {![string length $arr]} { 432 # The caller doesn't need more detailed information. 433 return 1 434 } 435 436 set cur $view!$row 437 438 upvar 1 $arr sb 439 440 set sb(type) $type 441 set sb(view) $view 442 set sb(ino) $cur 443 444 if { [string equal $type "directory"] } { 445 set sb(atime) 0 446 set sb(ctime) 0 447 set sb(gid) 0 448 set sb(mode) 0777 449 set sb(mtime) 0 450 set sb(nlink) [expr { [mk::get $cur files] + 1 }] 451 set sb(size) 0 452 set sb(csize) 0 453 set sb(uid) 0 454 } else { 455 set mtime [mk::get $cur date] 456 set sb(atime) $mtime 457 set sb(ctime) $mtime 458 set sb(gid) 0 459 set sb(mode) 0777 460 set sb(mtime) $mtime 461 set sb(nlink) 1 462 set sb(size) [mk::get $cur size] 463 set sb(csize) [mk::get $cur -size contents] 464 set sb(uid) 0 465 } 466 } 467 468 proc do_close {db fd mode cur} { 469 if {![regexp {[aw]} $mode]} { 470 error "mk4vfs::do_close called with bad mode: $mode" 471 } 472 473 mk::set $cur size -1 date [clock seconds] 474 flush $fd 475 if { [string match *z* $mode] } { 476 fconfigure $fd -translation binary 477 seek $fd 0 478 set data [read $fd] 479 set cdata [vfs::zip -mode compress $data] 480 set len [string length $data] 481 set clen [string length $cdata] 482 if { $clen < $len } { 483 mk::set $cur size $len contents $cdata 484 } else { 485 mk::set $cur size $len contents $data 486 } 487 } else { 488 mk::set $cur size [mk::get $cur -size contents] 489 } 490 # 16oct02 new logic to start a periodic commit timer if not yet running 491 setupCommits $db 492 return "" 493 } 494 495 proc setupCommits {db} { 496 if {$v::mode($db) eq "readwrite" && ![info exists v::timer($db)]} { 497 periodicCommit $db 498 mk::file autocommit $db 499 } 500 } 501 502 proc mkdir {db path} { 503 if {$v::mode($db) == "readonly"} { 504 vfs::filesystem posixerror $::vfs::posix(EROFS) 505 } 506 set sp [::file split $path] 507 set parent 0 508 set view $db.dirs 509 510 set npath {} 511 # This actually does more work than is needed. Tcl's 512 # vfs only requires us to create the last piece, and 513 # Tcl already knows it is not a file. 514 foreach ele $sp { 515 set npath [file join $npath $ele] 516 517 if {![catch {stat $db $npath sb}] } { 518 if { $sb(type) != "directory" } { 519 vfs::filesystem posixerror $::vfs::posix(EROFS) 520 } 521 set parent [mk::cursor position sb(ino)] 522 continue 523 } 524 #set parent [mk::cursor position sb(ino)] 525 set cur [mk::row append $view name $ele parent $parent] 526 set parent [mk::cursor position cur] 527 } 528 setupCommits $db 529 return "" 530 } 531 532 proc getdir {db path {pat *}} { 533 if {[catch { stat $db $path sb }] || $sb(type) != "directory" } { 534 return 535 } 536 537 # Match directories 538 set parent [mk::cursor position sb(ino)] 539 foreach row [mk::select $sb(view) parent $parent -glob name $pat] { 540 set hits([mk::get $sb(view)!$row name]) 1 541 } 542 # Match files 543 set view $sb(view)!$parent.files 544 foreach row [mk::select $view -glob name $pat] { 545 set hits([mk::get $view!$row name]) 1 546 } 547 return [lsort [array names hits]] 548 } 549 550 proc mtime {db path time} { 551 if {$v::mode($db) == "readonly"} { 552 vfs::filesystem posixerror $::vfs::posix(EROFS) 553 } 554 stat $db $path sb 555 if { $sb(type) == "file" } { 556 mk::set $sb(ino) date $time 557 } 558 return $time 559 } 560 561 proc delete {db path {recursive 0}} { 562 #puts stderr "mk4delete db $db path $path recursive $recursive" 563 if {$v::mode($db) == "readonly"} { 564 vfs::filesystem posixerror $::vfs::posix(EROFS) 565 } 566 stat $db $path sb 567 if {$sb(type) == "file" } { 568 mk::row delete $sb(ino) 569 if {[regexp {(.*)!(\d+)} $sb(ino) - v r] \ 570 && [info exists v::fcache($v)]} { 571 set v::fcache($v) [lreplace $v::fcache($v) $r $r] 572 } 573 } else { 574 # just mark dirs as deleted 575 set contents [getdir $db $path *] 576 if {$recursive} { 577 # We have to delete these manually, else 578 # they (or their cache) may conflict with 579 # something later 580 foreach f $contents { 581 delete $db [file join $path $f] $recursive 582 } 583 } else { 584 if {[llength $contents]} { 585 vfs::filesystem posixerror $::vfs::posix(ENOTEMPTY) 586 } 587 } 588 array unset v::cache \ 589 "$db,[mk::get $sb(ino) parent],[file tail $path]" 590 591 # flag with -99, because parent -1 is not reserved for the root dir 592 # deleted entries never get re-used, should be cleaned up one day 593 mk::set $sb(ino) parent -99 name "" 594 # get rid of file entries to release the space in the datafile 595 mk::view size $sb(ino).files 0 596 } 597 setupCommits $db 598 return "" 599 } 600} 601 602# DEPRECATED - please don't use. 603 604namespace eval mk4vfs { 605 606 namespace export mount umount 607 608 # deprecated, use vfs::mk4::Mount (first two args are reversed!) 609 proc mount {local mkfile args} { 610 uplevel [list ::vfs::mk4::Mount $mkfile $local] $args 611 } 612 613 # deprecated: unmounts, but only if vfs was mounted on itself 614 proc umount {local} { 615 foreach {db path} [mk::file open] { 616 if {[string equal $local $path]} { 617 vfs::filesystem unmount $local 618 _umount $db 619 return 620 } 621 } 622 tclLog "umount $local? [mk::file open]" 623 } 624} 625