Diff

Differences From Artifact [4aa4852a38]:

To Artifact [122176da29]:


   530    530       # requires dbopen/dbclose/dbtree/access/vnames/vlen/mvec primitives
   531    531       #source [file join [info dirname [info script]] decode.tcl]
   532    532   
   533    533       namespace export mk_*
   534    534   
   535    535       proc mk_file {cmd args} {
   536    536   #set indent [string repeat "    " [info level]]
   537         -#puts stderr "${indent}DEBUG: mk::file $cmd $args"
          537  +#puts stderr "${indent}DEBUG: readkit::file $cmd $args"
   538    538   	lassign $args db file
   539    539   	switch $cmd {
   540    540   	    open {
   541    541   		    return [dbopen $db $file]
   542    542   		}
   543    543   	    close {
   544    544   		    dbclose $db
................................................................................
   553    553   		    error "mk_file $cmd?"
   554    554   		}
   555    555   	}
   556    556       }
   557    557   
   558    558       proc mk_view {cmd path args} {
   559    559   #set indent [string repeat "    " [info level]]
   560         -#puts stderr "${indent}DEBUG: mk::view $cmd $path $args"
          560  +#puts stderr "${indent}DEBUG: readkit::view $cmd $path $args"
   561    561   	lassign $args a1
   562    562   	switch $cmd {
   563    563   	    info {
   564    564   		    return [vnames [access $path]]
   565    565   		}
   566    566   	    layout {
   567    567   		    set layout "NOTYET"
................................................................................
   581    581   		    error "mk_view $cmd?"
   582    582   		}
   583    583   	}
   584    584       }
   585    585   
   586    586       proc mk_cursor {cmd cursor args} {
   587    587   #set indent [string repeat "    " [info level]]
   588         -#puts stderr "${indent}DEBUG: mk::cursor $cmd $cursor $args"
          588  +#puts stderr "${indent}DEBUG: readkit::cursor $cmd $cursor $args"
   589    589   	upvar $cursor v
   590    590   	switch $cmd {
   591    591   	    create {
   592    592   		    NOTYET
   593    593   		}
   594    594   	    incr {
   595    595   		    NOTYET
................................................................................
   610    610   		    error "mk_cursor $cmd?"
   611    611   		}
   612    612   	}
   613    613       }
   614    614   
   615    615       proc mk_get {path args} {
   616    616   #set indent [string repeat "    " [info level]]
   617         -#puts stderr "${indent}DEBUG: mk::get $path $args"
          617  +#puts stderr "${indent}DEBUG: readkit::get $path $args"
   618    618   	set rowref [access $path]
   619    619   	set sized 0
   620    620   	if {[lindex $args 0] == "-size"} {
   621    621   	    set sized 1
   622    622   	    set args [lrange $args 1 end]
   623    623   	}
   624    624   	set ids 0
................................................................................
   650    650   	}
   651    651   
   652    652   	return $r
   653    653       }
   654    654   
   655    655       proc mk_loop {cursor path args} {
   656    656   #set indent [string repeat "    " [info level]]
   657         -#puts stderr "${indent}DEBUG: mk::loop $cursor $path ..."
          657  +#puts stderr "${indent}DEBUG: readkit::loop $cursor $path ..."
   658    658   	upvar $cursor v
   659    659   	if {[llength $args] == 0} {
   660    660   	    set args [list $path]
   661    661   	    set path $v
   662    662   	    regsub {!-?\d+$} $path {} path
   663    663   	}
   664    664   	lassign $args a1 a2 a3 a4
................................................................................
   703    703   		    }
   704    704   	    }
   705    705   	}
   706    706       }
   707    707   
   708    708       proc mk_select {path args} {
   709    709   #set indent [string repeat "    " [info level]]
   710         -#puts stderr "${indent}DEBUG: mk::select $path $args"
          710  +#puts stderr "${indent}DEBUG: readkit::select $path $args"
   711    711   	# only handle the simplest case: exact matches
   712    712   	if {[lindex $args 0] == "-count"} {
   713    713   		set maxitems [lindex $args 1]
   714    714   		set args [lrange $args 2 end]
   715    715   	}
   716    716   
   717    717   	set currmatchmode "caseinsensitive"
................................................................................
   771    771   	}
   772    772   
   773    773   	return $r
   774    774       }
   775    775   
   776    776       proc mk__rechan {path prop cmd chan args} {
   777    777   #set indent [string repeat "    " [info level]]
   778         -#puts stderr "${indent}DEBUG: mk::_rechan $path $prop $cmd $chan $args"
          778  +#puts stderr "${indent}DEBUG: readkit::_rechan $path $prop $cmd $chan $args"
   779    779   
   780    780           set key [list $path $prop]
   781    781           if {![info exists ::mk__cache($key)]} {
   782         -          set ::mk__cache($key) [mk::get $path $prop]
          782  +          set ::mk__cache($key) [readkit::get $path $prop]
   783    783           }
   784    784           if {![info exists ::mk__offset($key)]} {
   785    785             set ::mk__offset($key) 0
   786    786           }
   787    787           set data $::mk__cache($key)
   788    788           set offset $::mk__offset($key)
   789    789   
................................................................................
   798    798               }
   799    799               "close" {
   800    800                   unset -nocomplain ::mk__cache($key)
   801    801                   unset -nocomplain ::mk__offset($key)
   802    802                   return
   803    803               }
   804    804               default {
   805         -#puts stderr "${indent}DEBUG: mk::_rechan: Called for cmd $cmd"
          805  +#puts stderr "${indent}DEBUG: readkit::_rechan: Called for cmd $cmd"
   806    806                   return -code error "Not implemented: cmd = $cmd"
   807    807               }
   808    808           }
   809    809   
   810    810           set ::mk__offset($key) $offset
   811    811   
   812    812   	return $retval
   813    813       }
   814    814   
   815    815       proc mk_channel {path prop {mode "r"}} {
   816    816   #set indent [string repeat "    " [info level]]
   817         -#puts stderr "${indent}DEBUG: mk::channel $path $prop $mode"
          817  +#puts stderr "${indent}DEBUG: readkit::channel $path $prop $mode"
   818    818   	set fd [rechan [list mk__rechan $path $prop] 2]
   819    819   
   820    820   	return $fd
   821    821       }
   822    822       # vim: ft=tcl
   823    823   
   824    824   }
   825    825   
   826    826   # set up the MetaKit compatibility definitions
   827    827   foreach x {file view cursor get loop select channel} {
   828         -    interp alias {} ::mk::$x {} ::mk_$x
          828  +    interp alias {} ::readkit::$x {} ::mk_$x
          829  +}
          830  +
          831  +
          832  +
          833  +# mk4vfs.tcl -- Mk4tcl Virtual File System driver
          834  +# Copyright (C) 1997-2003 Sensus Consulting Ltd. All Rights Reserved.
          835  +# Matt Newman <matt@sensus.org> and Jean-Claude Wippler <jcw@equi4.com>
          836  +#
          837  +# $Id: mk4vfs.tcl,v 1.41 2008/04/15 21:11:53 andreas_kupries Exp $
          838  +#
          839  +# 05apr02 jcw	1.3	fixed append mode & close,
          840  +#			privatized memchan_handler
          841  +#			added zip, crc back in
          842  +# 28apr02 jcw	1.4	reorged memchan and pkg dependencies
          843  +# 22jun02 jcw	1.5	fixed recursive dir deletion
          844  +# 16oct02 jcw	1.6	fixed periodic commit once a change is made
          845  +# 20jan03 jcw	1.7	streamed zlib decompress mode, reduces memory usage
          846  +# 01feb03 jcw	1.8	fix mounting a symlink, cleanup mount/unmount procs
          847  +# 04feb03 jcw	1.8	whoops, restored vfs::mkcl::Unmount logic
          848  +# 17mar03 jcw	1.9	start with mode translucent or readwrite
          849  +# 18oct05 jcw	1.10	add fallback to MK Compatible Lite driver (vfs::mkcl)
          850  +
          851  +# Removed provision of the backward compatible name. Moved to separate
          852  +# file/package.
          853  +catch {
          854  +	load {} vfs
          855  +}
          856  +package require vfs
          857  +
          858  +# things that can no longer really be left out (but this is the wrong spot!)
          859  +# be as non-invasive as possible, using these definitions as last resort
          860  +
          861  +namespace eval vfs::mkcl {
          862  +    proc Mount {mkfile local args} {
          863  +	if {$mkfile != ""} {
          864  +	  # dereference a symlink, otherwise mounting on it fails (why?)
          865  +	  catch {
          866  +	    set mkfile [file join [file dirname $mkfile] \
          867  +	    			  [file readlink $mkfile]]
          868  +	  }
          869  +	  set mkfile [file normalize $mkfile]
          870  +	}
          871  +	set db [eval [list ::mkcl_vfs::_mount $mkfile] $args]
          872  +	::vfs::filesystem mount $local [list ::vfs::mkcl::handler $db]
          873  +	::vfs::RegisterMount $local [list ::vfs::mkcl::Unmount $db]
          874  +	return $db
          875  +    }
          876  +
          877  +    proc Unmount {db local} {
          878  +	vfs::filesystem unmount $local
          879  +	::mkcl_vfs::_umount $db
          880  +    }
          881  +
          882  +    proc attributes {db} { return [list "state" "commit"] }
          883  +    
          884  +    # Can use this to control commit/nocommit or whatever.
          885  +    # I'm not sure yet of what functionality jcw needs.
          886  +    proc commit {db args} {
          887  +	switch -- [llength $args] {
          888  +	    0 {
          889  +		if {$::mkcl_vfs::v::mode($db) == "readonly"} {
          890  +		    return 0
          891  +		} else {
          892  +		    # To Do: read the commit state
          893  +		    return 1
          894  +		}
          895  +	    }
          896  +	    1 {
          897  +		set val [lindex $args 0]
          898  +		if {$val != 0 && $val != 1} {
          899  +		    return -code error \
          900  +		      "invalid commit value $val, must be 0,1"
          901  +		}
          902  +		# To Do: set the commit state.
          903  +	    }
          904  +	    default {
          905  +		return -code error "Wrong num args"
          906  +	    }
          907  +	}
          908  +    }
          909  +    
          910  +    proc state {db args} {
          911  +	switch -- [llength $args] {
          912  +	    0 {
          913  +		return $::mkcl_vfs::v::mode($db)
          914  +	    }
          915  +	    1 {
          916  +		set val [lindex $args 0]
          917  +		if {[lsearch -exact [::vfs::states] $val] == -1} {
          918  +		    return -code error \
          919  +		      "invalid state $val, must be one of: [vfs::states]"
          920  +		}
          921  +		set ::mkcl_vfs::v::mode($db) $val
          922  +		::mkcl_vfs::setupCommits $db
          923  +	    }
          924  +	    default {
          925  +		return -code error "Wrong num args"
          926  +	    }
          927  +	}
          928  +    }
          929  +    
          930  +    proc handler {db cmd root relative actualpath args} {
          931  +	#puts stderr "handler: $db - $cmd - $root - $relative - $actualpath - $args"
          932  +	if {$cmd == "matchindirectory"} {
          933  +	    eval [list $cmd $db $relative $actualpath] $args
          934  +	} elseif {$cmd == "fileattributes"} {
          935  +	    eval [list $cmd $db $root $relative] $args
          936  +	} else {
          937  +	    eval [list $cmd $db $relative] $args
          938  +	}
          939  +    }
          940  +
          941  +    proc utime {db path actime modtime} {
          942  +	::mkcl_vfs::stat $db $path sb
          943  +	
          944  +	if { $sb(type) == "file" } {
          945  +	    readkit::set $sb(ino) date $modtime
          946  +	}
          947  +    }
          948  +
          949  +    proc matchindirectory {db path actualpath pattern type} {
          950  +	set newres [list]
          951  +	if {![string length $pattern]} {
          952  +	    # check single file
          953  +	    if {[catch {access $db $path 0}]} {
          954  +		return {}
          955  +	    }
          956  +	    set res [list $actualpath]
          957  +	    set actualpath ""
          958  +	} else {
          959  +	    set res [::mkcl_vfs::getdir $db $path $pattern]
          960  +	}
          961  +	foreach p [::vfs::matchCorrectTypes $type $res $actualpath] {
          962  +	    lappend newres [file join $actualpath $p]
          963  +	}
          964  +	return $newres
          965  +    }
          966  +
          967  +    proc stat {db name} {
          968  +	::mkcl_vfs::stat $db $name sb
          969  +
          970  +	set sb(ino) 0
          971  +	array get sb
          972  +    }
          973  +
          974  +    proc access {db name mode} {
          975  +	if {$mode & 2} {
          976  +	    if {$::mkcl_vfs::v::mode($db) == "readonly"} {
          977  +		vfs::filesystem posixerror $::vfs::posix(EROFS)
          978  +	    }
          979  +	}
          980  +	# We can probably do this more efficiently, can't we?
          981  +	::mkcl_vfs::stat $db $name sb
          982  +    }
          983  +
          984  +    proc open {db file mode permissions} {
          985  +	# return a list of two elements:
          986  +	# 1. first element is the Tcl channel name which has been opened
          987  +	# 2. second element (optional) is a command to evaluate when
          988  +	#  the channel is closed.
          989  +	switch -glob -- $mode {
          990  +	    {}  -
          991  +	    r {
          992  +		::mkcl_vfs::stat $db $file sb
          993  +
          994  +		if { $sb(csize) != $sb(size) } {
          995  +		    if {$::mkcl_vfs::zstreamed} {
          996  +		      set fd [readkit::channel $sb(ino) contents r]
          997  +		      fconfigure $fd -translation binary
          998  +		      set fd [vfs::zstream decompress $fd $sb(csize) $sb(size)]
          999  +		    } else {
         1000  +		      set fd [vfs::memchan]
         1001  +		      fconfigure $fd -translation binary
         1002  +		      set s [readkit::get $sb(ino) contents]
         1003  +		      puts -nonewline $fd [vfs::zip -mode decompress $s]
         1004  +
         1005  +		      fconfigure $fd -translation auto
         1006  +		      seek $fd 0
         1007  +		    }
         1008  +		} elseif { $::mkcl_vfs::direct } {
         1009  +		    set fd [vfs::memchan]
         1010  +		    fconfigure $fd -translation binary
         1011  +		    puts -nonewline $fd [readkit::get $sb(ino) contents]
         1012  +
         1013  +		    fconfigure $fd -translation auto
         1014  +		    seek $fd 0
         1015  +		} else {
         1016  +		    set fd [readkit::channel $sb(ino) contents r]
         1017  +		}
         1018  +		return [list $fd]
         1019  +	    }
         1020  +	    a {
         1021  +		if {$::mkcl_vfs::v::mode($db) == "readonly"} {
         1022  +		    vfs::filesystem posixerror $::vfs::posix(EROFS)
         1023  +		}
         1024  +		if { [catch {::mkcl_vfs::stat $db $file sb }] } {
         1025  +		    # Create file
         1026  +		    ::mkcl_vfs::stat $db [file dirname $file] sb
         1027  +		    set tail [file tail $file]
         1028  +		    set fview $sb(ino).files
         1029  +		    if {[info exists mkcl_vfs::v::fcache($fview)]} {
         1030  +			lappend mkcl_vfs::v::fcache($fview) $tail
         1031  +		    }
         1032  +		    set now [clock seconds]
         1033  +		    set sb(ino) [readkit::row append $fview \
         1034  +			    name $tail size 0 date $now ]
         1035  +
         1036  +		    if { [string match *z* $mode] || $mkcl_vfs::compress } {
         1037  +			set sb(csize) -1  ;# HACK - force compression
         1038  +		    } else {
         1039  +			set sb(csize) 0
         1040  +		    }
         1041  +		}
         1042  +
         1043  +		set fd [vfs::memchan]
         1044  +		fconfigure $fd -translation binary
         1045  +		set s [readkit::get $sb(ino) contents]
         1046  +
         1047  +		if { $sb(csize) != $sb(size) && $sb(csize) > 0 } {
         1048  +		    append mode z
         1049  +		    puts -nonewline $fd [vfs::zip -mode decompress $s]
         1050  +		} else {
         1051  +		    if { $mkcl_vfs::compress } { append mode z }
         1052  +		    puts -nonewline $fd $s
         1053  +		    #set fd [readkit::channel $sb(ino) contents a]
         1054  +		}
         1055  +		fconfigure $fd -translation auto
         1056  +		seek $fd 0 end
         1057  +		return [list $fd [list mkcl_vfs::do_close $db $fd $mode $sb(ino)]]
         1058  +	    }
         1059  +	    w*  {
         1060  +		if {$::mkcl_vfs::v::mode($db) == "readonly"} {
         1061  +		    vfs::filesystem posixerror $::vfs::posix(EROFS)
         1062  +		}
         1063  +		if { [catch {::mkcl_vfs::stat $db $file sb }] } {
         1064  +		    # Create file
         1065  +		    ::mkcl_vfs::stat $db [file dirname $file] sb
         1066  +		    set tail [file tail $file]
         1067  +		    set fview $sb(ino).files
         1068  +		    if {[info exists mkcl_vfs::v::fcache($fview)]} {
         1069  +			lappend mkcl_vfs::v::fcache($fview) $tail
         1070  +		    }
         1071  +		    set now [clock seconds]
         1072  +		    set sb(ino) [readkit::row append $fview \
         1073  +			    name $tail size 0 date $now ]
         1074  +		}
         1075  +
         1076  +		if { [string match *z* $mode] || $mkcl_vfs::compress } {
         1077  +		    append mode z
         1078  +		    set fd [vfs::memchan]
         1079  +		} else {
         1080  +		    set fd [readkit::channel $sb(ino) contents w]
         1081  +		}
         1082  +		return [list $fd [list mkcl_vfs::do_close $db $fd $mode $sb(ino)]]
         1083  +	    }
         1084  +	    default   {
         1085  +		error "illegal access mode \"$mode\""
         1086  +	    }
         1087  +	}
         1088  +    }
         1089  +
         1090  +    proc createdirectory {db name} {
         1091  +	mkcl_vfs::mkdir $db $name
         1092  +    }
         1093  +
         1094  +    proc removedirectory {db name recursive} {
         1095  +	mkcl_vfs::delete $db $name $recursive
         1096  +    }
         1097  +
         1098  +    proc deletefile {db name} {
         1099  +	mkcl_vfs::delete $db $name
         1100  +    }
         1101  +
         1102  +    proc fileattributes {db root relative args} {
         1103  +	switch -- [llength $args] {
         1104  +	    0 {
         1105  +		# list strings
         1106  +		return [::vfs::listAttributes]
         1107  +	    }
         1108  +	    1 {
         1109  +		# get value
         1110  +		set index [lindex $args 0]
         1111  +		return [::vfs::attributesGet $root $relative $index]
         1112  +
         1113  +	    }
         1114  +	    2 {
         1115  +		# set value
         1116  +		if {$::mkcl_vfs::v::mode($db) == "readonly"} {
         1117  +		    vfs::filesystem posixerror $::vfs::posix(EROFS)
         1118  +		}
         1119  +		set index [lindex $args 0]
         1120  +		set val [lindex $args 1]
         1121  +		return [::vfs::attributesSet $root $relative $index $val]
         1122  +	    }
         1123  +	}
         1124  +    }
         1125  +}
         1126  +
         1127  +namespace eval mkcl_vfs {
         1128  +    variable compress 1     ;# HACK - needs to be part of "Super-Block"
         1129  +    variable flush    5000  ;# Auto-Commit frequency
         1130  +    variable direct   0	    ;# read through a memchan, or from Mk4tcl if zero
         1131  +    variable zstreamed 0    ;# decompress on the fly (needs zlib 1.1)
         1132  +
         1133  +    namespace eval v {
         1134  +	variable seq      0
         1135  +	variable mode	    ;# array key is db, value is mode 
         1136  +	             	     # (readwrite/translucent/readonly)
         1137  +	variable timer	    ;# array key is db, set to afterid, periodicCommit
         1138  +
         1139  +	array set cache {}
         1140  +	array set fcache {}
         1141  +
         1142  +	array set mode {exe translucent}
         1143  +    }
         1144  +
         1145  +    proc init {db} {
         1146  +	readkit::view layout $db.dirs \
         1147  +		{name:S parent:I {files {name:S size:I date:I contents:M}}}
         1148  +
         1149  +	if { [readkit::view size $db.dirs] == 0 } {
         1150  +	    readkit::row append $db.dirs name <root> parent -1
         1151  +	}
         1152  +    }
         1153  +
         1154  +    proc _mount {{file ""} args} {
         1155  +	set db mk4vfs[incr v::seq]
         1156  +
         1157  +	if {$file == ""} {
         1158  +	    readkit::file open $db
         1159  +	    init $db
         1160  +	    set v::mode($db) "translucent"
         1161  +	} else {
         1162  +	    eval [list readkit::file open $db $file] $args
         1163  +	    
         1164  +	    init $db
         1165  +	    
         1166  +	    set mode 0
         1167  +	    foreach arg $args {
         1168  +		switch -- $arg {
         1169  +		    -readonly   { set mode 1 }
         1170  +		    -nocommit   { set mode 2 }
         1171  +		}
         1172  +	    }
         1173  +	    if {$mode == 0} {
         1174  +		periodicCommit $db
         1175  +	    }
         1176  +	    set v::mode($db) [lindex {translucent readwrite readwrite} $mode]
         1177  +	}
         1178  +	return $db
         1179  +    }
         1180  +
         1181  +    proc periodicCommit {db} {
         1182  +	variable flush
         1183  +	set v::timer($db) [after $flush [list ::mkcl_vfs::periodicCommit $db]]
         1184  +	readkit::file commit $db
         1185  +	return ;# 2005-01-20 avoid returning a value
         1186  +    }
         1187  +
         1188  +    proc _umount {db args} {
         1189  +	catch {after cancel $v::timer($db)}
         1190  +	array unset v::mode $db
         1191  +	array unset v::timer $db
         1192  +	array unset v::cache $db,*
         1193  +	array unset v::fcache $db.*
         1194  +	readkit::file close $db
         1195  +    }
         1196  +
         1197  +    proc stat {db path {arr ""}} {
         1198  +	set sp [::file split $path]
         1199  +	set tail [lindex $sp end]
         1200  +
         1201  +	set parent 0
         1202  +	set view $db.dirs
         1203  +	set type directory
         1204  +
         1205  +	foreach ele [lrange $sp 0 end-1] {
         1206  +	    if {[info exists v::cache($db,$parent,$ele)]} {
         1207  +		set parent $v::cache($db,$parent,$ele)
         1208  +	    } else {
         1209  +		set row [readkit::select $view -count 1 parent $parent name $ele]
         1210  +		if { $row == "" } {
         1211  +		    vfs::filesystem posixerror $::vfs::posix(ENOENT)
         1212  +		}
         1213  +		set v::cache($db,$parent,$ele) $row
         1214  +		set parent $row
         1215  +	    }
         1216  +	}
         1217  +	
         1218  +	# Now check if final comp is a directory or a file
         1219  +	# CACHING is required - it can deliver a x15 speed-up!
         1220  +	
         1221  +	if { [string equal $tail "."] || [string equal $tail ":"] \
         1222  +	  || [string equal $tail ""] } {
         1223  +	    set row $parent
         1224  +
         1225  +	} elseif { [info exists v::cache($db,$parent,$tail)] } {
         1226  +	    set row $v::cache($db,$parent,$tail)
         1227  +	} else {
         1228  +	    # File?
         1229  +	    set fview $view!$parent.files
         1230  +	    # create a name cache of files in this directory
         1231  +	    if {![info exists v::fcache($fview)]} {
         1232  +		# cache only a limited number of directories
         1233  +		if {[array size v::fcache] >= 10} {
         1234  +		    array unset v::fcache *
         1235  +		}
         1236  +		set v::fcache($fview) {}
         1237  +		readkit::loop c $fview {
         1238  +		    lappend v::fcache($fview) [readkit::get $c name]
         1239  +		}
         1240  +	    }
         1241  +	    set row [lsearch -exact $v::fcache($fview) $tail]
         1242  +	    #set row [readkit::select $fview -count 1 name $tail]
         1243  +	    #if {$row == ""} { set row -1 }
         1244  +	    if { $row != -1 } {
         1245  +		set type file
         1246  +		set view $view!$parent.files
         1247  +	    } else {
         1248  +		# Directory?
         1249  +		set row [readkit::select $view -count 1 parent $parent name $tail]
         1250  +		if { $row != "" } {
         1251  +		    set v::cache($db,$parent,$tail) $row
         1252  +		} else { 
         1253  +		    vfs::filesystem posixerror $::vfs::posix(ENOENT)
         1254  +		}
         1255  +	    }
         1256  +	}
         1257  + 
         1258  +        if {![string length $arr]} {
         1259  +            # The caller doesn't need more detailed information.
         1260  +            return 1
         1261  +        }
         1262  + 
         1263  +	set cur $view!$row
         1264  +
         1265  +	upvar 1 $arr sb
         1266  +
         1267  +	set sb(type)    $type
         1268  +	set sb(view)    $view
         1269  +	set sb(ino)     $cur
         1270  +
         1271  +	if { [string equal $type "directory"] } {
         1272  +	    set sb(atime) 0
         1273  +	    set sb(ctime) 0
         1274  +	    set sb(gid)   0
         1275  +	    set sb(mode)  0777
         1276  +	    set sb(mtime) 0
         1277  +	    set sb(nlink) [expr { [readkit::get $cur files] + 1 }]
         1278  +	    set sb(size)  0
         1279  +	    set sb(csize) 0
         1280  +	    set sb(uid)   0
         1281  +	} else {
         1282  +	    set mtime   [readkit::get $cur date]
         1283  +	    set sb(atime) $mtime
         1284  +	    set sb(ctime) $mtime
         1285  +	    set sb(gid)   0
         1286  +	    set sb(mode)  0777
         1287  +	    set sb(mtime) $mtime
         1288  +	    set sb(nlink) 1
         1289  +	    set sb(size)  [readkit::get $cur size]
         1290  +	    set sb(csize) [readkit::get $cur -size contents]
         1291  +	    set sb(uid)   0
         1292  +	}
         1293  +    }
         1294  +
         1295  +    proc do_close {db fd mode cur} {
         1296  +	if {![regexp {[aw]} $mode]} {
         1297  +	    error "mkcl_vfs::do_close called with bad mode: $mode"
         1298  +	}
         1299  +
         1300  +	readkit::set $cur size -1 date [clock seconds]
         1301  +	flush $fd
         1302  +	if { [string match *z* $mode] } {
         1303  +	    fconfigure $fd -translation binary
         1304  +	    seek $fd 0
         1305  +	    set data [read $fd]
         1306  +	    set cdata [vfs::zip -mode compress $data]
         1307  +	    set len [string length $data]
         1308  +	    set clen [string length $cdata]
         1309  +	    if { $clen < $len } {
         1310  +		readkit::set $cur size $len contents $cdata
         1311  +	    } else {
         1312  +		readkit::set $cur size $len contents $data
         1313  +	    }
         1314  +	} else {
         1315  +	    readkit::set $cur size [readkit::get $cur -size contents]
         1316  +	}
         1317  +	# 16oct02 new logic to start a periodic commit timer if not yet running
         1318  +	setupCommits $db
         1319  +	return ""
         1320  +    }
         1321  +
         1322  +    proc setupCommits {db} {
         1323  +	if {$v::mode($db) eq "readwrite" && ![info exists v::timer($db)]} {
         1324  +	    periodicCommit $db
         1325  +	    readkit::file autocommit $db
         1326  +	}
         1327  +    }
         1328  +
         1329  +    proc mkdir {db path} {
         1330  +	if {$v::mode($db) == "readonly"} {
         1331  +	    vfs::filesystem posixerror $::vfs::posix(EROFS)
         1332  +	}
         1333  +	set sp [::file split $path]
         1334  +	set parent 0
         1335  +	set view $db.dirs
         1336  +
         1337  +	set npath {}
         1338  +	# This actually does more work than is needed. Tcl's
         1339  +	# vfs only requires us to create the last piece, and
         1340  +	# Tcl already knows it is not a file.
         1341  +	foreach ele $sp {
         1342  +	    set npath [file join $npath $ele]
         1343  +
         1344  +	    if {![catch {stat $db $npath sb}] } {
         1345  +		if { $sb(type) != "directory" } {
         1346  +		    vfs::filesystem posixerror $::vfs::posix(EROFS)
         1347  +		}
         1348  +		set parent [readkit::cursor position sb(ino)]
         1349  +		continue
         1350  +	    }
         1351  +	    #set parent [readkit::cursor position sb(ino)]
         1352  +	    set cur [readkit::row append $view name $ele parent $parent]
         1353  +	    set parent [readkit::cursor position cur]
         1354  +	}
         1355  +	setupCommits $db
         1356  +	return ""
         1357  +    }
         1358  +
         1359  +    proc getdir {db path {pat *}} {
         1360  +	if {[catch { stat $db $path sb }] || $sb(type) != "directory" } {
         1361  +	    return
         1362  +	}
         1363  +
         1364  +	# Match directories
         1365  +	set parent [readkit::cursor position sb(ino)] 
         1366  +	foreach row [readkit::select $sb(view) parent $parent -glob name $pat] {
         1367  +	    set hits([readkit::get $sb(view)!$row name]) 1
         1368  +	}
         1369  +	# Match files
         1370  +	set view $sb(view)!$parent.files
         1371  +	foreach row [readkit::select $view -glob name $pat] {
         1372  +	    set hits([readkit::get $view!$row name]) 1
         1373  +	}
         1374  +	return [lsort [array names hits]]
         1375  +    }
         1376  +
         1377  +    proc mtime {db path time} {
         1378  +	if {$v::mode($db) == "readonly"} {
         1379  +	    vfs::filesystem posixerror $::vfs::posix(EROFS)
         1380  +	}
         1381  +	stat $db $path sb
         1382  +	if { $sb(type) == "file" } {
         1383  +	    readkit::set $sb(ino) date $time
         1384  +	}
         1385  +	return $time
         1386  +    }
         1387  +
         1388  +    proc delete {db path {recursive 0}} {
         1389  +	#puts stderr "mk4delete db $db path $path recursive $recursive"
         1390  +	if {$v::mode($db) == "readonly"} {
         1391  +	    vfs::filesystem posixerror $::vfs::posix(EROFS)
         1392  +	}
         1393  +	stat $db $path sb
         1394  +	if {$sb(type) == "file" } {
         1395  +	    readkit::row delete $sb(ino)
         1396  +	    if {[regexp {(.*)!(\d+)} $sb(ino) - v r] \
         1397  +		    && [info exists v::fcache($v)]} {
         1398  +		set v::fcache($v) [lreplace $v::fcache($v) $r $r]
         1399  +	    }
         1400  +	} else {
         1401  +	    # just mark dirs as deleted
         1402  +	    set contents [getdir $db $path *]
         1403  +	    if {$recursive} {
         1404  +		# We have to delete these manually, else
         1405  +		# they (or their cache) may conflict with
         1406  +		# something later
         1407  +		foreach f $contents {
         1408  +		    delete $db [file join $path $f] $recursive
         1409  +		}
         1410  +	    } else {
         1411  +		if {[llength $contents]} {
         1412  +		    vfs::filesystem posixerror $::vfs::posix(ENOTEMPTY)
         1413  +		}
         1414  +	    }
         1415  +	    array unset v::cache \
         1416  +		    "$db,[readkit::get $sb(ino) parent],[file tail $path]"
         1417  +	    
         1418  +	    # flag with -99, because parent -1 is not reserved for the root dir
         1419  +	    # deleted entries never get re-used, should be cleaned up one day
         1420  +	    readkit::set $sb(ino) parent -99 name ""
         1421  +	    # get rid of file entries to release the space in the datafile
         1422  +	    readkit::view size $sb(ino).files 0
         1423  +	}
         1424  +	setupCommits $db
         1425  +	return ""
         1426  +    }
   829   1427   }
   830   1428   
   831         -package provide Mk4tcl 2.4.0.1
         1429  +package provide readkit 0.8
         1430  +package provide vfs::mkcl 2.4.0.1