Check-in [66535d6924]
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  +