Overview
| Comment: | Updated to implement "vfs::mkcl" using Readkit
Updated local Readkit implementation to not attempt to replace Mk4tcl |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk |
| Files: | files | file ages | folders |
| SHA1: | 096098536d21d1b4183dd647f0f837e268b72de4 |
| User & Date: | rkeene on 2010-09-26 04:42:20 |
| Other Links: | manifest | tags |
Context
|
2010-09-26
| ||
| 04:42 | KitCreator 0.2.0.x check-in: b9f7f215ae user: rkeene tags: trunk, 0.2.0 | |
| 04:42 |
Updated to implement "vfs::mkcl" using Readkit
Updated local Readkit implementation to not attempt to replace Mk4tcl check-in: 096098536d user: rkeene tags: trunk | |
| 04:42 | Added internal script to build a minimal Tclkit check-in: 7596e618f3 user: rkeene tags: trunk | |
Changes
Modified kitsh/buildsrc/kitsh-0.0/boot.tcl from [22b7e78c5d] to [a3240f621e].
17 17 18 18 # the following code only gets executed once on startup 19 19 if {[info exists tcl_rcFileName]} { 20 20 load {} vfs 21 21 22 22 # lookup and emulate "source" of lib/vfs/{vfs*.tcl,mk4vfs.tcl} 23 23 # must use raw MetaKit calls because VFS is not yet in place 24 - set d [mk::select exe.dirs parent 0 name lib] 25 - set d [mk::select exe.dirs parent $d name vfs] 24 + set d [${::tclkitMkNamespace}::select exe.dirs parent 0 name lib] 25 + set d [${::tclkitMkNamespace}::select exe.dirs parent $d name vfs] 26 26 27 27 foreach x {vfsUtils vfslib mk4vfs} { 28 - set n [mk::select exe.dirs!$d.files name $x.tcl] 29 - set s [mk::get exe.dirs!$d.files!$n contents] 28 + set n [${::tclkitMkNamespace}::select exe.dirs!$d.files name $x.tcl] 29 + set s [${::tclkitMkNamespace}::get exe.dirs!$d.files!$n contents] 30 30 catch {set s [zlib decompress $s]} 31 31 uplevel #0 $s 32 32 } 33 33 34 34 # use on-the-fly decompression, if mk4vfs understands that 35 - set mk4vfs::zstreamed 1 35 + switch -- $::tclkitMkNamespace { 36 + "mk" { 37 + set mk4vfs::zstreamed 1 38 + set vfsimpl "mk4" 39 + } 40 + "readkit" { 41 + set mkcl_vfs::zstreamed 1 42 + set vfsimpl "mkcl" 43 + } 44 + } 36 45 37 46 # mount the executable, i.e. make all runtime files available 38 - vfs::filesystem mount $noe [list ::vfs::mk4::handler exe] 47 + vfs::filesystem mount $noe [list ::vfs::${vfsimpl}::handler exe] 39 48 40 49 # alter path to find encodings 41 50 if {[info tclversion] eq "8.4"} { 42 51 load {} pwb 43 52 librarypath [info library] 44 53 } else { 45 54 encoding dirs [list [file join [info library] encoding]] ;# TIP 258 ................................................................................ 61 70 set noe [info nameofexecutable] 62 71 63 72 # Resolve symlinks 64 73 set noe [file dirname [file normalize [file join $noe __dummy__]]] 65 74 66 75 set tcl_library [file join $noe lib tcl$tcl_version] 67 76 set tcl_libPath [list $tcl_library [file join $noe lib]] 68 - vfs::filesystem mount $noe [list ::vfs::mk4::handler exe] 77 + vfs::filesystem mount $noe [list ::vfs::${vfsimpl}::handler exe] 69 78 } 70 79 71 80 # load config settings file if present 72 81 namespace eval ::vfs { variable tclkit_version 1 } 73 82 catch { uplevel #0 [list source [file join $noe config.tcl]] } 74 83 75 84 uplevel #0 [list source [file join $tcl_library init.tcl]] 76 85 77 86 # reset auto_path, so that init.tcl's search outside of tclkit is cancelled 78 87 set auto_path $tcl_libPath 88 + 89 + unset ::tclkitMkNamespace 79 90 }
Modified kitsh/buildsrc/kitsh-0.0/kitInit.c from [40729608ac] to [f0bdde86c9].
76 76 "return -code $code $res\n" 77 77 "}\n" 78 78 #endif 79 79 "proc tclKitInit {} {\n" 80 80 "rename tclKitInit {}\n" 81 81 #ifdef KIT_INCLUDES_MK4TCL 82 82 "catch { load {} Mk4tcl }\n" 83 + "set ::tclkitMkNamespace \"mk\"\n" 83 84 #else 84 85 #include "mk4tcl.tcl.h" 86 + "set ::tclkitMkNamespace \"readkit\"\n" 85 87 #endif 86 - "mk::file open exe [info nameofexecutable] -readonly\n" 87 - "set n [mk::select exe.dirs!0.files name boot.tcl]\n" 88 + "${::tclkitMkNamespace}::file open exe [info nameofexecutable] -readonly\n" 89 + "set n [${::tclkitMkNamespace}::select exe.dirs!0.files name boot.tcl]\n" 88 90 "if {$n != \"\"} {\n" 89 - "set s [mk::get exe.dirs!0.files!$n contents]\n" 91 + "set s [${::tclkitMkNamespace}::get exe.dirs!0.files!$n contents]\n" 90 92 "if {![string length $s]} { error \"empty boot.tcl\" }\n" 91 93 "catch {load {} zlib}\n" 92 - "if {[mk::get exe.dirs!0.files!$n size] != [string length $s]} {\n" 94 + "if {[${::tclkitMkNamespace}::get exe.dirs!0.files!$n size] != [string length $s]} {\n" 93 95 "set s [zlib decompress $s]\n" 94 96 "}\n" 95 97 "} else {\n" 96 98 "set f [open setup.tcl]\n" 97 99 "set s [read $f]\n" 98 100 "close $f\n" 99 101 "}\n"
Modified kitsh/buildsrc/kitsh-0.0/mk4tcl.tcl from [4aa4852a38] to [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