From: Jean-Claude Wippler Date: Thu, 25 Apr 2002 13:34:22 +0000 (+0000) Subject: drop pink, scripdoc, vfslib X-Git-Tag: vfs-1-2~56 X-Git-Url: http://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=ebb2f4e297e8952bfdd43d5d518d7cf548bbb861;p=tclvfs drop pink, scripdoc, vfslib --- diff --git a/ChangeLog b/ChangeLog index 482b828..79d6b12 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +2002-04-25 Jean-Claude Wippler + * library/zipvfs.tcl: removed dependencies on pink, switched + to "zlib" command (now available in critlib and in tclkit) + * library/vfsUtils.tcl: fixed env to be global, added unset + so unmounting cleans up its list of mounted file systems + * library/{scripdoc.tcl,vfs.tcl}: removed, tclkit specific + * library/pkgIndex.tcl: drop packages "scripdoc" and "vfslib" + 2002-04-25 Vince Darley * tests/*: revamp of tests to be more robust, and to be able to run from inside a mounted virtual filesystem. diff --git a/library/pkgIndex.tcl b/library/pkgIndex.tcl index 4dd3631..0aefcc6 100644 --- a/library/pkgIndex.tcl +++ b/library/pkgIndex.tcl @@ -40,6 +40,4 @@ if {![file exists $file]} { package ifneeded vfs 1.0 [list load $file] unset file -package ifneeded scripdoc 0.3 [list source [file join $dir scripdoc.tcl]] package ifneeded mk4vfs 1.0 [list source [file join $dir mk4vfs.tcl]] -package ifneeded vfslib 0.1 [list source [file join $dir vfs.tcl]] diff --git a/library/scripdoc.tcl b/library/scripdoc.tcl deleted file mode 100644 index 20fb1fa..0000000 --- a/library/scripdoc.tcl +++ /dev/null @@ -1,122 +0,0 @@ -# Only useful for TclKit -# (this file is include in tclvfs so this entire package can be -# use in tclkit if desired). -# -# Scripted document support -# -# 2000/03/12 jcw v0.1 initial version -# 2000/09/30 jcw v0.2 added extendPath -# -# Copyright (C) 2000 Jean-Claude Wippler - -package require vfs -package provide scripdoc 0.3 - -namespace eval scripdoc { - variable self ;# the scripted document file - variable script ;# the script which is started up - - namespace export init extendPath -} - -proc scripdoc::init {version driver args} { - variable self - variable script - global errorInfo tk_library - - set self [info script] - set root [file tail [file rootname $self]] - - if {$root == ""} { - error "scripdoc::init can only be called from a script file" - } - - if {[catch { - if {$version != 1.0} { - error "Unsupported scripdoc format (need $version, have 1.0)" - } - - array set opts {m -nocommit} - array set opts $args - - package require ${driver}vfs - ::vfs::${driver}::Mount $self $self $opts(m) - - extendPath $self - - foreach name [list $root main help] { - set script [file join $self bin $name.tcl] - if {[file exists $script]} break - } - - if {![file exists $script]} { - error "don't know how to run $root for $self" - } - - uplevel [list source $script] - } msg]} { - if {[info exists tk_library]} { - wm withdraw . - tk_messageBox -icon error -message $msg -title "Fatal error" - } elseif {"[info commands eventlog][info procs eventlog]" != ""} { - eventlog error $errorInfo - } else { - puts stderr $errorInfo - } - exit - } -} - -# Extend auto_path with a set of directories, if they exist. -# -# The following paths may be added (but in the opposite order): -# $base/lib -# $base/lib/arch/$tcl_platform(machine) -# $base/lib/arch/$tcl_platform(platform) -# $base/lib/arch/$tcl_platform(os) -# $base/lib/arch/$tcl_platform(os)/$tcl_platform(osVersion) -# -# The last two entries are actually expanded even further, splitting -# $tcl_platform(os) on spaces and $tcl_platform(osVersion) on ".". -# -# So on NT, "Windows" and "Windows/NT" would also be considered, and on -# Linux 2.2.14, all of the following: Linux/2, Linux/2/2, Linux/2/2/14 -# -# Only paths for which the dir exist are added (once) to auto_path. - -proc scripdoc::extendPath {base {verbose 0}} { - global auto_path - upvar #0 tcl_platform pf - - set path [file join $base lib] - if {[file isdirectory $path]} { - set pos [lsearch $auto_path $path] - if {$pos < 0} { - set pos [llength $auto_path] - lappend auto_path $path - } - - if {$verbose} { - set tmp [join [concat {{}} $auto_path] "\n "] - tclLog "scripDoc::extendPath $base -> auto_path is: $tmp" - } - - foreach suffix [list $pf(machine) \ - $pf(platform) \ - [list $pf(os) $pf(osVersion)] \ - [concat [split $pf(os) " "] \ - [split $pf(osVersion) .]]] { - - set tmp [file join $path arch] - foreach x $suffix { - set tmp [file join $tmp $x] - if {$verbose} {tclLog " checking $tmp"} - if {![file isdirectory $tmp]} break - if {[lsearch $auto_path $tmp] < 0} { - if {$verbose} {tclLog " inserted in auto_path."} - set auto_path [linsert $auto_path $pos $tmp] - } - } - } - } -} diff --git a/library/vfs.tcl b/library/vfs.tcl deleted file mode 100644 index f91f234..0000000 --- a/library/vfs.tcl +++ /dev/null @@ -1,63 +0,0 @@ -# Only useful for TclKit -# (this file is included in tclvfs so this entire package can be -# use in tclkit if desired). -# -# Initialization script normally executed in the interpreter for each -# VFS-based application. -# -# Copyright (c) 1999 Matt Newman -# Further changes made by Jean-Claude Wippler -# Further changes made by Vince Darley -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. - -# Insist on running with compatible version of Tcl. -package require Tcl 8.4 -package provide vfslib 0.1 - -# So I can debug on command line when starting up Tcl from a vfs -# when I might not have the history procedures loaded yet! -#proc history {args} {} - -# This stuff is for TclKit -namespace eval ::vfs { - variable temp - global env - - set temp [file nativename /usr/tmp] - if {![file exists $temp]} {set temp [file nativename /tmp]} - catch {set temp $env(TMP)} - catch {set temp $env(TMPDIR)} - catch {set temp $env(SYSTEMDRIVE)/temp} - catch {set temp $env(TEMP)} - catch {set temp $env(VFS_TEMP)} - set temp [file join $temp tclkit] - file mkdir $temp - set temp [file nativename $temp] - - # This is not right XXX need somewhere to unpack - # indirect-dependant DLL's etc. - - global env tcl_platform - if {$tcl_platform(platform) == "windows"} { - set env(PATH) "${vfs::temp};$env(PATH)" - } elseif {$tcl_platform(platform) == "unix"} { - set env(PATH) "${vfs::temp}:$env(PATH)" - } else { - set env(PATH) "${vfs::temp}" - } - proc debug {tag body} { - set cnt [info cmdcount] - set time [lindex [time { - set rc [catch {uplevel 1 [list eval $body]} ret] - }] 0] - set cnt' [info cmdcount] - set ei ${::errorInfo} - set ec ${::errorCode} - puts stderr "$tag: [expr {${cnt'} - $cnt}] ops, $time us" - return -code $rc -errorcode $ec -errorinfo $ei $ret - } - # for backwards compatibility - proc normalize {path} { ::file normalize $path } -} diff --git a/library/vfsUtils.tcl b/library/vfsUtils.tcl index a634b37..05af286 100644 --- a/library/vfsUtils.tcl +++ b/library/vfsUtils.tcl @@ -4,8 +4,8 @@ package require vfs namespace eval ::vfs { variable debug 0 - if {[info exists env(VFS_DEBUG)]} { - set debug $env(VFS_DEBUG) + if {[info exists ::env(VFS_DEBUG)]} { + set debug $::env(VFS_DEBUG) } } @@ -35,6 +35,7 @@ proc ::vfs::unmount {mountpoint} { variable _unmountCmd set norm [file normalize $mountpoint] uplevel \#0 $_unmountCmd($norm) [list $norm] + unset _unmountCmd($norm) } ::vfs::autoMountExtension "" ::vfs::mk4::Mount vfs diff --git a/library/zipvfs.tcl b/library/zipvfs.tcl index d68c9af..b648ad9 100644 --- a/library/zipvfs.tcl +++ b/library/zipvfs.tcl @@ -1,5 +1,7 @@ -package require vfs 1.0 +package require vfs +package require pink +package provide zipvfs 1.0 # Using the vfs, memchan and Trf extensions, we ought to be able # to write a Tcl-only zip virtual filesystem. What we have below @@ -98,7 +100,6 @@ proc vfs::zip::open {zipfd name mode permissions} { ::zip::stat $zipfd $name sb - package require Trf package require Memchan set nfd [memchan] @@ -159,7 +160,6 @@ proc vfs::zip::utime {fd path actime mtime} { error "" } - # Below copied from TclKit distribution # @@ -179,7 +179,6 @@ proc vfs::zip::utime {fd path actime mtime} { # archive by first fetching EndOfArchive, then # just loading the TOC # -package provide vfs.zip 0.5 namespace eval zip { array set methods { @@ -264,7 +263,8 @@ proc zip::Data {fd arr {varPtr ""} {verify 0}} { sb(crc) sb(csize) sb(size) flen elen] if { ![string equal "PK\03\04" $hdr] } { - error "bad header: [hexdump $hdr]" + binary scan $hdr H* x + error "bad header: $x" } set sb(ver) [u_short $sb(ver)] set sb(flags) [u_short $sb(flags)] @@ -293,15 +293,16 @@ proc zip::Data {fd arr {varPtr ""} {verify 0}} { if { $sb(method) != 0 } { if { [catch { - set data [zip -mode decompress -nowrap 1 $data] + set data [zlib decompress $data] } err] } { ::vfs::log "$sb(name): inflate error: $err" - ::vfs::log [hexdump $data] + binary scan $data H* x + ::vfs::log $x } } return if { $verify } { - set ncrc [pink zlib crc $data] + set ncrc [zlib crc32 $data] if { $ncrc != $sb(crc) } { tclLog [format {%s: crc mismatch: expected 0x%x, got 0x%x} \ $sb(name) $sb(crc) $ncrc] @@ -348,7 +349,8 @@ proc zip::TOC {fd arr} { sb(atx) sb(ino) if { ![string equal "PK\01\02" $hdr] } { - error "bad central header: [hexdump $buf]" + binary scan $hdr H* x + error "bad central header: $x" } foreach v {vem ver flags method disk attr} {