Overview
| Comment: | KitCreator 0.3.0.x
Added support for using ZIP archives if MK4 fails to build Removed support for pure-Tcl MK4 (it didn't work) |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | trunk | 0.3.0 |
| Files: | files | file ages | folders |
| SHA1: | 66535d6924ff2a81d02360d114ba67103cfa278b |
| User & Date: | rkeene on 2010-09-26 04:43:48 |
| Other Links: | manifest | tags |
Context
|
2010-09-26
| ||
| 04:43 | Updated to return in failure if we fail to properly install check-in: bdcfd6df7f user: rkeene tags: trunk | |
| 04:43 |
KitCreator 0.3.0.x
Added support for using ZIP archives if MK4 fails to build Removed support for pure-Tcl MK4 (it didn't work) check-in: 66535d6924 user: rkeene tags: trunk, 0.3.0 | |
| 04:43 | Added support for building under Win64 (MingW64) check-in: 53cdd8c9a6 user: rkeene tags: trunk | |
Changes
Modified build/makearch.info from [038ce76a42] to [d2944198db].
12 12 # If set to "auto" it will be maintained in a file called .version 13 13 # in the source directory and the revision will be incremented 14 14 # each time a "makearch" is done. 15 15 # 16 16 # If @@SVNLCR@@ is used anywhere in this version number, it will be 17 17 # replaced with the highest last-changed-rev from the output of 18 18 # svn info -R (or 0) 19 -VERS="0.2.4.@@SVNLCR@@" 19 +VERS="0.3.0.@@SVNLCR@@" 20 20 21 21 # Space sperated list of documents, if they exist, they will be 22 22 # prefixed with the contents of the DOC_HDR file and substitution 23 23 # will occur: 24 24 # @@UTIL@@ becomes the utility name ${UTIL} 25 25 # @@VERS@@ becomes the utility version 26 26 # @@DATE@@ becomes the current date
Modified build/pre.sh from [24cc7de513] to [52ef0ed788].
9 9 cd "${KITSHROOTDIR}" || exit 1 10 10 11 11 autoconf; autoheader 12 12 rm -rf autom4te.cache 13 13 rm -f *~ 14 14 15 15 ./configure || exit 1 16 - make mk4tcl.tcl.h 16 + make boot.tcl.h 17 + make zipvfs.tcl.h 17 18 18 19 make distclean 19 20 ) || exit 1 20 21 21 22 find . -name '.*.sw?' -type f | xargs rm -f
Modified kitsh/buildsrc/kitsh-0.0/Makefile.in from [4fbebeccc2] to [c486d97051].
11 11 12 12 kit.res.o: kit.rc kit.ico 13 13 $(RC) -o kit.res.o $(CPPFLAGS) kit.rc 14 14 15 15 kit: $(OBJS) $(ARCHS) 16 16 $(CC) $(CPPFLAGS) $(CFLAGS) -o kit $(OBJS) $(ARCHS) $(LDFLAGS) $(LIBS) 17 17 18 -mk4tcl.tcl.h: mk4tcl.tcl 19 - ./stringify.tcl mk4tcl.tcl > mk4tcl.tcl.h 18 +boot.tcl.h: boot.tcl 19 + ./stringify.tcl boot.tcl > boot.tcl.h 20 + 21 +zipvfs.tcl.h: zipvfs.tcl 22 + ./stringify.tcl zipvfs.tcl > zipvfs.tcl.h 20 23 21 24 clean: 22 25 rm -f kit $(OBJS) 23 26 24 27 distclean: clean 25 28 rm -f config.h Makefile config.log config.status 26 29 rm -rf autom4te.cache 27 30 28 31 mrproper: distclean 29 - rm -f configure config.h mk4tcl.tcl.h 32 + rm -f configure config.h boot.tcl.h zipvfs.tcl.h 30 33 31 34 .PHONY: all clean distclean
Modified kitsh/buildsrc/kitsh-0.0/boot.tcl from [a3240f621e] to [fad62aecf7].
1 1 proc tclInit {} { 2 - rename tclInit {} 2 + rename tclInit {} 3 3 4 - global auto_path tcl_library tcl_libPath 5 - global tcl_version tcl_rcFileName 4 + global auto_path tcl_library tcl_libPath 5 + global tcl_version tcl_rcFileName 6 6 7 - set noe [info nameofexecutable] 7 + set noe [info nameofexecutable] 8 8 9 - # Resolve symlinks 10 - set noe [file dirname [file normalize [file join $noe __dummy__]]] 9 + # Resolve symlinks 10 + set noe [file dirname [file normalize [file join $noe __dummy__]]] 11 11 12 - set tcl_library [file join $noe lib tcl$tcl_version] 13 - set tcl_libPath [list $tcl_library [file join $noe lib]] 12 + set tcl_library [file join $noe lib tcl$tcl_version] 13 + set tcl_libPath [list $tcl_library [file join $noe lib]] 14 14 15 - # get rid of a build residue 16 - unset -nocomplain ::tclDefaultLibrary 15 + # get rid of a build residue 16 + unset -nocomplain ::tclDefaultLibrary 17 17 18 - # the following code only gets executed once on startup 19 - if {[info exists tcl_rcFileName]} { 20 - load {} vfs 18 + # the following code only gets executed once on startup 19 + if {[info exists tcl_rcFileName]} { 20 + # lookup and emulate "source" of lib/vfs/{vfs*.tcl,mk4vfs.tcl} 21 + switch -- $::tclKitStorage { 22 + "mk4" { 23 + load {} vfs 21 24 22 - # lookup and emulate "source" of lib/vfs/{vfs*.tcl,mk4vfs.tcl} 23 - # must use raw MetaKit calls because VFS is not yet in place 24 - set d [${::tclkitMkNamespace}::select exe.dirs parent 0 name lib] 25 - set d [${::tclkitMkNamespace}::select exe.dirs parent $d name vfs] 25 + # must use raw MetaKit calls because VFS is not yet in place 26 + set d [mk::select exe.dirs parent 0 name lib] 27 + set d [mk::select exe.dirs parent $d name vfs] 26 28 27 - foreach x {vfsUtils vfslib mk4vfs} { 28 - set n [${::tclkitMkNamespace}::select exe.dirs!$d.files name $x.tcl] 29 - set s [${::tclkitMkNamespace}::get exe.dirs!$d.files!$n contents] 30 - catch {set s [zlib decompress $s]} 31 - uplevel #0 $s 32 - } 29 + foreach x {vfsUtils vfslib mk4vfs} { 30 + set n [mk::select exe.dirs!$d.files name $x.tcl] 31 + set s [mk::get exe.dirs!$d.files!$n contents] 32 + catch {set s [zlib decompress $s]} 33 + uplevel #0 $s 34 + } 35 + 36 + # use on-the-fly decompression, if mk4vfs understands that 37 + set mk4vfs::zstreamed 1 38 + 39 + # Set VFS handler name 40 + set vfsHandler [list ::vfs::mk4::handler exe] 41 + } 42 + "zip" { 43 + set prefix "lib/vfs" 44 + foreach file [list vfsUtils vfslib] { 45 + set fullfile "${prefix}/${file}.tcl" 46 + 47 + ::zip::stat $::tclKitStorage_fd $fullfile finfo 48 + seek $::tclKitStorage_fd $finfo(ino) 49 + zip::Data $::tclKitStorage_fd sb s 50 + 51 + switch -- $file { 52 + "vfsUtils" { 53 + # Preserve our working "::vfs::zip" implementation 54 + # so we can replace it after the stub is replaced 55 + # from vfsUtils 56 + # The correct implementation will be provided by vfslib, 57 + # but only if we can read it 58 + rename ::vfs::zip ::vfs::zip_impl 59 + } 60 + } 61 + 62 + uplevel #0 $s 63 + 64 + switch -- $file { 65 + "vfsUtils" { 66 + # Restore preserved "::vfs:zip" implementation 67 + rename ::vfs::zip {} 68 + rename ::vfs::zip_impl ::vfs::zip 69 + } 70 + } 71 + } 72 + 73 + seek $::tclKitStorage_fd 0 74 + set vfsHandler [list ::vfs::zip::handler $::tclKitStorage_fd] 75 + unset ::tclKitStorage_fd 76 + } 77 + } 78 + 79 + # mount the executable, i.e. make all runtime files available 80 + vfs::filesystem mount $noe $vfsHandler 81 + 82 + # alter path to find encodings 83 + if {[info tclversion] eq "8.4"} { 84 + load {} pwb 85 + librarypath [info library] 86 + } else { 87 + encoding dirs [list [file join [info library] encoding]] ;# TIP 258 88 + } 89 + 90 + # fix system encoding, if it wasn't properly set up (200207.004 bug) 91 + if {[encoding system] eq "identity"} { 92 + switch $::tcl_platform(platform) { 93 + windows { encoding system cp1252 } 94 + macintosh { encoding system macRoman } 95 + default { encoding system iso8859-1 } 96 + } 97 + } 98 + 99 + # now remount the executable with the correct encoding 100 + vfs::filesystem unmount [lindex [::vfs::filesystem info] 0] 101 + 102 + set noe [info nameofexecutable] 103 + 104 + # Resolve symlinks 105 + set noe [file dirname [file normalize [file join $noe __dummy__]]] 33 106 34 - # use on-the-fly decompression, if mk4vfs understands that 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 - } 107 + set tcl_library [file join $noe lib tcl$tcl_version] 108 + set tcl_libPath [list $tcl_library [file join $noe lib]] 45 109 46 - # mount the executable, i.e. make all runtime files available 47 - vfs::filesystem mount $noe [list ::vfs::${vfsimpl}::handler exe] 48 - 49 - # alter path to find encodings 50 - if {[info tclversion] eq "8.4"} { 51 - load {} pwb 52 - librarypath [info library] 53 - } else { 54 - encoding dirs [list [file join [info library] encoding]] ;# TIP 258 55 - } 110 + vfs::filesystem mount $noe $vfsHandler 111 + } 112 + 113 + # load config settings file if present 114 + namespace eval ::vfs { variable tclkit_version 1 } 115 + catch { uplevel #0 [list source [file join $noe config.tcl]] } 56 116 57 - # fix system encoding, if it wasn't properly set up (200207.004 bug) 58 - if {[encoding system] eq "identity"} { 59 - switch $::tcl_platform(platform) { 60 - windows { encoding system cp1252 } 61 - macintosh { encoding system macRoman } 62 - default { encoding system iso8859-1 } 63 - } 64 - } 65 - 66 - # now remount the executable with the correct encoding 67 - #vfs::filesystem unmount $noe 68 - vfs::filesystem unmount [lindex [::vfs::filesystem info] 0] 69 - 70 - set noe [info nameofexecutable] 71 - 72 - # Resolve symlinks 73 - set noe [file dirname [file normalize [file join $noe __dummy__]]] 74 - 75 - set tcl_library [file join $noe lib tcl$tcl_version] 76 - set tcl_libPath [list $tcl_library [file join $noe lib]] 77 - vfs::filesystem mount $noe [list ::vfs::${vfsimpl}::handler exe] 78 - } 117 + uplevel #0 [list source [file join $tcl_library init.tcl]] 79 118 80 - # load config settings file if present 81 - namespace eval ::vfs { variable tclkit_version 1 } 82 - catch { uplevel #0 [list source [file join $noe config.tcl]] } 119 + # reset auto_path, so that init.tcl's search outside of tclkit is cancelled 120 + set auto_path $tcl_libPath 83 121 84 - uplevel #0 [list source [file join $tcl_library init.tcl]] 85 - 86 -# reset auto_path, so that init.tcl's search outside of tclkit is cancelled 87 - set auto_path $tcl_libPath 122 + # This loads everything needed for "clock scan" to work 123 + # "clock scan" is used within "vfs::zip", which may be 124 + # loaded before this is run causing the root VFS to break 125 + catch { clock scan } 88 126 89 - unset ::tclkitMkNamespace 127 + # Cleanup 128 + unset ::tclKitStorage 129 + unset -nocomplain ::tclKitStorage_fd 90 130 }
Modified kitsh/buildsrc/kitsh-0.0/installvfs.tcl from [848dac55a9] to [3a059dfee8].
1 1 #! /usr/bin/env tclsh 2 2 3 +# Parse arguments 3 4 set opt_compression 1 4 5 if {[llength $argv] < 2} { 5 6 puts stderr "Usage: installvfs.tcl <kitfile> <vfsdir> \[<enable_compression>\]" 6 7 7 8 exit 1 8 9 } 9 10 10 11 set kitfile [lindex $argv 0] 11 12 set vfsdir [lindex $argv 1] 12 13 if {[lindex $argv 2] != ""} { 13 14 set opt_compression [lindex $argv 2] 14 15 } 15 16 16 -if {[catch { 17 - package require vfs::mk4 18 -}]} { 19 - catch { 20 - load "" vfs 21 - load "" Mk4tcl 17 +# Determine what storage mechanism is being used 18 +## This logic must be duplicated from "kitInit.c" 19 +set fd [open Makefile r] 20 +set data [read $fd] 21 +close $fd 22 22 23 - source [file join $vfsdir lib/vfs/vfsUtils.tcl] 24 - source [file join $vfsdir lib/vfs/vfslib.tcl] 25 - source [file join $vfsdir lib/vfs/mk4vfs.tcl] 26 - } 23 +if {[string match "*KIT_INCLUDES_MK4TCL*" $data]} { 24 + set tclKitStorage mk4 25 +} else { 26 + set tclKitStorage zip 27 27 } 28 -set mk4vfs::compress $opt_compression 29 28 29 +# Define procedures 30 30 proc copy_file {srcfile destfile} { 31 31 switch -glob -- $srcfile { 32 32 "*.tcl" - "*.txt" { 33 33 set ifd [open $srcfile r] 34 34 set ofd [open $destfile w] 35 35 36 36 set ret [fcopy $ifd $ofd] ................................................................................ 61 61 copy_file $file $destfile 62 62 } err]} { 63 63 puts stderr "Failed to copy: $file: $err" 64 64 } 65 65 } 66 66 } 67 67 68 -set handle [vfs::mk4::Mount $kitfile /kit -nocommit] 68 +# Update the kit, based on what kind of kit this is 69 +switch -- $tclKitStorage { 70 + "mk4" { 71 + if {[catch { 72 + # Try as if a pre-existing Tclkit, or a tclsh 73 + package require vfs::mk4 74 + }]} { 75 + # Try as if uninitialized Tclkit 76 + catch { 77 + load "" vfs 78 + load "" Mk4tcl 79 + 80 + source [file join $vfsdir lib/vfs/vfsUtils.tcl] 81 + source [file join $vfsdir lib/vfs/vfslib.tcl] 82 + source [file join $vfsdir lib/vfs/mk4vfs.tcl] 83 + } 84 + } 85 + set mk4vfs::compress $opt_compression 86 + 87 + set handle [vfs::mk4::Mount $kitfile /kit -nocommit] 88 + 89 + recursive_copy $vfsdir /kit 90 + 91 + vfs::unmount /kit 92 + } 93 + "zip" { 94 + set kitfd [open $kitfile a+] 95 + fconfigure $kitfd -translation binary 96 + 97 + cd $vfsdir 98 + set zipfd [open "|zip -r - [glob *] 2> /dev/null"] 99 + fconfigure $zipfd -translation binary 100 + 101 + fcopy $zipfd $kitfd 69 102 70 -recursive_copy $vfsdir /kit 103 + close $kitfd 104 + if {[catch { 105 + close $zipfd 106 + } err]} { 107 + puts stderr "Error while updating executable: $err" 71 108 72 -vfs::unmount /kit 109 + exit 1 110 + } 111 + } 112 +}
Modified kitsh/buildsrc/kitsh-0.0/kitInit.c from [f0bdde86c9] to [1ea5ee25a0].
12 12 * See the file "license.terms" for information on usage and redistribution 13 13 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 14 14 * 15 15 * RCS: @(#) $Id$ 16 16 */ 17 17 18 18 #ifdef KIT_INCLUDES_TK 19 -#include <tk.h> 19 +# include <tk.h> 20 20 #else 21 -#include <tcl.h> 22 -#endif 21 +# include <tcl.h> 22 +#endif /* KIT_INCLUDES_TK */ 23 23 24 24 #ifdef _WIN32 25 -#define WIN32_LEAN_AND_MEAN 26 -#include <windows.h> 27 -#undef WIN32_LEAN_AND_MEAN 28 -#endif 25 +# define WIN32_LEAN_AND_MEAN 26 +# include <windows.h> 27 +# undef WIN32_LEAN_AND_MEAN 28 +#endif /* _WIN32 */ 29 29 30 30 #ifndef MB_TASKMODAL 31 -#define MB_TASKMODAL 0 32 -#endif 31 +# define MB_TASKMODAL 0 32 +#endif /* MB_TASKMODAL */ 33 33 34 34 #include "tclInt.h" 35 35 36 36 #ifdef KIT_INCLUDES_ITCL 37 37 Tcl_AppInitProc Itcl_Init; 38 38 #endif 39 39 #ifdef KIT_INCLUDES_MK4TCL ................................................................................ 46 46 #ifdef TCL_THREADS 47 47 Tcl_AppInitProc Thread_Init; 48 48 #endif 49 49 #ifdef _WIN32 50 50 Tcl_AppInitProc Dde_Init, Registry_Init; 51 51 #endif 52 52 53 -char *tclExecutableName; 53 +/* Determine which type of storage to use -- MK4 or ZIP */ 54 +#if defined(KIT_STORAGE_MK4) && defined(KIT_STORAGE_ZIP) 55 +# undef KIT_STORAGE_ZIP 56 +#endif 57 +#if !defined(KIT_STORAGE_MK4) && !defined(KIT_STORAGE_ZIP) 58 +# ifdef KIT_INCLUDES_MK4TCL 59 +# define KIT_STORAGE_MK4 1 60 +# else 61 +# define KIT_STORAGE_ZIP 1 62 +# endif 63 +#endif 64 + 65 +static char *tclExecutableName; 54 66 55 67 /* 56 68 * Attempt to load a "boot.tcl" entry from the embedded MetaKit file. 57 69 * If there isn't one, try to open a regular "setup.tcl" file instead. 58 70 * If that fails, this code will throw an error, using a message box. 59 71 */ 60 72 ................................................................................ 61 73 static char *preInitCmd = 62 74 #ifdef _WIN32_WCE 63 75 /* silly hack to get wince port to launch, some sort of std{in,out,err} problem */ 64 76 "open /kitout.txt a; open /kitout.txt a; open /kitout.txt a\n" 65 77 /* this too seems to be needed on wince - it appears to be related to the above */ 66 78 "catch {rename source ::tcl::source}\n" 67 79 "proc source file {\n" 68 - "set old [info script]\n" 69 - "info script $file\n" 70 - "set fid [open $file]\n" 71 - "set data [read $fid]\n" 72 - "close $fid\n" 73 - "set code [catch {uplevel 1 $data} res]\n" 74 - "info script $old\n" 75 - "if {$code == 2} { set code 0 }\n" 76 - "return -code $code $res\n" 80 + "set old [info script]\n" 81 + "info script $file\n" 82 + "set fid [open $file]\n" 83 + "set data [read $fid]\n" 84 + "close $fid\n" 85 + "set code [catch {uplevel 1 $data} res]\n" 86 + "info script $old\n" 87 + "if {$code == 2} { set code 0 }\n" 88 + "return -code $code $res\n" 77 89 "}\n" 78 -#endif 90 +#endif /* _WIN32_WCE */ 79 91 "proc tclKitInit {} {\n" 80 - "rename tclKitInit {}\n" 81 -#ifdef KIT_INCLUDES_MK4TCL 82 - "catch { load {} Mk4tcl }\n" 83 - "set ::tclkitMkNamespace \"mk\"\n" 84 -#else 85 -#include "mk4tcl.tcl.h" 86 - "set ::tclkitMkNamespace \"readkit\"\n" 87 -#endif 88 - "${::tclkitMkNamespace}::file open exe [info nameofexecutable] -readonly\n" 89 - "set n [${::tclkitMkNamespace}::select exe.dirs!0.files name boot.tcl]\n" 90 - "if {$n != \"\"} {\n" 91 - "set s [${::tclkitMkNamespace}::get exe.dirs!0.files!$n contents]\n" 92 - "if {![string length $s]} { error \"empty boot.tcl\" }\n" 93 - "catch {load {} zlib}\n" 94 - "if {[${::tclkitMkNamespace}::get exe.dirs!0.files!$n size] != [string length $s]} {\n" 95 - "set s [zlib decompress $s]\n" 92 + "rename tclKitInit {}\n" 93 +#ifdef KIT_STORAGE_MK4 94 + "set ::tclKitStorage \"mk4\"\n" 95 + "catch { load {} Mk4tcl }\n" 96 + "mk::file open exe [info nameofexecutable] -readonly\n" 97 + "set n [mk::select exe.dirs!0.files name boot.tcl]\n" 98 + "if {$n != \"\"} {\n" 99 + "set s [mk::get exe.dirs!0.files!$n contents]\n" 100 + "if {![string length $s]} { error \"empty boot.tcl\" }\n" 101 + "catch {load {} zlib}\n" 102 + "if {[mk::get exe.dirs!0.files!$n size] != [string length $s]} {\n" 103 + "set s [zlib decompress $s]\n" 104 + "}\n" 105 + "}\n" 106 +#endif /* KIT_STORAGE_MK4 */ 107 +#ifdef KIT_STORAGE_ZIP 108 + "set ::tclKitStorage \"zip\"\n" 109 + "catch { load {} vfs }\n" 110 +# include "zipvfs.tcl.h" 111 + "set ::tclKitStorage_fd [zip::open [info nameofexecutable]]\n" 112 + "if {![catch { ::zip::stat $::tclKitStorage_fd boot.tcl sb }]} {\n" 113 + "seek $::tclKitStorage_fd $sb(ino)\n" 114 + "zip::Data $::tclKitStorage_fd sb s\n" 115 + "}\n" 116 +#endif /* KIT_STORAGE_ZIP */ 117 + "if {![info exists s]} {\n" 118 + "set f [open setup.tcl]\n" 119 + "set s [read $f]\n" 120 + "close $f\n" 96 121 "}\n" 97 - "} else {\n" 98 - "set f [open setup.tcl]\n" 99 - "set s [read $f]\n" 100 - "close $f\n" 101 - "}\n" 102 - "uplevel #0 $s\n" 122 + "uplevel #0 $s\n" 103 123 #ifdef _WIN32 104 - "catch {load {} dde}\n" 105 - "catch {load {} registry}\n" 106 -#endif 124 + "catch {load {} dde}\n" 125 + "catch {load {} registry}\n" 126 +#endif /* _WIN32 */ 127 + "return 0\n" 107 128 "}\n" 108 -"tclKitInit" 109 -; 129 +"tclKitInit"; 110 130 111 131 static const char initScript[] = 112 132 "if {[file isfile [file join [info nameofexe] main.tcl]]} {\n" 113 - "if {[info commands console] != {}} { console hide }\n" 114 - "set tcl_interactive 0\n" 115 - "incr argc\n" 116 - "set argv [linsert $argv 0 $argv0]\n" 117 - "set argv0 [file join [info nameofexe] main.tcl]\n" 118 -"} else continue\n" 119 -; 133 + "if {[info commands console] != {}} { console hide }\n" 134 + "set tcl_interactive 0\n" 135 + "incr argc\n" 136 + "set argv [linsert $argv 0 $argv0]\n" 137 + "set argv0 [file join [info nameofexe] main.tcl]\n" 138 +"} else continue\n"; 120 139 121 140 /* SetExecName -- 122 141 123 142 Hack to get around Tcl bug 1224888. 124 143 */ 125 - 126 144 void SetExecName(Tcl_Interp *interp) { 127 - if (tclExecutableName == NULL) { 128 - int len = 0; 129 - Tcl_Obj *execNameObj; 130 - Tcl_Obj *lobjv[1]; 145 + if (tclExecutableName == NULL) { 146 + int len = 0; 147 + Tcl_Obj *execNameObj; 148 + Tcl_Obj *lobjv[1]; 149 + 150 + lobjv[0] = Tcl_GetVar2Ex(interp, "argv0", NULL, TCL_GLOBAL_ONLY); 151 + execNameObj = Tcl_FSJoinToPath(Tcl_FSGetCwd(interp), 1, lobjv); 131 152 132 - lobjv[0] = Tcl_GetVar2Ex(interp, "argv0", NULL, TCL_GLOBAL_ONLY); 133 - execNameObj = Tcl_FSJoinToPath(Tcl_FSGetCwd(interp), 1, lobjv); 134 - 135 - tclExecutableName = strdup(Tcl_GetStringFromObj(execNameObj, &len)); 136 - } 153 + tclExecutableName = strdup(Tcl_GetStringFromObj(execNameObj, &len)); 154 + } 137 155 } 138 156 139 -int 140 -TclKit_AppInit(Tcl_Interp *interp) 141 -{ 157 +int TclKit_AppInit(Tcl_Interp *interp) { 142 158 #ifdef KIT_INCLUDES_ITCL 143 - Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL); 159 + Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL); 144 160 #endif 145 161 #ifdef KIT_INCLUDES_MK4TCL 146 - Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL); 162 + Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL); 147 163 #endif 148 164 #if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85 149 - Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL); 165 + Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL); 150 166 #endif 151 - Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL); 152 - Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL); 153 - Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL); 167 + Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL); 168 + Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL); 169 + Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL); 154 170 #ifdef TCL_THREADS 155 - Tcl_StaticPackage(0, "Thread", Thread_Init, NULL); 171 + Tcl_StaticPackage(0, "Thread", Thread_Init, NULL); 156 172 #endif 157 173 #ifdef _WIN32 158 - Tcl_StaticPackage(0, "dde", Dde_Init, NULL); 159 - Tcl_StaticPackage(0, "registry", Registry_Init, NULL); 174 + Tcl_StaticPackage(0, "dde", Dde_Init, NULL); 175 + Tcl_StaticPackage(0, "registry", Registry_Init, NULL); 160 176 #endif 161 177 #ifdef KIT_INCLUDES_TK 162 - Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit); 178 + Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit); 163 179 #endif 164 180 165 - /* the tcl_rcFileName variable only exists in the initial interpreter */ 181 + /* the tcl_rcFileName variable only exists in the initial interpreter */ 166 182 #ifdef _WIN32 167 - Tcl_SetVar(interp, "tcl_rcFileName", "~/tclkitrc.tcl", TCL_GLOBAL_ONLY); 183 + Tcl_SetVar(interp, "tcl_rcFileName", "~/tclkitrc.tcl", TCL_GLOBAL_ONLY); 168 184 #else 169 - Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclkitrc", TCL_GLOBAL_ONLY); 185 + Tcl_SetVar(interp, "tcl_rcFileName", "~/.tclkitrc", TCL_GLOBAL_ONLY); 170 186 #endif 171 187 172 - /* Hack to get around Tcl bug 1224888. This must be run here and 173 - * in LibraryPathObjCmd because this information is needed both 174 - * before and after that command is run. */ 175 - SetExecName(interp); 188 + /* Hack to get around Tcl bug 1224888. This must be run here and 189 + * in LibraryPathObjCmd because this information is needed both 190 + * before and after that command is run. */ 191 + SetExecName(interp); 176 192 177 - TclSetPreInitScript(preInitCmd); 178 - if (Tcl_Init(interp) == TCL_ERROR) 179 - goto error; 193 + TclSetPreInitScript(preInitCmd); 194 + if (Tcl_Init(interp) == TCL_ERROR) { 195 + goto error; 196 + } 180 197 181 198 #ifdef KIT_INCLUDES_TK 182 -#ifdef _WIN32 183 - if (Tk_Init(interp) == TCL_ERROR) 184 - goto error; 185 - if (Tk_CreateConsoleWindow(interp) == TCL_ERROR) 186 - goto error; 187 -#endif 188 -#endif 199 +# ifdef _WIN32 200 + if (Tk_Init(interp) == TCL_ERROR) { 201 + goto error; 202 + } 203 + if (Tk_CreateConsoleWindow(interp) == TCL_ERROR) { 204 + goto error; 205 + } 206 +# endif /* _WIN32 */ 207 +#endif /* KIT_INCLUDES_TK */ 189 208 190 - /* messy because TclSetStartupScriptPath is called slightly too late */ 191 - if (Tcl_Eval(interp, initScript) == TCL_OK) { 192 - Tcl_Obj* path; 209 + /* messy because TclSetStartupScriptPath is called slightly too late */ 210 + if (Tcl_Eval(interp, initScript) == TCL_OK) { 211 + Tcl_Obj* path; 193 212 #ifdef HAVE_TCLSETSTARTUPSCRIPTPATH 194 - path = TclGetStartupScriptPath(); 195 - TclSetStartupScriptPath(Tcl_GetObjResult(interp)); 196 -#else 197 -# ifdef HAVE_TCL_SETSTARTUPSCRIPT 198 - path = Tcl_GetStartupScript(NULL); 199 - Tcl_SetStartupScript(Tcl_GetObjResult(interp), NULL); 200 -# endif 213 + path = TclGetStartupScriptPath(); 214 + TclSetStartupScriptPath(Tcl_GetObjResult(interp)); 215 +#elif defined(HAVE_TCL_SETSTARTUPSCRIPT) 216 + path = Tcl_GetStartupScript(NULL); 217 + Tcl_SetStartupScript(Tcl_GetObjResult(interp), NULL); 201 218 #endif 202 - if (path == NULL) 203 - Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]"); 204 - } 219 + if (path == NULL) { 220 + Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]"); 221 + } 222 + } 223 + 224 + Tcl_SetVar(interp, "errorInfo", "", TCL_GLOBAL_ONLY); 225 + Tcl_ResetResult(interp); 205 226 206 - Tcl_SetVar(interp, "errorInfo", "", TCL_GLOBAL_ONLY); 207 - Tcl_ResetResult(interp); 208 - return TCL_OK; 227 + return TCL_OK; 209 228 210 229 error: 211 230 #ifdef KIT_INCLUDES_TK 212 -#ifdef _WIN32 213 - MessageBeep(MB_ICONEXCLAMATION); 214 -#ifndef _WIN32_WCE 215 - MessageBox(NULL, Tcl_GetStringResult(interp), "Error in TclKit", 216 - MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); 217 - ExitProcess(1); 218 -#endif 231 +# ifdef _WIN32 232 + MessageBeep(MB_ICONEXCLAMATION); 233 +# ifndef _WIN32_WCE 234 + MessageBox(NULL, Tcl_GetStringResult(interp), "Error in TclKit", 235 + MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); 236 + 237 + ExitProcess(1); 238 +# endif /* !_WIN32_WCE */ 219 239 /* we won't reach this, but we need the return */ 220 -#endif 221 -#endif 222 - return TCL_ERROR; 240 +# endif /* _WIN32 */ 241 +#endif /* KIT_INCLUDES_TK */ 242 + 243 + return TCL_ERROR; 223 244 }
Deleted kitsh/buildsrc/kitsh-0.0/mk4tcl-new.tcl version [737d3e66d5].
1 -#! /usr/bin/env tclsh 2 - 3 -namespace eval ::mk {} 4 -namespace eval ::mk::file {} 5 -namespace eval ::mk::view {} 6 -namespace eval ::mk::cursor {} 7 -namespace eval ::mk::row {} 8 -namespace eval ::mk::private {} 9 - 10 -proc ::mk::file {cmd args} { 11 - set args [lindex $args 0 ::mk::file::${cmd}] 12 - 13 - return [eval $args] 14 -} 15 - 16 -proc ::mk::file::open {args} { 17 - if {[llength $args] == 0} { 18 - # Return open tags 19 - 20 - set retval [list] 21 - foreach tag [array names ::mk::private::tags] { 22 - unset -nocomplain taginfo 23 - array set taginfo $::mk::private::tags($tag) 24 - 25 - lappend retval $tag $taginfo(file) 26 - } 27 - 28 - return 29 - } 30 - 31 - set tag [lindex $args 0] 32 - if {[info exists ::mk::private::tags($tag)]} { 33 - return -code error "tag is already open" 34 - } 35 - 36 - set taginfo(writable) 1 37 - set taginfo(commit_on_close) 1 38 - set taginfo(commit_on_set) 0 39 - set taginfo(extend) 0 40 - set taginfo(shared) 0 41 - 42 - if {[llength $args] == 1} { 43 - # Use in-memory file 44 - 45 - set taginfo(file) "" 46 - set taginfo(fd) "" 47 - } else { 48 - set filename [lindex $args 1] 49 - 50 - foreach opt [lrange $args 2 end] { 51 - switch -- $opt { 52 - "-readonly" { 53 - set taginfo(writable) 0 54 - } 55 - "-nocommit" { 56 - set taginfo(commit_on_close) 0 57 - } 58 - "-extend" { 59 - set taginfo(extend) 1 60 - } 61 - "-shared" { 62 - set taginfo(shared) 1 63 - } 64 - } 65 - } 66 - 67 - if {$taginfo(writable)} { 68 - set fd [open $filename a+] 69 - seek $fd 0 start 70 - } else { 71 - set fd [open $filename r] 72 - } 73 - 74 - set taginfo(file) $filename 75 - set taginfo(fd) $fd 76 - } 77 - 78 - set ::mk::private::changes($tag) [list] 79 - set ::mk::private::tags($tag) [array get taginfo] 80 -} 81 - 82 -proc ::mk::file::close {tag} { 83 - if {![info exists ::mk::private::tags($tag)]} { 84 - return -code error "no storage with this name" 85 - } 86 - 87 - array set taginfo $::mk::private::tags($tag) 88 - 89 - if {$taginfo(commit_on_close) && $taginfo(writable) && $taginfo(fd) != ""} { 90 - mk::file commit $tag -full 91 - } 92 - 93 - if {$taginfo(fd) != ""} { 94 - close $taginfo(fd) 95 - } 96 - 97 - unset ::mk::private::changes($tag) 98 - unset ::mk::private::tags($tag) 99 -} 100 - 101 -proc ::mk::file::views {{tag ""}} { 102 - return -code error "Not Implemented" 103 -} 104 - 105 -proc ::mk::file::commit {tag {fullOpt ""}} { 106 - if {![info exists ::mk::private::tags($tag)]} { 107 - return -code error "no storage with this name" 108 - } 109 - 110 - array set taginfo $::mk::private::tags($tag) 111 - 112 - if {$fullOpt == "-full"} { 113 - # Flush asides 114 - # XXX: TODO 115 - } 116 - 117 - if {$taginfo(fd) == ""} { 118 - # We can't commit if we weren't asked to write to stable 119 - # storage 120 - return 121 - } 122 - 123 - # XXX: TODO 124 - return -code error "Not Implemented" 125 -} 126 - 127 -proc ::mk::file::rollback {tag {fullOpt ""}} { 128 - if {![info exists ::mk::private::tags($tag)]} { 129 - return -code error "no storage with this name" 130 - } 131 - 132 - if {$fullOpt == "-full"} { 133 - # Clear asides ... 134 - # XXX: TODO 135 - } 136 - 137 - set ::mk::private::changes($tag) "" 138 -} 139 - 140 -proc ::mk::file::load {{tag ""} {channel ""}} { 141 - return -code error "Not Implemented" 142 -} 143 - 144 -proc ::mk::file::save {{tag ""} {channel ""}} { 145 - return -code error "Not Implemented" 146 -} 147 - 148 -proc ::mk::file::aside {{tag1 ""} {tag2 ""}} { 149 - return -code error "Not Implemented" 150 -} 151 - 152 -proc ::mk::file::autocommit {tag} { 153 - if {![info exists ::mk::private::tags($tag)]} { 154 - return -code error "no storage with this name" 155 - } 156 - 157 - array set taginfo $::mk::private::tags($tag) 158 - 159 - set taginfo(commit_on_close) 1 160 - 161 - set ::mk::private::tags($tag) [array get taginfo] 162 -} 163 - 164 -proc ::mk::view {cmd args} { 165 - return -code error "Not Implemented" 166 -} 167 - 168 -proc ::mk::cursor {cmd args} { 169 - return -code error "Not Implemented" 170 -} 171 - 172 -proc ::mk::row {cmd args} { 173 - return -code error "Not Implemented" 174 -} 175 - 176 -proc ::mk::get {args} { 177 - return -code error "Not Implemented" 178 -} 179 - 180 -proc ::mk::set {args} { 181 - return -code error "Not Implemented" 182 -} 183 - 184 -proc ::mk::loop {args} { 185 - return -code error "Not Implemented" 186 -} 187 - 188 -proc ::mk::select {args} { 189 - return -code error "Not Implemented" 190 -} 191 - 192 -proc ::mk::channel {args} { 193 - return -code error "Not Implemented" 194 -} 195 - 196 -package provide Mk4tcl 2.4.9.6
Deleted kitsh/buildsrc/kitsh-0.0/mk4tcl.tcl version [320b85c042].
1 -#! /usr/bin/env tclsh 2 -# ReadKit, a viewer/extractor/converter for starkits which does not 3 -# require TclKit or MetaKit. This file was generated by "rkgen.tcl". 4 -# 5 -# June 2002, Jean-Claude Wippler <jcw@equi4.com> 6 - 7 -# this is needed so often that I just drop copies of it all over the place 8 -if {![info exists auto_index(lassign)] && [info commands lassign] == ""} { 9 - proc lassign {l args} { 10 - foreach v $l a $args { uplevel 1 [list set $a $v] } 11 - } 12 -} 13 - 14 -catch { 15 - load {} zlib 16 -} 17 -catch { 18 - package require zlib 19 -} 20 - 21 -if {[info comm mmap] == ""} { 22 - # mmap and mvec primitives in pure Tcl (a C version is present in critlib) 23 - 24 - namespace export mmap mvec 25 - 26 - namespace eval v { 27 - array set mmap_data {} 28 - array set mvec_shifts { 29 - - -1 0 -1 30 - 1 0 2 1 4 2 8 3 31 - 16 4 16r 4 32 - 32 5 32r 5 32f 5 32fr 5 33 - 64 6 64r 6 64f 6 64fr 6 } 34 - } 35 - 36 - proc mmap {fd args} { 37 - upvar #0 v::mmap_data($fd) data 38 - # special case if fd is the name of a variable (qualified or global) 39 - if {[uplevel #0 [list info exists $fd]]} { 40 - upvar #0 $fd var 41 - set data $var 42 - } 43 - # cache a full copy of the file to simulate memory mapping 44 - if {![info exists data]} { 45 - set pos [tell $fd] 46 - seek $fd 0 end 47 - set end [tell $fd] 48 - seek $fd 0 49 - set trans [fconfigure $fd -translation] 50 - fconfigure $fd -translation binary 51 - set data [read $fd $end] 52 - fconfigure $fd -translation $trans 53 - seek $fd $pos 54 - } 55 - set total [string length $data] 56 - if {[llength $args] == 0} { 57 - return $total 58 - } 59 - foreach {off len} $args break 60 - if {$len < 0} { 61 - set len $total 62 - } 63 - if {$len < 0 || $len > $total - $off} { 64 - set len [expr {$total - $off}] 65 - } 66 - binary scan $data @${off}a$len s 67 - return $s 68 - } 69 - 70 - proc mvec {v args} { 71 - foreach {mode data off len} $v break 72 - if {[info exists v::mvec_shifts($mode)]} { 73 - # use _mvec_get to access elements 74 - set shift $v::mvec_shifts($mode) 75 - if {[llength $v] < 4} { 76 - set len $off 77 - } 78 - set get [list _mvec_get $shift $v *] 79 - } else { 80 - # virtual mode, set to evaluate script 81 - set shift "" 82 - set len [lindex $v end] 83 - set get $v 84 - } 85 - # try to derive vector length from data length if not specified 86 - if {$len == "" || $len < 0} { 87 - set len 0 88 - if {$shift >= 0} { 89 - if {[llength $v] < 4} { 90 - set n [string length $data] 91 - } else { 92 - set n [mmap $data] 93 - } 94 - set len [expr {($n << 3) >> $shift}] 95 - } 96 - } 97 - set nargs [llength $args] 98 - # with just a varname as arg, return info about this vector 99 - if {$nargs == 0} { 100 - if {$shift == ""} { 101 - return [list $len {} $v] 102 - } 103 - return [list $len $mode $shift] 104 - } 105 - foreach {pos count pred cond} $args break 106 - # with an index as second arg, do a single access and return element 107 - if {$nargs == 1} { 108 - return [uplevel 1 [lreplace $get end end $pos]] 109 - } 110 - if {$count < 0} { 111 - set count $len 112 - } 113 - if {$count > $len - $pos && $shift != -1} { 114 - set count [expr {$len - $pos}] 115 - } 116 - if {$nargs == 4} { 117 - upvar $pred x 118 - } 119 - set r {} 120 - incr count $pos 121 - # loop through specified range to build result vector 122 - # with four args, used that as predicate function to filter 123 - # with five args, use fourth as loop var and apply fifth as condition 124 - for {set x $pos} {$x < $count} {incr x} { 125 - set y [uplevel 1 [lreplace $get end end $x]] 126 - switch $nargs { 127 - 3 { 128 - if {![uplevel 1 [list $pred $v $x $y]]} continue 129 - } 130 - 4 { 131 - if {![uplevel 1 [list expr $cond]]} continue 132 - } 133 - } 134 - lappend r $y 135 - } 136 - return $r 137 - } 138 - 139 - proc _mvec_get {shift desc index} { 140 - foreach {mode data off len} $desc break 141 - switch -- $mode { 142 - - { 143 - return $index 144 - } 145 - 0 { 146 - return $data 147 - } 148 - } 149 - if {[llength $desc] < 4} { 150 - set off [expr {($index << $shift) >> 3}] 151 - } else { 152 - # don't load more than 8 bytes from the proper offset 153 - incr off [expr {($index << $shift) >> 3}] 154 - set data [mmap $data $off 8] 155 - set off 0 156 - } 157 - switch -- $mode { 158 - 1 { 159 - binary scan $data @${off}c value 160 - return [expr {($value>>($index&7)) &1}] 161 - } 162 - 2 { 163 - binary scan $data @${off}c value 164 - return [expr {($value>>(($index&3) <<1)) &3}] 165 - } 166 - 4 { 167 - binary scan $data @${off}c value 168 - return [expr {($value>>(($index&1) <<2)) &15}] 169 - } 170 - 8 { 171 - set w 1 172 - set f c 173 - } 174 - 16 { 175 - set w 2 176 - set f s 177 - } 178 - 16r { 179 - set w 2 180 - set f S 181 - } 182 - 32 { 183 - set w 4 184 - set f i 185 - } 186 - 32r { 187 - set w 4 188 - set f I 189 - } 190 - 32fr - 191 - 32f { 192 - set w 4 193 - set f f 194 - } 195 - 64 - 196 - 64r { 197 - set w 8 198 - set f i2 199 - } 200 - 64fr - 201 - 64f { 202 - set w 8 203 - set f d 204 - } 205 - } 206 - 207 - binary scan $data @$off$f value 208 - return $value 209 - } 210 - 211 - # vim: ft=tcl 212 - 213 -} 214 - 215 -if {[info comm dbopen] == ""} { 216 - # Decoder for MetaKit datafiles in Tcl 217 - 218 - # requires mmap/mvec primitives: 219 - #source [file join [info dirname [info script]] mvprim.tcl] 220 - 221 - namespace export dbopen dbclose dbtree access vnames vlen 222 - 223 - namespace eval v { 224 - variable widths { 225 - {8 16 1 32 2 4} 226 - {4 8 1 16 2 0} 227 - {2 4 8 1 0 16} 228 - {2 4 0 8 1 0} 229 - {1 2 4 0 8 0} 230 - {1 2 4 0 0 8} 231 - {1 2 0 4 0 0} } 232 - } 233 - 234 - proc fetch {file} { 235 - if {$file == ""} { 236 - error "temp storages not supported" 237 - } 238 - set v::data [open $file] 239 - set v::seqn 0 240 - } 241 - 242 - proc byte_seg {off len} { 243 - incr off $v::zero 244 - return [mmap $v::data $off $len] 245 - } 246 - 247 - proc int_seg {off cnt} { 248 - set vec [list 32r [byte_seg $off [expr {4*$cnt}]]] 249 - return [mvec $vec 0 $cnt] 250 - } 251 - 252 - proc get_s {len} { 253 - set s [byte_seg $v::curr $len] 254 - incr v::curr $len 255 - return $s 256 - } 257 - 258 - proc get_v {} { 259 - set v 0 260 - while 1 { 261 - set char [mvec $v::byte $v::curr] 262 - incr v::curr 263 - set v [expr {$v*128+($char&0xff)}] 264 - if {$char < 0} { 265 - return [incr v -128] 266 - } 267 - } 268 - } 269 - 270 - proc get_p {rows vs vo} { 271 - upvar $vs size $vo off 272 - set off 0 273 - if {$rows == 0} { 274 - set size 0 275 - } else { 276 - set size [get_v] 277 - if {$size > 0} { 278 - set off [get_v] 279 - } 280 - } 281 - } 282 - 283 - proc header {{end ""}} { 284 - set v::zero 0 285 - if {$end == ""} { 286 - set end [mmap $v::data] 287 - } 288 - set v::byte [list 8 $v::data $v::zero $end] 289 - lassign [int_seg [expr {$end-16}] 4] t1 t2 t3 t4 290 - set v::zero [expr {$end-$t2-16}] 291 - incr end -$v::zero 292 - set v::byte [list 8 $v::data $v::zero $end] 293 - lassign [int_seg 0 2] h1 h2 294 - lassign [int_seg [expr {$h2-8}] 2] e1 e2 295 - set v::info(mkend) $h2 296 - set v::info(mktoc) $e2 297 - set v::info(mklen) [expr {$e1 & 0xffffff}] 298 - set v::curr $e2 299 - } 300 - 301 - proc layout {fmt} { 302 - regsub -all { } $fmt "" fmt 303 - regsub -all {(\w+)\[} $fmt "{\\1 {" fmt 304 - regsub -all {\]} $fmt "}}" fmt 305 - regsub -all {,} $fmt " " fmt 306 - return $fmt 307 - } 308 - 309 - proc descparse {desc} { 310 - set names {} 311 - set types {} 312 - foreach x $desc { 313 - if {[llength $x] == 1} { 314 - lassign [split $x :] name type 315 - if {$type == ""} { 316 - set type S 317 - } 318 - } else { 319 - lassign $x name type 320 - } 321 - lappend names $name 322 - lappend types $type 323 - } 324 - return [list $names $types] 325 - } 326 - 327 - proc numvec {rows type} { 328 - get_p $rows size off 329 - if {$size == 0} { 330 - return {0 0} 331 - } 332 - set w [expr {int(($size<<3) /$rows)}] 333 - if {$rows <= 7 && 0 < $size && $size <= 6} { 334 - set w [lindex [lindex $v::widths [expr {$rows-1}]] [expr {$size-1}]] 335 - } 336 - if {$w == 0} { 337 - error "numvec?" 338 - } 339 - switch $type\ 340 - F { 341 - set w 32f 342 - }\ 343 - D { 344 - set w 64f 345 - } 346 - incr off $v::zero 347 - return [list $w $v::data $off $rows] 348 - } 349 - 350 - proc lazy_str {self rows type pos sizes msize moff index} { 351 - set soff {} 352 - for {set i 0} {$i < $rows} {incr i} { 353 - set n [mvec $sizes $i] 354 - lappend soff $pos 355 - incr pos $n 356 - } 357 - if {$msize > 0} { 358 - set slen [mvec $sizes 0 $rows] 359 - set v::curr $moff 360 - set limit [expr {$moff+$msize}] 361 - for {set row 0} {$v::curr < $limit} {incr row} { 362 - incr row [get_v] 363 - get_p 1 ms mo 364 - set soff [lreplace $soff $row $row $mo] 365 - set slen [lreplace $slen $row $row $ms] 366 - } 367 - set sizes [list lindex $slen $rows] 368 - } 369 - if {$type == "S"} { 370 - set adj -1 371 - } else { 372 - set adj 0 373 - } 374 - set v::node($self) [list get_str $soff $sizes $adj $rows] 375 - return [mvec $v::node($self) $index] 376 - } 377 - 378 - proc get_str {soff sizes adj index} { 379 - set n [mvec $sizes $index] 380 - return [byte_seg [lindex $soff $index] [incr n $adj]] 381 - } 382 - 383 - proc lazy_sub {self desc size off rows index} { 384 - set v::curr $off 385 - lassign [descparse $desc] names types 386 - set subs {} 387 - for {set i 0} {$i < $rows} {incr i} { 388 - if {[get_v] != 0} { 389 - error "lazy_sub?" 390 - } 391 - lappend subs [prepare $types] 392 - } 393 - set v::node($self) [list get_sub $names $subs $rows] 394 - return [mvec $v::node($self) $index] 395 - } 396 - 397 -#proc backtrace {{level_adj 0}} { 398 -# set ret [list] 399 -# 400 -# set level [expr 0 - $level_adj] 401 -# for {set i [expr [info level] - $level_adj]} {$i > 1} {incr i -1} { 402 -# incr level -1 403 -# set ret [linsert $ret 0 [lindex [info level $level] 0]] 404 -# } 405 -# set ret [linsert $ret 0 GLOBAL] 406 -# 407 -# return $ret 408 -#} 409 - 410 - proc get_sub {names subs index} { 411 -#puts stderr "DEBUG: get_sub: [list $names $subs $index]" 412 -#puts "backtrace: [backtrace]" 413 - lassign [lindex $subs $index] rows handlers 414 - return [list get_view $names $rows $handlers $rows] 415 - } 416 - 417 - proc prepare {types} { 418 - set r [get_v] 419 - set handlers {} 420 - foreach x $types { 421 - set n [incr v::seqn] 422 - lappend handlers $n 423 - switch $x { 424 - I - 425 - L - 426 - F - 427 - D { 428 - set v::node($n) [numvec $r $x] 429 - } 430 - B - 431 - S { 432 - get_p $r size off 433 - set sizes {0 0} 434 - if {$size > 0} { 435 - set sizes [numvec $r I] 436 - } 437 - get_p $r msize moff 438 - set v::node($n) [list lazy_str $n $r $x $off $sizes\ 439 - $msize $moff $r] 440 - } 441 - default { 442 - get_p $r size off 443 - set v::node($n) [list lazy_sub $n $x $size $off $r $r] 444 - } 445 - } 446 - } 447 - return [list $r $handlers] 448 - } 449 - 450 - proc get_view {names rows handlers index} { 451 - return [list get_prop $names $rows $handlers $index [llength $names]] 452 - } 453 - 454 - proc get_prop {names rows handlers index ident} { 455 - set col [lsearch -exact $names $ident] 456 - if {$col < 0} { 457 - error "unknown property: $ident" 458 - } 459 - set h [lindex $handlers $col] 460 - set ret [mvec $v::node($h) $index] 461 - 462 - return $ret 463 - } 464 - 465 - proc dbopen {db file} { 466 - # open datafile, stores datafile descriptors and starts building tree 467 - if {$db == ""} { 468 - set r {} 469 - foreach {k v} [array get v::dbs] { 470 - lappend r $k [lindex $v 0] 471 - } 472 - return $r 473 - } 474 - fetch $file 475 - header 476 - if {[get_v] != 0} { 477 - error "dbopen?" 478 - } 479 - set desc [layout [get_s [get_v]]] 480 - lassign [descparse $desc] names types 481 - set root [get_sub $names [list [prepare $types]] 0] 482 - set v::dbs($db) [list $file $v::data $desc [mvec $root 0]] 483 - return $db 484 - } 485 - 486 - proc dbclose {db} { 487 - # close datafile, get rid of stored info 488 - unset v::dbs($db) 489 - set v::data "" ;# it may be big 490 - } 491 - 492 - proc dbtree {db} { 493 - # datafile selection, first step in access navigation loop 494 - return [lindex $v::dbs($db) 3] 495 - } 496 - 497 - proc access {spec} { 498 - # this is the main access navigation loop 499 - set s [split $spec ".!"] 500 - set x [list dbtree [array size v::dbs]] 501 - foreach y $s { 502 - set x [mvec $x $y] 503 - } 504 - return $x 505 - } 506 - 507 - proc vnames {view} { 508 - # return a list of property names 509 - if {[lindex $view 0] != "get_view"} { 510 - error "vnames?" 511 - } 512 - return [lindex $view 1] 513 - } 514 - 515 - proc vlen {view} { 516 - # return the number of rows in this view 517 - if {[lindex $view 0] != "get_view"} { 518 - error "vlen?" 519 - } 520 - return [lindex $view 2] 521 - } 522 - 523 - # vim: ft=tcl 524 - 525 -} 526 - 527 -if {[info comm mk_file] == ""} { 528 - # Compatibility layer for MetaKit 529 - 530 - # requires dbopen/dbclose/dbtree/access/vnames/vlen/mvec primitives 531 - #source [file join [info dirname [info script]] decode.tcl] 532 - 533 - namespace export mk_* 534 - 535 - proc mk_file {cmd args} { 536 -#set indent [string repeat " " [info level]] 537 -#puts stderr "${indent}DEBUG: readkit::file $cmd $args" 538 - lassign $args db file 539 - switch $cmd { 540 - open { 541 - return [dbopen $db $file] 542 - } 543 - close { 544 - dbclose $db 545 - } 546 - views { 547 - return [vnames [dbtree $db]] 548 - } 549 - commit { 550 - 551 - } 552 - default { 553 - error "mk_file $cmd?" 554 - } 555 - } 556 - } 557 - 558 - proc mk_view {cmd path args} { 559 -#set indent [string repeat " " [info level]] 560 -#puts stderr "${indent}DEBUG: readkit::view $cmd $path $args" 561 - lassign $args a1 562 - switch $cmd { 563 - info { 564 - return [vnames [access $path]] 565 - } 566 - layout { 567 - set layout "NOTYET" 568 - if {[llength $args] > 0 && $layout != $a1} { 569 - #error "view restructuring not supported" 570 - } 571 - return $layout 572 - } 573 - size { 574 - set len [vlen [access $path]] 575 - if {[llength $args] > 0 && $len != $a1} { 576 - error "view resizing not supported" 577 - } 578 - return [vlen [access $path]] 579 - } 580 - default { 581 - error "mk_view $cmd?" 582 - } 583 - } 584 - } 585 - 586 - proc mk_cursor {cmd cursor args} { 587 -#set indent [string repeat " " [info level]] 588 -#puts stderr "${indent}DEBUG: readkit::cursor $cmd $cursor $args" 589 - upvar $cursor v 590 - switch $cmd { 591 - create { 592 - NOTYET 593 - } 594 - incr { 595 - NOTYET 596 - } 597 - pos - 598 - position { 599 - if {$args != ""} { 600 - regsub {!-?\d+$} $v {} v 601 - append v !$args 602 - return $args 603 - } 604 - if {![regexp {\d+$} $v n]} { 605 - set n -1 606 - } 607 - return $n 608 - } 609 - default { 610 - error "mk_cursor $cmd?" 611 - } 612 - } 613 - } 614 - 615 - proc mk_get {path args} { 616 -#set indent [string repeat " " [info level]] 617 -#puts stderr "${indent}DEBUG: readkit::get $path $args" 618 - set rowref [access $path] 619 - set sized 0 620 - if {[lindex $args 0] == "-size"} { 621 - set sized 1 622 - set args [lrange $args 1 end] 623 - } 624 - set ids 0 625 - if {[llength $args] == 0} { 626 - set args [vnames $rowref] 627 - set ids 1 628 - } 629 - set r {} 630 - foreach x $args { 631 - if {$ids} { 632 - lappend r $x 633 - } 634 - set v [mvec $rowref $x] 635 -if {[string range $v 0 8] == "get_view "} { 636 -# XXX: ?!?!?: TODO: FIX 637 -set v 1 638 -} 639 - if {$sized} { 640 - lappend r [string length $v] 641 - } else { 642 - lappend r $v 643 - } 644 - } 645 - if {[llength $args] == 1} { 646 - set r [lindex $r 0] 647 - } 648 - 649 - return $r 650 - } 651 - 652 - proc mk_loop {cursor path args} { 653 -#set indent [string repeat " " [info level]] 654 -#puts stderr "${indent}DEBUG: readkit::loop $cursor $path ..." 655 - upvar $cursor v 656 - if {[llength $args] == 0} { 657 - set args [list $path] 658 - set path $v 659 - regsub {!-?\d+$} $path {} path 660 - } 661 - lassign $args a1 a2 a3 a4 662 - set rowref [access $path] 663 - set first 0 664 - set limit [vlen $rowref] 665 - set step 1 666 - switch [llength $args] { 667 - 1 { 668 - set body $a1 669 - } 670 - 2 { 671 - set first $a1 672 - set body $a2 673 - } 674 - 3 { 675 - set first $a1 676 - set limit $a2 677 - set body $a3 678 - } 679 - 4 { 680 - set first $a1 681 - set limit $a2 682 - set step $a3 683 - set body $a4 684 - } 685 - default { 686 - error "mk_loop arg count?" 687 - } 688 - } 689 - set code 0 690 - for {set i $first} {$i < $limit} {incr i $step} { 691 - set v $path!$i 692 - set code [catch [list uplevel 1 $body] err] 693 - switch $code { 694 - 1 - 695 - 2 { 696 - return -code $code $err 697 - } 698 - 3 { 699 - break 700 - } 701 - } 702 - } 703 - } 704 - 705 - proc mk_select {path args} { 706 -#set indent [string repeat " " [info level]] 707 -#puts stderr "${indent}DEBUG: readkit::select $path $args" 708 - # only handle the simplest case: exact matches 709 - if {[lindex $args 0] == "-count"} { 710 - set maxitems [lindex $args 1] 711 - set args [lrange $args 2 end] 712 - } 713 - 714 - set currmatchmode "caseinsensitive" 715 - 716 - set keys {} 717 - set value {} 718 - set matchmodes {} 719 - for {set idx 0} {$idx < [llength $args]} {incr idx 2} { 720 - switch -glob -- [lindex $args $idx] { 721 - "-glob" { 722 - set currmatchmode "glob" 723 - incr idx -1 724 - continue 725 - } 726 - "-*" { 727 - error "Unhandled option: [lindex $args $idx]" 728 - } 729 - } 730 - 731 - set k [lindex $args $idx] 732 - set v [lindex $args [expr {$idx+1}]] 733 - 734 - lappend keys $k 735 - lappend values $v 736 - lappend matchmodes $currmatchmode 737 - } 738 - set r {} 739 - mk_loop c $path { 740 - set x [eval mk_get $c $keys] 741 - set matchCnt 0 742 - for {set idx 0} {$idx < [llength $x]} {incr idx} { 743 - set val [lindex $values $idx] 744 - set chkval [lindex $x $idx] 745 - set matchmode [lindex $matchmodes $idx] 746 - 747 - switch -- $matchmode { 748 - "caseinsensitive" { 749 - if {$val == $chkval} { 750 - incr matchCnt 751 - } 752 - } 753 - "glob" { 754 - if {[string match $val $chkval]} { 755 - incr matchCnt 756 - } 757 - } 758 - } 759 - 760 - } 761 - if {$matchCnt == [llength $keys]} { 762 - lappend r [mk_cursor position c] 763 - } 764 - } 765 - 766 - if {[info exists maxitems]} { 767 - set r [lrange $r 0 [expr $maxitems - 1]] 768 - } 769 - 770 - return $r 771 - } 772 - 773 - proc mk__rechan {path prop cmd chan args} { 774 -#set indent [string repeat " " [info level]] 775 -#puts stderr "${indent}DEBUG: readkit::_rechan $path $prop $cmd $chan $args" 776 - 777 - set key [list $path $prop] 778 - if {![info exists ::mk__cache($key)]} { 779 - set ::mk__cache($key) [readkit::get $path $prop] 780 - } 781 - if {![info exists ::mk__offset($key)]} { 782 - set ::mk__offset($key) 0 783 - } 784 - set data $::mk__cache($key) 785 - set offset $::mk__offset($key) 786 - 787 - switch -- $cmd { 788 - "read" { 789 - set count [lindex $args 0] 790 - set retval [string range $data $offset [expr {$offset + $count - 1}]] 791 - 792 - set readbytes [string length $retval] 793 - 794 - incr offset $readbytes 795 - } 796 - "close" { 797 - unset -nocomplain ::mk__cache($key) 798 - unset -nocomplain ::mk__offset($key) 799 - return 800 - } 801 - default { 802 -#puts stderr "${indent}DEBUG: readkit::_rechan: Called for cmd $cmd" 803 - return -code error "Not implemented: cmd = $cmd" 804 - } 805 - } 806 - 807 - set ::mk__offset($key) $offset 808 - 809 - return $retval 810 - } 811 - 812 - proc mk_channel {path prop {mode "r"}} { 813 -#set indent [string repeat " " [info level]] 814 -#puts stderr "${indent}DEBUG: readkit::channel $path $prop $mode" 815 - set fd [rechan [list mk__rechan $path $prop] 2] 816 - 817 - return $fd 818 - } 819 - # vim: ft=tcl 820 - 821 -} 822 - 823 -# set up the MetaKit compatibility definitions 824 -foreach x {file view cursor get loop select channel} { 825 - interp alias {} ::readkit::$x {} ::mk_$x 826 -} 827 - 828 - 829 - 830 -# mk4vfs.tcl -- Mk4tcl Virtual File System driver 831 -# Copyright (C) 1997-2003 Sensus Consulting Ltd. All Rights Reserved. 832 -# Matt Newman <matt@sensus.org> and Jean-Claude Wippler <jcw@equi4.com> 833 -# 834 -# $Id: mk4vfs.tcl,v 1.41 2008/04/15 21:11:53 andreas_kupries Exp $ 835 -# 836 -# 05apr02 jcw 1.3 fixed append mode & close, 837 -# privatized memchan_handler 838 -# added zip, crc back in 839 -# 28apr02 jcw 1.4 reorged memchan and pkg dependencies 840 -# 22jun02 jcw 1.5 fixed recursive dir deletion 841 -# 16oct02 jcw 1.6 fixed periodic commit once a change is made 842 -# 20jan03 jcw 1.7 streamed zlib decompress mode, reduces memory usage 843 -# 01feb03 jcw 1.8 fix mounting a symlink, cleanup mount/unmount procs 844 -# 04feb03 jcw 1.8 whoops, restored vfs::mkcl::Unmount logic 845 -# 17mar03 jcw 1.9 start with mode translucent or readwrite 846 -# 18oct05 jcw 1.10 add fallback to MK Compatible Lite driver (vfs::mkcl) 847 - 848 -# Removed provision of the backward compatible name. Moved to separate 849 -# file/package. 850 -catch { 851 - load {} vfs 852 -} 853 -package require vfs 854 - 855 -# things that can no longer really be left out (but this is the wrong spot!) 856 -# be as non-invasive as possible, using these definitions as last resort 857 - 858 -namespace eval vfs::mkcl { 859 - proc Mount {mkfile local args} { 860 - if {$mkfile != ""} { 861 - # dereference a symlink, otherwise mounting on it fails (why?) 862 - catch { 863 - set mkfile [file join [file dirname $mkfile] \ 864 - [file readlink $mkfile]] 865 - } 866 - set mkfile [file normalize $mkfile] 867 - } 868 - set db [eval [list ::mkcl_vfs::_mount $mkfile] $args] 869 - ::vfs::filesystem mount $local [list ::vfs::mkcl::handler $db] 870 - ::vfs::RegisterMount $local [list ::vfs::mkcl::Unmount $db] 871 - return $db 872 - } 873 - 874 - proc Unmount {db local} { 875 - vfs::filesystem unmount $local 876 - ::mkcl_vfs::_umount $db 877 - } 878 - 879 - proc attributes {db} { return [list "state" "commit"] } 880 - 881 - # Can use this to control commit/nocommit or whatever. 882 - # I'm not sure yet of what functionality jcw needs. 883 - proc commit {db args} { 884 - switch -- [llength $args] { 885 - 0 { 886 - if {$::mkcl_vfs::v::mode($db) == "readonly"} { 887 - return 0 888 - } else { 889 - # To Do: read the commit state 890 - return 1 891 - } 892 - } 893 - 1 { 894 - set val [lindex $args 0] 895 - if {$val != 0 && $val != 1} { 896 - return -code error \ 897 - "invalid commit value $val, must be 0,1" 898 - } 899 - # To Do: set the commit state. 900 - } 901 - default { 902 - return -code error "Wrong num args" 903 - } 904 - } 905 - } 906 - 907 - proc state {db args} { 908 - switch -- [llength $args] { 909 - 0 { 910 - return $::mkcl_vfs::v::mode($db) 911 - } 912 - 1 { 913 - set val [lindex $args 0] 914 - if {[lsearch -exact [::vfs::states] $val] == -1} { 915 - return -code error \ 916 - "invalid state $val, must be one of: [vfs::states]" 917 - } 918 - set ::mkcl_vfs::v::mode($db) $val 919 - ::mkcl_vfs::setupCommits $db 920 - } 921 - default { 922 - return -code error "Wrong num args" 923 - } 924 - } 925 - } 926 - 927 - proc handler {db cmd root relative actualpath args} { 928 - #puts stderr "handler: $db - $cmd - $root - $relative - $actualpath - $args" 929 - if {$cmd == "matchindirectory"} { 930 - eval [list $cmd $db $relative $actualpath] $args 931 - } elseif {$cmd == "fileattributes"} { 932 - eval [list $cmd $db $root $relative] $args 933 - } else { 934 - eval [list $cmd $db $relative] $args 935 - } 936 - } 937 - 938 - proc utime {db path actime modtime} { 939 - ::mkcl_vfs::stat $db $path sb 940 - 941 - if { $sb(type) == "file" } { 942 - readkit::set $sb(ino) date $modtime 943 - } 944 - } 945 - 946 - proc matchindirectory {db path actualpath pattern type} { 947 - set newres [list] 948 - if {![string length $pattern]} { 949 - # check single file 950 - if {[catch {access $db $path 0}]} { 951 - return {} 952 - } 953 - set res [list $actualpath] 954 - set actualpath "" 955 - } else { 956 - set res [::mkcl_vfs::getdir $db $path $pattern] 957 - } 958 - foreach p [::vfs::matchCorrectTypes $type $res $actualpath] { 959 - lappend newres [file join $actualpath $p] 960 - } 961 - return $newres 962 - } 963 - 964 - proc stat {db name} { 965 - ::mkcl_vfs::stat $db $name sb 966 - 967 - set sb(ino) 0 968 - array get sb 969 - } 970 - 971 - proc access {db name mode} { 972 - if {$mode & 2} { 973 - if {$::mkcl_vfs::v::mode($db) == "readonly"} { 974 - vfs::filesystem posixerror $::vfs::posix(EROFS) 975 - } 976 - } 977 - # We can probably do this more efficiently, can't we? 978 - ::mkcl_vfs::stat $db $name sb 979 - } 980 - 981 - proc open {db file mode permissions} { 982 - # return a list of two elements: 983 - # 1. first element is the Tcl channel name which has been opened 984 - # 2. second element (optional) is a command to evaluate when 985 - # the channel is closed. 986 - switch -glob -- $mode { 987 - {} - 988 - r { 989 - ::mkcl_vfs::stat $db $file sb 990 - 991 - if { $sb(csize) != $sb(size) } { 992 - if {$::mkcl_vfs::zstreamed} { 993 - set fd [readkit::channel $sb(ino) contents r] 994 - fconfigure $fd -translation binary 995 - set fd [vfs::zstream decompress $fd $sb(csize) $sb(size)] 996 - } else { 997 - set fd [vfs::memchan] 998 - fconfigure $fd -translation binary 999 - set s [readkit::get $sb(ino) contents] 1000 - puts -nonewline $fd [vfs::zip -mode decompress $s] 1001 - 1002 - fconfigure $fd -translation auto 1003 - seek $fd 0 1004 - } 1005 - } elseif { $::mkcl_vfs::direct } { 1006 - set fd [vfs::memchan] 1007 - fconfigure $fd -translation binary 1008 - puts -nonewline $fd [readkit::get $sb(ino) contents] 1009 - 1010 - fconfigure $fd -translation auto 1011 - seek $fd 0 1012 - } else { 1013 - set fd [readkit::channel $sb(ino) contents r] 1014 - } 1015 - return [list $fd] 1016 - } 1017 - a { 1018 - if {$::mkcl_vfs::v::mode($db) == "readonly"} { 1019 - vfs::filesystem posixerror $::vfs::posix(EROFS) 1020 - } 1021 - if { [catch {::mkcl_vfs::stat $db $file sb }] } { 1022 - # Create file 1023 - ::mkcl_vfs::stat $db [file dirname $file] sb 1024 - set tail [file tail $file] 1025 - set fview $sb(ino).files 1026 - if {[info exists mkcl_vfs::v::fcache($fview)]} { 1027 - lappend mkcl_vfs::v::fcache($fview) $tail 1028 - } 1029 - set now [clock seconds] 1030 - set sb(ino) [readkit::row append $fview \ 1031 - name $tail size 0 date $now ] 1032 - 1033 - if { [string match *z* $mode] || $mkcl_vfs::compress } { 1034 - set sb(csize) -1 ;# HACK - force compression 1035 - } else { 1036 - set sb(csize) 0 1037 - } 1038 - } 1039 - 1040 - set fd [vfs::memchan] 1041 - fconfigure $fd -translation binary 1042 - set s [readkit::get $sb(ino) contents] 1043 - 1044 - if { $sb(csize) != $sb(size) && $sb(csize) > 0 } { 1045 - append mode z 1046 - puts -nonewline $fd [vfs::zip -mode decompress $s] 1047 - } else { 1048 - if { $mkcl_vfs::compress } { append mode z } 1049 - puts -nonewline $fd $s 1050 - #set fd [readkit::channel $sb(ino) contents a] 1051 - } 1052 - fconfigure $fd -translation auto 1053 - seek $fd 0 end 1054 - return [list $fd [list mkcl_vfs::do_close $db $fd $mode $sb(ino)]] 1055 - } 1056 - w* { 1057 - if {$::mkcl_vfs::v::mode($db) == "readonly"} { 1058 - vfs::filesystem posixerror $::vfs::posix(EROFS) 1059 - } 1060 - if { [catch {::mkcl_vfs::stat $db $file sb }] } { 1061 - # Create file 1062 - ::mkcl_vfs::stat $db [file dirname $file] sb 1063 - set tail [file tail $file] 1064 - set fview $sb(ino).files 1065 - if {[info exists mkcl_vfs::v::fcache($fview)]} { 1066 - lappend mkcl_vfs::v::fcache($fview) $tail 1067 - } 1068 - set now [clock seconds] 1069 - set sb(ino) [readkit::row append $fview \ 1070 - name $tail size 0 date $now ] 1071 - } 1072 - 1073 - if { [string match *z* $mode] || $mkcl_vfs::compress } { 1074 - append mode z 1075 - set fd [vfs::memchan] 1076 - } else { 1077 - set fd [readkit::channel $sb(ino) contents w] 1078 - } 1079 - return [list $fd [list mkcl_vfs::do_close $db $fd $mode $sb(ino)]] 1080 - } 1081 - default { 1082 - error "illegal access mode \"$mode\"" 1083 - } 1084 - } 1085 - } 1086 - 1087 - proc createdirectory {db name} { 1088 - mkcl_vfs::mkdir $db $name 1089 - } 1090 - 1091 - proc removedirectory {db name recursive} { 1092 - mkcl_vfs::delete $db $name $recursive 1093 - } 1094 - 1095 - proc deletefile {db name} { 1096 - mkcl_vfs::delete $db $name 1097 - } 1098 - 1099 - proc fileattributes {db root relative args} { 1100 - switch -- [llength $args] { 1101 - 0 { 1102 - # list strings 1103 - return [::vfs::listAttributes] 1104 - } 1105 - 1 { 1106 - # get value 1107 - set index [lindex $args 0] 1108 - return [::vfs::attributesGet $root $relative $index] 1109 - 1110 - } 1111 - 2 { 1112 - # set value 1113 - if {$::mkcl_vfs::v::mode($db) == "readonly"} { 1114 - vfs::filesystem posixerror $::vfs::posix(EROFS) 1115 - } 1116 - set index [lindex $args 0] 1117 - set val [lindex $args 1] 1118 - return [::vfs::attributesSet $root $relative $index $val] 1119 - } 1120 - } 1121 - } 1122 -} 1123 - 1124 -namespace eval mkcl_vfs { 1125 - variable compress 1 ;# HACK - needs to be part of "Super-Block" 1126 - variable flush 5000 ;# Auto-Commit frequency 1127 - variable direct 0 ;# read through a memchan, or from Mk4tcl if zero 1128 - variable zstreamed 1 ;# decompress on the fly (needs zlib 1.1) 1129 - 1130 - namespace eval v { 1131 - variable seq 0 1132 - variable mode ;# array key is db, value is mode 1133 - # (readwrite/translucent/readonly) 1134 - variable timer ;# array key is db, set to afterid, periodicCommit 1135 - 1136 - array set cache {} 1137 - array set fcache {} 1138 - 1139 - array set mode {exe translucent} 1140 - } 1141 - 1142 - proc init {db} { 1143 - readkit::view layout $db.dirs \ 1144 - {name:S parent:I {files {name:S size:I date:I contents:M}}} 1145 - 1146 - if { [readkit::view size $db.dirs] == 0 } { 1147 - readkit::row append $db.dirs name <root> parent -1 1148 - } 1149 - } 1150 - 1151 - proc _mount {{file ""} args} { 1152 - set db mk4vfs[incr v::seq] 1153 - 1154 - if {$file == ""} { 1155 - readkit::file open $db 1156 - init $db 1157 - set v::mode($db) "translucent" 1158 - } else { 1159 - eval [list readkit::file open $db $file] $args 1160 - 1161 - init $db 1162 - 1163 - set mode 0 1164 - foreach arg $args { 1165 - switch -- $arg { 1166 - -readonly { set mode 1 } 1167 - -nocommit { set mode 2 } 1168 - } 1169 - } 1170 - if {$mode == 0} { 1171 - periodicCommit $db 1172 - } 1173 - set v::mode($db) [lindex {translucent readwrite readwrite} $mode] 1174 - } 1175 - return $db 1176 - } 1177 - 1178 - proc periodicCommit {db} { 1179 - variable flush 1180 - set v::timer($db) [after $flush [list ::mkcl_vfs::periodicCommit $db]] 1181 - readkit::file commit $db 1182 - return ;# 2005-01-20 avoid returning a value 1183 - } 1184 - 1185 - proc _umount {db args} { 1186 - catch {after cancel $v::timer($db)} 1187 - array unset v::mode $db 1188 - array unset v::timer $db 1189 - array unset v::cache $db,* 1190 - array unset v::fcache $db.* 1191 - readkit::file close $db 1192 - } 1193 - 1194 - proc stat {db path {arr ""}} { 1195 - set sp [::file split $path] 1196 - set tail [lindex $sp end] 1197 - 1198 - set parent 0 1199 - set view $db.dirs 1200 - set type directory 1201 - 1202 - foreach ele [lrange $sp 0 end-1] { 1203 - if {[info exists v::cache($db,$parent,$ele)]} { 1204 - set parent $v::cache($db,$parent,$ele) 1205 - } else { 1206 - set row [readkit::select $view -count 1 parent $parent name $ele] 1207 - if { $row == "" } { 1208 - vfs::filesystem posixerror $::vfs::posix(ENOENT) 1209 - } 1210 - set v::cache($db,$parent,$ele) $row 1211 - set parent $row 1212 - } 1213 - } 1214 - 1215 - # Now check if final comp is a directory or a file 1216 - # CACHING is required - it can deliver a x15 speed-up! 1217 - 1218 - if { [string equal $tail "."] || [string equal $tail ":"] \ 1219 - || [string equal $tail ""] } { 1220 - set row $parent 1221 - 1222 - } elseif { [info exists v::cache($db,$parent,$tail)] } { 1223 - set row $v::cache($db,$parent,$tail) 1224 - } else { 1225 - # File? 1226 - set fview $view!$parent.files 1227 - # create a name cache of files in this directory 1228 - if {![info exists v::fcache($fview)]} { 1229 - # cache only a limited number of directories 1230 - if {[array size v::fcache] >= 10} { 1231 - array unset v::fcache * 1232 - } 1233 - set v::fcache($fview) {} 1234 - readkit::loop c $fview { 1235 - lappend v::fcache($fview) [readkit::get $c name] 1236 - } 1237 - } 1238 - set row [lsearch -exact $v::fcache($fview) $tail] 1239 - #set row [readkit::select $fview -count 1 name $tail] 1240 - #if {$row == ""} { set row -1 } 1241 - if { $row != -1 } { 1242 - set type file 1243 - set view $view!$parent.files 1244 - } else { 1245 - # Directory? 1246 - set row [readkit::select $view -count 1 parent $parent name $tail] 1247 - if { $row != "" } { 1248 - set v::cache($db,$parent,$tail) $row 1249 - } else { 1250 - vfs::filesystem posixerror $::vfs::posix(ENOENT) 1251 - } 1252 - } 1253 - } 1254 - 1255 - if {![string length $arr]} { 1256 - # The caller doesn't need more detailed information. 1257 - return 1 1258 - } 1259 - 1260 - set cur $view!$row 1261 - 1262 - upvar 1 $arr sb 1263 - 1264 - set sb(type) $type 1265 - set sb(view) $view 1266 - set sb(ino) $cur 1267 - 1268 - if { [string equal $type "directory"] } { 1269 - set sb(atime) 0 1270 - set sb(ctime) 0 1271 - set sb(gid) 0 1272 - set sb(mode) 0777 1273 - set sb(mtime) 0 1274 - set sb(nlink) [expr { [readkit::get $cur files] + 1 }] 1275 - set sb(size) 0 1276 - set sb(csize) 0 1277 - set sb(uid) 0 1278 - } else { 1279 - set mtime [readkit::get $cur date] 1280 - set sb(atime) $mtime 1281 - set sb(ctime) $mtime 1282 - set sb(gid) 0 1283 - set sb(mode) 0777 1284 - set sb(mtime) $mtime 1285 - set sb(nlink) 1 1286 - set sb(size) [readkit::get $cur size] 1287 - set sb(csize) [readkit::get $cur -size contents] 1288 - set sb(uid) 0 1289 - } 1290 - } 1291 - 1292 - proc do_close {db fd mode cur} { 1293 - if {![regexp {[aw]} $mode]} { 1294 - error "mkcl_vfs::do_close called with bad mode: $mode" 1295 - } 1296 - 1297 - readkit::set $cur size -1 date [clock seconds] 1298 - flush $fd 1299 - if { [string match *z* $mode] } { 1300 - fconfigure $fd -translation binary 1301 - seek $fd 0 1302 - set data [read $fd] 1303 - set cdata [vfs::zip -mode compress $data] 1304 - set len [string length $data] 1305 - set clen [string length $cdata] 1306 - if { $clen < $len } { 1307 - readkit::set $cur size $len contents $cdata 1308 - } else { 1309 - readkit::set $cur size $len contents $data 1310 - } 1311 - } else { 1312 - readkit::set $cur size [readkit::get $cur -size contents] 1313 - } 1314 - # 16oct02 new logic to start a periodic commit timer if not yet running 1315 - setupCommits $db 1316 - return "" 1317 - } 1318 - 1319 - proc setupCommits {db} { 1320 - if {$v::mode($db) eq "readwrite" && ![info exists v::timer($db)]} { 1321 - periodicCommit $db 1322 - readkit::file autocommit $db 1323 - } 1324 - } 1325 - 1326 - proc mkdir {db path} { 1327 - if {$v::mode($db) == "readonly"} { 1328 - vfs::filesystem posixerror $::vfs::posix(EROFS) 1329 - } 1330 - set sp [::file split $path] 1331 - set parent 0 1332 - set view $db.dirs 1333 - 1334 - set npath {} 1335 - # This actually does more work than is needed. Tcl's 1336 - # vfs only requires us to create the last piece, and 1337 - # Tcl already knows it is not a file. 1338 - foreach ele $sp { 1339 - set npath [file join $npath $ele] 1340 - 1341 - if {![catch {stat $db $npath sb}] } { 1342 - if { $sb(type) != "directory" } { 1343 - vfs::filesystem posixerror $::vfs::posix(EROFS) 1344 - } 1345 - set parent [readkit::cursor position sb(ino)] 1346 - continue 1347 - } 1348 - #set parent [readkit::cursor position sb(ino)] 1349 - set cur [readkit::row append $view name $ele parent $parent] 1350 - set parent [readkit::cursor position cur] 1351 - } 1352 - setupCommits $db 1353 - return "" 1354 - } 1355 - 1356 - proc getdir {db path {pat *}} { 1357 - if {[catch { stat $db $path sb }] || $sb(type) != "directory" } { 1358 - return 1359 - } 1360 - 1361 - # Match directories 1362 - set parent [readkit::cursor position sb(ino)] 1363 - foreach row [readkit::select $sb(view) parent $parent -glob name $pat] { 1364 - set hits([readkit::get $sb(view)!$row name]) 1 1365 - } 1366 - # Match files 1367 - set view $sb(view)!$parent.files 1368 - foreach row [readkit::select $view -glob name $pat] { 1369 - set hits([readkit::get $view!$row name]) 1 1370 - } 1371 - return [lsort [array names hits]] 1372 - } 1373 - 1374 - proc mtime {db path time} { 1375 - if {$v::mode($db) == "readonly"} { 1376 - vfs::filesystem posixerror $::vfs::posix(EROFS) 1377 - } 1378 - stat $db $path sb 1379 - if { $sb(type) == "file" } { 1380 - readkit::set $sb(ino) date $time 1381 - } 1382 - return $time 1383 - } 1384 - 1385 - proc delete {db path {recursive 0}} { 1386 - #puts stderr "mk4delete db $db path $path recursive $recursive" 1387 - if {$v::mode($db) == "readonly"} { 1388 - vfs::filesystem posixerror $::vfs::posix(EROFS) 1389 - } 1390 - stat $db $path sb 1391 - if {$sb(type) == "file" } { 1392 - readkit::row delete $sb(ino) 1393 - if {[regexp {(.*)!(\d+)} $sb(ino) - v r] \ 1394 - && [info exists v::fcache($v)]} { 1395 - set v::fcache($v) [lreplace $v::fcache($v) $r $r] 1396 - } 1397 - } else { 1398 - # just mark dirs as deleted 1399 - set contents [getdir $db $path *] 1400 - if {$recursive} { 1401 - # We have to delete these manually, else 1402 - # they (or their cache) may conflict with 1403 - # something later 1404 - foreach f $contents { 1405 - delete $db [file join $path $f] $recursive 1406 - } 1407 - } else { 1408 - if {[llength $contents]} { 1409 - vfs::filesystem posixerror $::vfs::posix(ENOTEMPTY) 1410 - } 1411 - } 1412 - array unset v::cache \ 1413 - "$db,[readkit::get $sb(ino) parent],[file tail $path]" 1414 - 1415 - # flag with -99, because parent -1 is not reserved for the root dir 1416 - # deleted entries never get re-used, should be cleaned up one day 1417 - readkit::set $sb(ino) parent -99 name "" 1418 - # get rid of file entries to release the space in the datafile 1419 - readkit::view size $sb(ino).files 0 1420 - } 1421 - setupCommits $db 1422 - return "" 1423 - } 1424 -} 1425 - 1426 -package provide readkit 0.8 1427 -package provide vfs::mkcl 2.4.0.1
Modified kitsh/buildsrc/kitsh-0.0/zipvfs.tcl from [4a9165155e] to [734aa55ae1].
1 1 # Removed provision of the backward compatible name. Moved to separate 2 2 # file/package. 3 -package provide vfs::zip 1.0.1 4 3 5 4 package require vfs 6 5 7 6 # Using the vfs, memchan and Trf extensions, we ought to be able 8 7 # to write a Tcl-only zip virtual filesystem. What we have below 9 8 # is basically that. 10 9 ................................................................................ 233 232 128 {normal} 234 233 } 235 234 236 235 proc u_short {n} { return [expr { ($n+0x10000)%0x10000 }] } 237 236 } 238 237 239 238 proc zip::DosTime {date time} { 239 + # The pre-VFS environment will not have access to "clock", so don't even 240 + # bother 241 + return 0 242 + 240 243 set time [u_short $time] 241 244 set date [u_short $date] 242 245 243 246 # time = fedcba9876543210 244 247 # HHHHHmmmmmmSSSSS (sec/2 actually) 245 248 246 249 # data = fedcba9876543210 ................................................................................ 251 254 set hour [expr { ($time >> 11) & 0x1F }] 252 255 253 256 set mday [expr { $date & 0x1F }] 254 257 set mon [expr { (($date >> 5) & 0xF) }] 255 258 set year [expr { (($date >> 9) & 0xFF) + 1980 }] 256 259 257 260 # Fix up bad date/time data, no need to fail 258 - while {$sec > 59} {incr sec -60} 259 - while {$min > 59} {incr sec -60} 260 - while {$hour > 23} {incr hour -24} 261 - if {$mday < 1} {incr mday} 262 - if {$mon < 1} {incr mon} 263 - while {$mon > 12} {incr hour -12} 261 + if {$sec > 59} {set sec 59} 262 + if {$min > 59} {set sec 59} 263 + if {$hour > 23} {set hour 23} 264 + if {$mday < 1} {set mday 1} 265 + if {$mday > 35} {set mday 35} 266 + if {$mon < 1} {set mon 1} 267 + if {$mon > 12} {set mon 12} 264 268 265 - while {[catch { 269 + set res 0 270 + while {$mday > 1 && [catch { 266 271 set dt [format {%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d} \ 267 272 $year $mon $mday $hour $min $sec] 268 273 set res [clock scan $dt -gmt 1] 269 274 }]} { 270 275 # Only mday can be wrong, at end of month 271 276 incr mday -1 272 277 } 278 + 273 279 return $res 274 280 } 275 281 276 282 277 283 proc zip::Data {fd arr {varPtr ""} {verify 0}} { 278 284 upvar 1 $arr sb 279 285 ................................................................................ 396 402 397 403 # Compute base for situations where ZIP file 398 404 # has been appended to another media (e.g. EXE) 399 405 set cb(base) [expr { $pos - $cb(csize) - $cb(coff) }] 400 406 } 401 407 402 408 proc zip::TOC {fd arr} { 409 + upvar #0 zip::$fd cb 403 410 upvar 1 $arr sb 404 411 405 412 set buf [read $fd 46] 406 413 407 414 binary scan $buf A4ssssssiiisssssii hdr \ 408 415 sb(vem) sb(ver) sb(flags) sb(method) time date \ 409 416 sb(crc) sb(csize) sb(size) \ 410 417 flen elen clen sb(disk) sb(attr) \ 411 418 sb(atx) sb(ino) 419 + 420 + set sb(ino) [expr {$cb(base) + $sb(ino)}] 412 421 413 422 if { ![string equal "PK\01\02" $hdr] } { 414 423 binary scan $hdr H* x 415 424 error "bad central header: $x" 416 425 } 417 426 418 427 foreach v {vem ver flags method disk attr} { ................................................................................ 438 447 upvar #0 zip::$fd cb 439 448 upvar #0 zip::$fd.toc toc 440 449 441 450 fconfigure $fd -translation binary ;#-buffering none 442 451 443 452 zip::EndOfArchive $fd cb 444 453 445 - seek $fd $cb(coff) start 454 + seek $fd [expr {$cb(base) + $cb(coff)}] start 446 455 447 456 set toc(_) 0; unset toc(_); #MakeArray 448 457 449 458 for { set i 0 } { $i < $cb(nitems) } { incr i } { 450 459 zip::TOC $fd sb 451 460 452 461 set sb(depth) [llength [file split $sb(name)]] ................................................................................ 560 569 proc zip::_close {fd} { 561 570 variable $fd 562 571 variable $fd.toc 563 572 unset $fd 564 573 unset $fd.toc 565 574 ::close $fd 566 575 } 576 + 577 +# use zlib to define zip and crc if available 578 +if {[llength [info command vfs::zip]] == 0 && [llength [info command zlib]] || ![catch {load "" zlib}]} { 579 + proc vfs::zip {flag value args} { 580 + switch -glob -- "$flag $value" { 581 + {-mode d*} { set mode decompress } 582 + {-mode c*} { set mode compress } 583 + default { error "usage: zip -mode {compress|decompress} data" } 584 + } 585 + 586 + # kludge to allow "-nowrap 1" as second option, 5-9-2002 587 + if {[llength $args] > 2 && [lrange $args 0 1] eq "-nowrap 1"} { 588 + if {$mode eq "compress"} { 589 + set mode deflate 590 + } else { 591 + set mode inflate 592 + } 593 + } 594 + 595 + return [zlib $mode [lindex $args end]] 596 + } 597 +}
Added tclvfs/patches/all/tclvfs-20080503-zipvfs-clock_and_append_to_exe.diff version [b74bd5027c].
1 +Binary files tclvfs-20080503.orig//library/.zipvfs.tcl.swp and tclvfs-20080503-1rsk//library/.zipvfs.tcl.swp differ 2 +diff -uNr tclvfs-20080503.orig//library/zipvfs.tcl tclvfs-20080503-1rsk//library/zipvfs.tcl 3 +--- tclvfs-20080503.orig//library/zipvfs.tcl 2008-04-15 16:11:53.000000000 -0500 4 ++++ tclvfs-20080503-1rsk//library/zipvfs.tcl 2010-09-10 06:48:25.026165002 -0500 5 +@@ -255,21 +255,21 @@ 6 + set year [expr { (($date >> 9) & 0xFF) + 1980 }] 7 + 8 + # Fix up bad date/time data, no need to fail 9 +- while {$sec > 59} {incr sec -60} 10 +- while {$min > 59} {incr sec -60} 11 +- while {$hour > 23} {incr hour -24} 12 +- if {$mday < 1} {incr mday} 13 +- if {$mon < 1} {incr mon} 14 +- while {$mon > 12} {incr hour -12} 15 ++ if {$sec > 59} {set sec 59} 16 ++ if {$min > 59} {set sec 59} 17 ++ if {$hour > 23} {set hour 23} 18 ++ if {$mday < 1} {set mday 1} 19 ++ if {$mday > 31} {set mday 31} 20 ++ if {$mon < 1} {set mon 1} 21 ++ if {$mon > 12} {set mon 12} 22 + 23 +- while {[catch { 24 ++ set res 0 25 ++ catch { 26 + set dt [format {%4.4d-%2.2d-%2.2d %2.2d:%2.2d:%2.2d} \ 27 + $year $mon $mday $hour $min $sec] 28 + set res [clock scan $dt -gmt 1] 29 +- }]} { 30 +- # Only mday can be wrong, at end of month 31 +- incr mday -1 32 + } 33 ++ 34 + return $res 35 + } 36 + 37 +@@ -400,6 +400,7 @@ 38 + } 39 + 40 + proc zip::TOC {fd arr} { 41 ++ upvar #0 zip::$fd cb 42 + upvar 1 $arr sb 43 + 44 + set buf [read $fd 46] 45 +@@ -410,6 +411,8 @@ 46 + flen elen clen sb(disk) sb(attr) \ 47 + sb(atx) sb(ino) 48 + 49 ++ set sb(ino) [expr {$cb(base) + $sb(ino)}] 50 ++ 51 + if { ![string equal "PK\01\02" $hdr] } { 52 + binary scan $hdr H* x 53 + error "bad central header: $x" 54 +@@ -442,7 +445,7 @@ 55 + 56 + zip::EndOfArchive $fd cb 57 + 58 +- seek $fd $cb(coff) start 59 ++ seek $fd [expr {$cb(base) + $cb(coff)}] start 60 + 61 + set toc(_) 0; unset toc(_); #MakeArray 62 +