+2002-04-25 Jean-Claude Wippler <jcw@equi4.com>
+ * 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 <vincentdarley@sourceforge.net>
* tests/*: revamp of tests to be more robust, and to be
able to run from inside a mounted virtual filesystem.
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]]
+++ /dev/null
-# 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 <jcw@equi4.com>
-
-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]
- }
- }
- }
- }
-}
+++ /dev/null
-# 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 <matt@sensus.org>
-# Further changes made by Jean-Claude Wippler <jcw@equi4.com>
-# Further changes made by Vince Darley <vince.darley@eurobios.com>
-#
-# 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 }
-}
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)
}
}
variable _unmountCmd
set norm [file normalize $mountpoint]
uplevel \#0 $_unmountCmd($norm) [list $norm]
+ unset _unmountCmd($norm)
}
::vfs::autoMountExtension "" ::vfs::mk4::Mount vfs
-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
::zip::stat $zipfd $name sb
- package require Trf
package require Memchan
set nfd [memchan]
error ""
}
-
# Below copied from TclKit distribution
#
# archive by first fetching EndOfArchive, then
# just loading the TOC
#
-package provide vfs.zip 0.5
namespace eval zip {
array set methods {
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)]
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]
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} {
projects / tclvfs / commitdiff