--- /dev/null
+The Storage package is Tcl extension that adds a 'storage' command to
+Tcl and provides access to Microsoft's "Structured Storage" file
+format. Structured storages are used extensively to provide
+persistence for OLE or COM components. The format presents a
+filesystem-like hierarchy of storages and streams that maps well into
+Tcl's virtual filesystem model.
+
+Notable users of structured storages are Microsoft Word and Excel.
+
+See http://www.patthoyts.tk/index.html#tclstorage for files and
+documentation.
+
+Usage:
+ storage open filename mode
+ mode is as per the Tcl open command "[raw]+?"
+ returns a storage command. The storage will remain open
+ as long as the command exists. You can close the storage file
+ using either the close subcommand or renaming the command.
+ eg: % storage open document.doc r+
+ stg1
+
+ object commands:
+ opendir name ?mode? open or create a sub-storage
+ open name ?mode? open or create a stream as a Tcl channel
+ close close the storage or sub-storage
+ stat name varname get information about the named item
+ commit not used
+ rename oldname newname rename a stream or sub-storage
+ remove name deletes a stream or sub-storage + contents
+ names list all items in the current storage
+
--- /dev/null
+/*
+ * $Id$
+ * Author: Joe English, <jenglish@flightab.com>
+ * Created: 26 Jun 2000
+ * Description: CSS stylesheet for TCL man pages
+ */
+
+HTML {
+ background: #FFFFFF;
+ color: black;
+}
+
+BODY {
+ background: #FFFFFF;
+ color: black;
+}
+
+DIV.body {
+ margin-left: 10%;
+ margin-right: 10%;
+}
+DIV.header,DIV.footer {
+ width: 100%;
+ margin-left: 0%;
+ margin-right: 0%;
+}
+
+DIV.body H1,DIV.body H2 {
+ margin-left: -5%;
+}
+
+/* Navigation material: */
+
+DIV.navbar {
+ width: 100%;
+ margin-top: 5pt;
+ margin-bottom: 5pt;
+ margin-left: 0%;
+ margin-right: 0%;
+ padding-top: 5pt;
+ padding-bottom: 5pt;
+ background: #DDDDDD;
+ color: black;
+ border: 1px solid black;
+ text-align: center;
+ font-size: small;
+ font-family: sans-serif;
+}
+
+P.navaid {
+ text-align: center;
+}
+.navaid {
+ font-size: small;
+ font-family: sans-serif;
+}
+
+P.notice {
+ text-align: center;
+ font-size: small;
+ font-family: sans-serif;
+ font-style: italic;
+ color: red;
+}
+
+A.navaid:link { color: green; background: transparent; }
+A.navaid:visited { color: green; background: transparent; }
+A.navaid:active { color: yellow; background: transparent; }
+
+/* For most anchors, we should leave colors up to the user's preferences. */
+/*--
+A:link { color: blue; background: transparent; }
+A:visited { color: purple; background: transparent; }
+A:active { color: red; background: transparent; }
+--*/
+
+H1, H2, H3, H4 {
+ margin-top: 1em;
+ font-family: sans-serif;
+ font-size: large;
+ color: #005A9C;
+ background: transparent;
+ text-align: left;
+}
+
+H1.title {
+ text-align: center;
+}
+
+UL,OL {
+ margin-right: 0em;
+ margin-top: 3pt;
+ margin-bottom: 3pt;
+}
+UL LI {
+ list-style: disc;
+}
+OL LI {
+ list-style: decimal;
+}
+
+DT {
+ padding-top: 1ex;
+}
+
+DL.toc {
+ font: normal 12pt/16pt sans-serif;
+ margin-left: 10%;
+}
+
+UL.toc,UL.toc UL, UL.toc UL UL {
+ font: normal 12pt/14pt sans-serif;
+ list-style: none;
+}
+LI.tocentry,LI.tocheading {
+ list-style: none;
+ margin-left: 0em;
+ text-indent: 0em;
+ padding: 0em;
+}
+
+.tocheading {
+ font-family: sans-serif;
+ font-weight: bold;
+ color: #005A9C;
+ background: transparent;
+}
+
+PRE {
+ display: block;
+ font-family: monospace;
+ white-space: pre;
+ margin: 0%;
+ padding-top: 0.5ex;
+ padding-bottom: 0.5ex;
+ padding-left: 1ex;
+ padding-right: 1ex;
+ width: 100%;
+}
+PRE.syntax {
+ color: black;
+ background: #80ffff;
+ border: 1px solid black;
+ font-family: serif;
+}
+PRE.example {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+}
+
+PRE.sample {
+ color: black;
+ background: #f5dcb3;
+ border: 1px solid black;
+}
+
+DIV.arglist {
+ border: 1px solid black;
+ width: 100%;
+}
+TH, THEAD TR, TR.heading {
+ color: #005A9C;
+ background: #DDDDDD;
+ text-align: center;
+ font-family: sans-serif;
+ font-weight: bold;
+}
+TR.syntax {
+ color: black;
+ background: #80ffff;
+}
+TR.desc {
+ color: black;
+ background: #f5dcb3;
+}
+
+/* TR.row[01] are used to get alternately colored table rows.
+ * Could probably choose better colors here...
+ */
+TR.row0 {
+ color: black;
+ background: #efffef;
+}
+
+TR.row1 {
+ color: black;
+ background: #efefff;
+}
+
+/* Workaround for Netscape bugs:
+ * Netscape doesn't seem to compute table widths properly.
+ * unless they're wrapped inside a DIV. (Additionally,
+ * it appears to require a non-zero border-width.)
+ */
+DIV.table {
+ border-width: 1px;
+ border-color: white;
+ width: 100%;
+}
+DIV.menu { /* Wrapper for TABLE class="menu" */
+ margin-top: 10px;
+ margin-bottom: 10px;
+ border: thin solid #005A9C;
+ width: 100%;
+ margin-left: 5%;
+}
+
+VAR {
+ font-style: italic;
+}
+
+/* For debugging: highlight unrecognized elements: */
+.unrecognized {
+ color: red; background: green;
+}
+
+/* EOF */
--- /dev/null
+[manpage_begin stgvfs n 1.0.0]
+[copyright {2004, Pat Thoyts}]
+[comment {link rel="stylesheet" href="manpage.css" type="text/css"}]
+[moddesc {stgvfs}]
+[titledesc {Structured storage based virtual filesystem}]
+[require Tcl 8.2]
+[require Storage [opt 1.0.0]]
+[require vfs::stg [opt 1.0.0]]
+[description]
+[para]
+
+This package builds upon the [package Storage] package to enable Tcl
+scripts to mount structured storage files as a virtual
+filesystem. Files based upon this format include Microsoft Word
+documents, Excel spreadsheets and Powerpoint presentations and are
+often used for OLE object persistence to file.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd "vfs::stg::Mount"] [arg "path"] [arg "to"]]
+
+Mount the specified file as directory [arg to].
+
+[list_end]
+
+[example {
+% package require stgvfs
+% vfs::stg::Mount "My Document.doc" "My Document.doc"
+% set f [open "My Document.doc/WordDocument" r]
+% fconfigure $f -encoding unicode
+% read $f
+}]
+
+[section AUTHORS]
+Pat Thoyts
+
+[see_also vfs(n) tclstorage(n)]
+[keywords {structured storage} stream vfs {virtual filesystem}]
+[manpage_end]
--- /dev/null
+[manpage_begin tclstorage n 1.0.0]
+[copyright {2004, Pat Thoyts}]
+[comment {link rel="stylesheet" href="manpage.css" type="text/css"}]
+[moddesc {tclstorage}]
+[titledesc {Structured storage access tcl extension}]
+[require Tcl 8.2]
+[require Storage [opt 1.0.0]]
+[description]
+[para]
+
+This package is an extension that adds the ability to access and
+manipulate Microsoft's "Structured Storage" files to Tcl. Structured
+storages are used extensively in Windows to provide persistence for
+OLE or COM components and as a composite file for various
+applications. The format presents a filesystem-like hierarchy of
+storages and streams that maps well into Tcl's virtual filesystem
+model.
+
+[para]
+
+Notable users of structured storages are Microsoft Word and Excel.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd "storage open"] [arg filename] [opt [arg "mode"]]]
+
+Creates or opens a structured storage file. This will create
+a unique command in the Tcl interpreter that can be used to
+access the contents of the storage. The file will remain
+open with exclusive access until this command is destroyed either
+by the use of the close sub-command or by renaming the command
+to {}.
+[nl]
+The mode string is as per the Tcl open command. If w is specified
+the file will be created.
+
+[list_end]
+
+[section "ENSEMBLE COMMANDS"]
+
+[list_begin definitions]
+
+[call "\$stg [cmd opendir] [arg name] [opt [arg mode]]"]
+
+Opens a sub-storage. A new Tcl command is created to manage the
+resource and the mode is as per the Tcl open command. If 'w'
+is specified then the sub-storage is created as a child of the
+current storage if it is not already present.
+Note: Storages may be read-only or write-only or read-write.
+[nl]
+The sub-storage is only usable if all it's parents are still
+open. This limitation is part of the COM architecture.
+If a parent storage is closed then the only valid command
+on its children is a close.
+
+[call "\$stg [cmd open] [arg name] [opt [arg mode]]"]
+
+Open a file within the storage. This opens the named item
+and creates a Tcl channel to support reading and writing
+data. Modes are as per the Tcl 'open' command and may depend upon
+the mode settings of the owning storage.
+
+[call "\$stg [cmd close]"]
+
+Closes the storage or sub-storage and deletes the command from the
+interpreter. See the [cmd opendir] command for some caveats about
+this.
+
+[call "\$stg [cmd stat] [arg name] [arg varname]"]
+
+Fetches information about an item in the structured storage. This is
+equivalent to the [cmd "file stat"] command and similar fields are set
+in [arg varname].
+
+[call "\$stg [cmd commit]"]
+
+Flush changes to the underlying file.
+
+At the moment we always use STGM_DIRECT. In the future we may
+support transacted mode in which case this would do something.
+However, for multi-megabyte files there is a significant
+performance hit when using transacted mode - especially during
+the commit.
+
+[call "\$stg [cmd rename] [arg oldname] [arg newname]"]
+
+Change the name of an item
+
+[call "\$stg [cmd remove] [arg name]"]
+
+Removes the item from the storage. If the named item is a
+sub-storage then it is removed [strong "even if not empty"].
+
+[call "\$stg [cmd names]"]
+
+Obtain a list of all item names contained in this storage. The list
+includes both sub-storage names and stream names and is not sorted.
+
+[list_end]
+
+[example {
+% package require Storage
+1.0.0
+% set stg [storage open test.stg w+]
+stg1
+% set stm [$stg open file.txt w]
+stm1
+% puts $stm "Hello, World!"
+% close $stm
+% $stg names
+file.txt
+% $stg close
+}]
+
+[section AUTHORS]
+Pat Thoyts
+
+[keywords {structured storage} stream vfs {virtual filesystem}]
+[manpage_end]
--- /dev/null
+# stgvfs.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+#
+#
+
+package require vfs 1; # tclvfs
+package require Storage; # tclstorage
+
+namespace eval ::vfs::stg {
+ variable version 1.0.0
+ variable rcsid {$Id$}
+
+ variable uid
+ if {![info exists uid]} {
+ set uid 0
+ }
+}
+
+proc ::vfs::stg::Mount {path local} {
+ variable uid
+ set stg [::storage open [::file normalize $path] r+]
+
+ set token [namespace current]::mount[incr uid]
+ variable $token
+ upvar \#0 $token state
+ catch {unset state}
+ set state(/stg) $stg
+ set state(/root) $path
+ set state(/mnt) $local
+
+ vfs::filesystem mount $local [list [namespace origin handler] $token]
+ vfs::RegisterMount $local [list [namespace origin Unmount] $token]
+ return $token
+}
+
+proc ::vfs::stg::Unmount {token local} {
+ variable $token
+ upvar \#0 $token state
+
+ foreach path [array get state] {
+ if {![string match "/*" $path]} {
+ catch {$state($path) close}
+ }
+ }
+ vfs::filesystem unmount $local
+ $state(/stg) close
+ unset state
+}
+
+proc ::vfs::stg::Execute {path} {
+ Mount $path $path
+ source [file join $path main.tcl]
+}
+
+# -------------------------------------------------------------------------
+
+proc ::vfs::stg::handler {token cmd root relative actualpath args} {
+ #::vfs::log [list $token $cmd $root $relative $actualpath $args]
+ if {![string compare $cmd "matchindirectory"]} {
+ eval [linsert $args 0 $cmd $token $relative $actualpath]
+ } else {
+ eval [linsert $args 0 $cmd $token $relative]
+ }
+}
+
+# Open up a path within the specified storage. We cache the intermediate
+# opened storage items (we have to or the leaves are invalid).
+# Returns the final storage item in the path.
+# - path
+proc ::vfs::stg::PathToStg {token path} {
+ variable $token
+ upvar \#0 $token state
+ set stg $state(/stg)
+ if {[string equal $path "."]} {return $stg}
+ set elements [file split $path]
+ set path {}
+ foreach dir $elements {
+ set path [file join $path $dir]
+ if {[info exists state($path)]} {
+ set stg $state($path)
+ } else {
+ set stg [$stg opendir $dir r+]
+ set state($path) $stg
+ }
+ }
+
+ return $stg
+}
+
+
+# -------------------------------------------------------------------------
+# The vfs handler procedures
+# -------------------------------------------------------------------------
+
+proc vfs::stg::access {token name mode} {
+ ::vfs::log "access: $token $name $mode"
+
+ if {[string length $name] < 1} {return 1}
+ set stg [PathToStg $token [file dirname $name]]
+ if {[catch {$stg stat [file tail $name] sd} err]} {
+ vfs::filesystem posixerror $::vfs::posix(ENOENT)
+ } else {
+ if {($mode & 2) && $sd(mode) == 1} {
+ vfs::filesystem posixerror $::vfs::posix(EACCES)
+ }
+ }
+ return
+}
+
+proc vfs::stg::createdirectory {token path} {
+ ::vfs::log "createdirectory: $token $path"
+ set stg [PathToStg $token [file dirname $path]]
+ $stg opendir [file tail $path] w+
+}
+
+proc vfs::stg::attributes {token} {
+ ::vfs::log "attributes: $fd"
+ return [list "state"]
+}
+
+proc vfs::stg::stat {token path} {
+ ::vfs::log "stat: $token \"$path\""
+ set stg [PathToStg $token [file dirname $path]]
+ $stg stat [file tail $path] sb
+ array get sb
+}
+
+proc vfs::stg::state {token args} {
+ ::vfs::log "state: $token $args"
+ vfs::attributeCantConfigure "state" "readonly" $args
+}
+
+proc vfs::stg::matchindirectory {token path actualpath pattern type} {
+ ::vfs::log [list matchindirectory: $token $path $actualpath $pattern $type]
+
+ set names {}
+ if {[string length $pattern] > 0} {
+ set stg [PathToStg $token $path]
+ foreach name [$stg names] {
+ if {[string match $pattern $name]} {lappend names $name}
+ }
+ } else {
+ set stg [PathToStg $token [file dirname $path]]
+ set names [file tail $path]
+ set actualpath [file dirname $actualpath]
+ if {[catch {$stg stat $names sd}]} {
+ ::vfs::filesystem posixerror ::vfs::posix(ENOENT)
+ return {}
+ }
+ }
+
+ set glob {}
+ foreach name [::vfs::matchCorrectTypes $type $names $actualpath] {
+ lappend glob [file join $actualpath $name]
+ }
+ return $glob
+}
+
+proc vfs::stg::open {token path mode permissions} {
+ ::vfs::log "open: $token $path $mode $permissions"
+ set stg [PathToStg $token [file dirname $path]]
+ if {[catch {set f [$stg open [file tail $path] $mode]} err]} {
+ vfs::filesystem posixerror $::vfs::posix(EACCES)
+ } else {
+ return [list $f]
+ }
+}
+
+proc vfs::stg::removedirectory {token path recursive} {
+ ::vfs::log "removedirectory: $token $path $recursive"
+ variable $token
+ upvar #0 $token state
+ set stg [PathToStg $token [file dirname $path]]
+ $stg remove [file tail $path]
+ if {[info exist state($path)]} {
+ $state($path) close
+ unset state($path)
+ }
+}
+
+proc ::vfs::stg::deletefile {token path} {
+ ::vfs::log "deletefile: $token $path"
+ set stg [PathToStg $token [file dirname $path]]
+ $stg remove [file tail $path]
+}
+
+proc ::vfs::stg::fileattributes {token path args} {
+ #::vfs::log "fileattributes: $token $path $args"
+ # for normal files, this is the following:
+ # -archive 1 -hidden 0 -longname ztest.stg -readonly 0
+ # -shortname ztest.stg -system 0
+ # We don't have any yet.
+ switch -- [llength $args] {
+ 0 {
+ # list strings
+ return [list]
+ }
+ 1 {
+ # get value
+ # set index [lindex $args 0]
+ return ""
+ }
+ 2 {
+ # set value
+ # foreach {index value} $args break
+ vfs::filesystem posixerror $::vfs::posix(EROFS)
+ }
+ }
+}
+
+proc ::vfs::stg::utime {token path atime mtime} {
+ #::vfs::log "utime: $path $atime $mtime"
+ set stg [PathToStg $token [file dirname $path]]
+ #$stg touch [file tail $path] $atime $mtime
+ # FIX ME: we don't have a touch op yet.
+ vfs::filesystem posixerror $::vfs::posix(EACCES)
+}
+
+# -------------------------------------------------------------------------
+
+package provide vfs::stg $::vfs::stg::version
+package provide stgvfs $::vfs::stg::version
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
--- /dev/null
+# makefile.vc -- -*- Makefile -*-
+#
+# Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+)
+#
+# This makefile is based upon the Tcl 8.4 Makefile.vc and modified to
+# make it suitable as a general package makefile. Look for the word EDIT
+# which marks sections that may need modification. As a minumum you will
+# need to change the PROJECT, DOTVERSION and DLLOBJS variables to values
+# relevant to your package.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-2000 Ajuba Solutions.
+# Copyright (c) 2001 ActiveState Corporation.
+# Copyright (c) 2001-2002 David Gravereaux.
+# Copyright (c) 2003 Pat Thoyts
+#
+#-------------------------------------------------------------------------
+# RCS: @(#)$Id$
+#-------------------------------------------------------------------------
+
+!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCToolkitInstallDir)
+MSG = ^
+You will need to run vcvars32.bat from Developer Studio, first, to setup^
+the environment. Jump to this line to read the new instructions.
+!error $(MSG)
+!endif
+
+#------------------------------------------------------------------------------
+# HOW TO USE this makefile:
+#
+# 1) It is now necessary to have %MSVCDir% set in the environment. This is
+# used as a check to see if vcvars32.bat had been run prior to running
+# nmake or during the installation of Microsoft Visual C++, MSVCDir had
+# been set globally and the PATH adjusted. Either way is valid.
+#
+# You'll need to run vcvars32.bat contained in the MsDev's vc(98)/bin
+# directory to setup the proper environment, if needed, for your current
+# setup. This is a needed bootstrap requirement and allows the swapping of
+# different environments to be easier.
+#
+# 2) To use the Platform SDK (not expressly needed), run setenv.bat after
+# vcvars32.bat according to the instructions for it. This can also turn on
+# the 64-bit compiler, if your SDK has it.
+#
+# 3) Targets are:
+# all -- Builds everything.
+# <project> -- Builds the project (eg: nmake sample)
+# test -- Builds and runs the test suite.
+# install -- Installs the built binaries and libraries to $(INSTALLDIR)
+# in an appropriate subdirectory.
+# clean/realclean/distclean -- varying levels of cleaning.
+#
+# 4) Macros usable on the commandline:
+# INSTALLDIR=<path>
+# Sets where to install Tcl from the built binaries.
+# C:\Progra~1\Tcl is assumed when not specified.
+#
+# OPTS=static,msvcrt,staticpkg,threads,symbols,profile,loimpact,none
+# Sets special options for the core. The default is for none.
+# Any combination of the above may be used (comma separated).
+# 'none' will over-ride everything to nothing.
+#
+# static = Builds a static library of the core instead of a
+# dll. The shell will be static (and large), as well.
+# msvcrt = Effects the static option only to switch it from
+# using libcmt(d) as the C runtime [by default] to
+# msvcrt(d). This is useful for static embedding
+# support.
+# staticpkg = Effects the static option only to switch
+# tclshXX.exe to have the dde and reg extension linked
+# inside it.
+# threads = Turns on full multithreading support.
+# thrdalloc = Use the thread allocator (shared global free pool).
+# symbols = Adds symbols for step debugging.
+# profile = Adds profiling hooks. Map file is assumed.
+# loimpact = Adds a flag for how NT treats the heap to keep memory
+# in use, low. This is said to impact alloc performance.
+#
+# STATS=memdbg,compdbg,none
+# Sets optional memory and bytecode compiler debugging code added
+# to the core. The default is for none. Any combination of the
+# above may be used (comma separated). 'none' will over-ride
+# everything to nothing.
+#
+# memdbg = Enables the debugging memory allocator.
+# compdbg = Enables byte compilation logging.
+#
+# MACHINE=(IX86|IA64|ALPHA)
+# Set the machine type used for the compiler, linker, and
+# resource compiler. This hook is needed to tell the tools
+# when alternate platforms are requested. IX86 is the default
+# when not specified.
+#
+# TMP_DIR=<path>
+# OUT_DIR=<path>
+# Hooks to allow the intermediate and output directories to be
+# changed. $(OUT_DIR) is assumed to be
+# $(BINROOT)\(Release|Debug) based on if symbols are requested.
+# $(TMP_DIR) will de $(OUT_DIR)\<buildtype> by default.
+#
+# TESTPAT=<file>
+# Reads the tests requested to be run from this file.
+#
+# CFG_ENCODING=encoding
+# name of encoding for configuration information. Defaults
+# to cp1252
+#
+# 5) Examples:
+#
+# Basic syntax of calling nmake looks like this:
+# nmake [-nologo] -f makefile.vc [target|macrodef [target|macrodef] [...]]
+#
+# Standard (no frills)
+# c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat
+# Setting environment for using Microsoft Visual C++ tools.
+# c:\tcl_src\win\>nmake -f makefile.vc all
+# c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl
+#
+# Building for Win64
+# c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat
+# Setting environment for using Microsoft Visual C++ tools.
+# c:\tcl_src\win\>c:\progra~1\platfo~1\setenv.bat /pre64 /RETAIL
+# Targeting Windows pre64 RETAIL
+# c:\tcl_src\win\>nmake -f makefile.vc MACHINE=IA64
+#
+#------------------------------------------------------------------------------
+#==============================================================================
+###############################################################################
+#------------------------------------------------------------------------------
+
+!if !exist("makefile.vc")
+MSG = ^
+You must run this makefile only from the directory it is in.^
+Please `cd` to its location first.
+!error $(MSG)
+!endif
+
+#-------------------------------------------------------------------------
+# Project specific information (EDIT)
+#
+# You should edit this with the name and version of your project. This
+# information is used to generate the name of the package library and
+# it's install location.
+#
+# For example, the sample extension is going to build sample04.dll and
+# would install it into $(INSTALLDIR)\lib\sample04
+#
+# You need to specify the object files that need to be linked into your
+# binary here.
+#
+#-------------------------------------------------------------------------
+
+PROJECT = tclstorage
+!include "rules.vc"
+
+DOTVERSION = 1.0.0
+VERSION = $(DOTVERSION:.=)
+STUBPREFIX = $(PROJECT)stub
+
+DLLOBJS = \
+ $(TMP_DIR)\tclstorage.obj
+RCRES = \
+ $(TMP_DIR)\tclstorage.res
+
+HTMLDOCS = \
+ $(DOCDIR)\tclstorage.html \
+ $(DOCDIR)\stgvfs.html
+
+#-------------------------------------------------------------------------
+# Target names and paths ( shouldn't need changing )
+#-------------------------------------------------------------------------
+
+BINROOT = .
+ROOT = .
+
+PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
+PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT)
+PRJLIB = $(OUT_DIR)\$(PRJLIBNAME)
+
+PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib
+PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME)
+
+### Make sure we use backslash only.
+PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION)
+LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR)
+BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR)
+DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR)
+SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR)
+INCLUDE_INSTALL_DIR = $(_TCLDIR)\include
+
+### The following paths CANNOT have spaces in them.
+GENERICDIR = $(ROOT)\generic
+WINDIR = $(ROOT)
+LIBDIR = $(ROOT)\library
+DOCDIR = $(ROOT)\doc
+TOOLSDIR = $(ROOT)\tools
+COMPATDIR = $(ROOT)\compat
+
+#---------------------------------------------------------------------
+# Compile flags
+#---------------------------------------------------------------------
+
+!if !$(DEBUG)
+!if $(OPTIMIZING)
+### This cranks the optimization level to maximize speed
+cdebug = -O2 -Op -Gs
+!else
+cdebug =
+!endif
+!else if "$(MACHINE)" == "IA64"
+### Warnings are too many, can't support warnings into errors.
+cdebug = -Z7 -Od -GZ
+!else
+cdebug = -Z7 -WX -Od -GZ
+!endif
+
+### Declarations common to all compiler options
+cflags = -nologo -c -W3 -YX -Fp$(TMP_DIR)^\
+
+!if $(PENT_0F_ERRATA)
+cflags = $(cflags) -QI0f
+!endif
+
+!if $(ITAN_B_ERRATA)
+cflags = $(cflags) -QIA64_Bx
+!endif
+
+!if $(MSVCRT)
+!if $(DEBUG)
+crt = -MDd
+!else
+crt = -MD
+!endif
+!else
+!if $(DEBUG)
+crt = -MTd
+!else
+crt = -MT
+!endif
+!endif
+
+INCLUDES = $(TCL_INCLUDES) -I"$(WINDIR)" -I"$(GENERICDIR)"
+BASE_CLFAGS = $(cflags) $(cdebug) $(crt) $(INCLUDES)
+CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE
+TCL_CFLAGS = -DUSE_TCL_STUBS -DPACKAGE_VERSION="\"$(DOTVERSION)\"" \
+ $(BASE_CLFAGS) $(OPTDEFINES)
+
+#---------------------------------------------------------------------
+# Link flags
+#---------------------------------------------------------------------
+
+!if $(DEBUG)
+ldebug = -debug:full -debugtype:cv
+!else
+ldebug = -release -opt:ref -opt:icf,3
+!endif
+
+### Declarations common to all linker options
+lflags = -nologo -machine:$(MACHINE) $(ldebug)
+
+!if $(PROFILE)
+lflags = $(lflags) -profile
+!endif
+
+!if $(ALIGN98_HACK) && !$(STATIC_BUILD)
+### Align sections for PE size savings.
+lflags = $(lflags) -opt:nowin98
+!else if !$(ALIGN98_HACK) && $(STATIC_BUILD)
+### Align sections for speed in loading by choosing the virtual page size.
+lflags = $(lflags) -align:4096
+!endif
+
+!if $(LOIMPACT)
+lflags = $(lflags) -ws:aggressive
+!endif
+
+dlllflags = $(lflags) -dll
+conlflags = $(lflags) -subsystem:console
+guilflags = $(lflags) -subsystem:windows
+baselibs = $(TCLSTUBLIB) ole32.lib advapi32.lib
+
+#---------------------------------------------------------------------
+# TclTest flags
+#---------------------------------------------------------------------
+
+!IF "$(TESTPAT)" != ""
+TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT)
+!ENDIF
+
+#---------------------------------------------------------------------
+# Project specific targets (EDIT)
+#---------------------------------------------------------------------
+
+all: setup $(PROJECT)
+$(PROJECT): setup $(PRJLIB)
+install: install-binaries install-libraries install-docs
+docs: $(HTMLDOCS)
+
+# Tests need to ensure we load the right dll file we
+# have to handle the output differently on Win9x.
+#
+!if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE"
+test: setup $(PROJECT)
+ set TCL_LIBRARY=$(ROOT)/library
+ $(TCLSH) <<
+load $(PRJLIB:\=/) Storage
+cd "$(ROOT)/tests"
+set argv "$(TESTFLAGS)"
+source all.tcl
+<<
+!else
+test: setup $(PROJECT)
+ echo Please wait while the test results are collected
+ set TCL_LIBRARY=$(ROOT)/library
+ $(TCLSH) << >tests.log
+load $(PRJLIB:\=/) Storage
+cd "$(ROOT)/tests"
+set argv "$(TESTFLAGS)"
+source all.tcl
+<<
+ type tests.log | more
+!endif
+
+setup:
+ @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR)
+ @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR)
+
+$(PRJLIB): $(DLLOBJS) $(RCRES)
+ $(link32) $(dlllflags) -out:$@ $(baselibs) @<<
+$**
+<<
+ -@del $*.exp
+
+$(PRJSTUBLIB): $(PRJSTUBOBJS)
+ $(lib32) -nologo -out:$@ $(PRJSTUBOBJS)
+
+#---------------------------------------------------------------------
+# Implicit rules
+#---------------------------------------------------------------------
+
+{$(WINDIR)}.c{$(TMP_DIR)}.obj::
+ $(cc32) $(TCL_CFLAGS) -DBUILD_$(PROJECT) -Fo$(TMP_DIR)\ @<<
+$<
+<<
+
+{$(GENERICDIR)}.c{$(TMP_DIR)}.obj::
+ $(cc32) $(TCL_CFLAGS) -DBUILD_$(PROJECT) -Fo$(TMP_DIR)\ @<<
+$<
+<<
+
+{$(COMPATDIR)}.c{$(TMP_DIR)}.obj::
+ $(cc32) $(TCL_CFLAGS) -DBUILD_$(PROJECT) -Fo$(TMP_DIR)\ @<<
+$<
+<<
+
+{$(WINDIR)}.rc{$(TMP_DIR)}.res:
+ $(rc32) -fo $@ -r -i "$(GENERICDIR)" -D__WIN32__ \
+ -DCOMMAVERSION=$(DOTVERSION:.=,),0 \
+ -DDOTVERSION=\"$(DOTVERSION)\" \
+ -DVERSION=\"$(VERSION)$(SUFX)\" \
+!if $(DEBUG)
+ -d DEBUG \
+!endif
+!if $(TCL_THREADS)
+ -d TCL_THREADS \
+!endif
+!if $(STATIC_BUILD)
+ -d STATIC_BUILD \
+!endif
+ $<
+
+{$(DOCDIR)}.man{$(DOCDIR)}.html:
+ mpexpand html $< $@
+ @set TCL_LIBRARY=$(ROOT)/library
+ @$(TCLSH) <<
+set name $(@:\=/)
+set f [open $$name r]; set d [read $$f]; close $$f
+set d [regsub {</head>} $$d {<link rel="stylesheet" href="manpage.css" type="text/css"></head>}]
+set f [open $$name w]; puts -nonewline $$f $$d; close $$f
+<<
+
+.SUFFIXES:
+.SUFFIXES:.c .rc .man
+
+#---------------------------------------------------------------------
+# Installation. (EDIT)
+#
+# You may need to modify this section to reflect the final distribution
+# of your files and possibly to generate documentation.
+#
+#---------------------------------------------------------------------
+
+install-binaries:
+ @echo Installing binaries to '$(SCRIPT_INSTALL_DIR)'
+ @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)"
+ @$(CPY) $(PRJLIB) "$(SCRIPT_INSTALL_DIR)" >NUL
+
+install-libraries:
+ @echo Installing libraries to '$(SCRIPT_INSTALL_DIR)'
+ @if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)" >NUL
+ @echo Installing package index in '$(SCRIPT_INSTALL_DIR)'
+ @type << >"$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
+# Hand-crafted pkgIndex.tcl
+if {![package vsatisfies [package provide Tcl] 8]} {return}
+if {[string compare $$::tcl_platform(platform) windows]} {return}
+if {[info exists ::tcl_platform(debug)]} {
+ package ifneeded Storage $(DOTVERSION) \
+ [list load [file join $$dir $(PROJECT)$(VERSION)_g.$(EXT)] Storage]
+} else {
+ package ifneeded Storage $(DOTVERSION) \
+ [list load [file join $$dir $(PROJECT)$(VERSION).$(EXT)] Storage]
+}
+package ifneeded vfs::stg $(DOTVERSION) [list source [file join $$dir stgvfs.tcl]]
+package ifneeded stgvfs $(DOTVERSION) [list source [file join $$dir stgvfs.tcl]]
+<<
+
+install-docs:
+ @echo Installing documentation files to '$(DOC_INSTALL_DIR)'
+ @if exist $(DOCDIR) $(CPY) $(DOCDIR)\*.html "$(DOC_INSTALL_DIR)" >NUL
+ @if exist $(DOCDIR) $(CPY) $(DOCDIR)\*.css "$(DOC_INSTALL_DIR)" >NUL
+
+#---------------------------------------------------------------------
+# Clean up
+#---------------------------------------------------------------------
+
+clean:
+ @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR)
+ @if exist $(WINDIR)\version.vc del $(WINDIR)\version.vc
+
+realclean: clean
+ @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR)
+
+distclean: realclean
+ @if exist $(WINDIR)\nmakehlp.exe del $(WINDIR)\nmakehlp.exe
+ @if exist $(WINDIR)\nmakehlp.obj del $(WINDIR)\nmakehlp.obj
--- /dev/null
+/* ----------------------------------------------------------------------------
+ * nmakehlp.c --
+ *
+ * This is used to fix limitations within nmake and the environment.
+ *
+ * Copyright (c) 2002 by David Gravereaux.
+ * Copyright (c) 2003 by Patrick Thoyts
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * ----------------------------------------------------------------------------
+ * RCS: @(#) $Id$
+ * ----------------------------------------------------------------------------
+ */
+#include <windows.h>
+#include <stdio.h>
+#pragma comment (lib, "user32.lib")
+#pragma comment (lib, "kernel32.lib")
+
+/* protos */
+int CheckForCompilerFeature (const char *option);
+int CheckForLinkerFeature (const char *option);
+int IsIn (const char *string, const char *substring);
+DWORD WINAPI ReadFromPipe (LPVOID args);
+int GetVersionFromHeader(const char *tclh, const char *tkh);
+
+/* globals */
+typedef struct {
+ HANDLE pipe;
+ char buffer[1000];
+} pipeinfo;
+
+pipeinfo Out = {INVALID_HANDLE_VALUE, '\0'};
+pipeinfo Err = {INVALID_HANDLE_VALUE, '\0'};
+
+
+
+/* exitcodes: 0 == no, 1 == yes, 2 == error */
+int
+main (int argc, char *argv[])
+{
+ char msg[300];
+ DWORD dwWritten;
+ int chars;
+
+ if (argc > 1 && *argv[1] == '-') {
+ switch (*(argv[1]+1)) {
+ case 'c':
+ if (argc != 3) {
+ chars = wsprintf(msg, "usage: %s -c <compiler option>\n"
+ "Tests for whether cl.exe supports an option\n"
+ "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
+ return 2;
+ }
+ return CheckForCompilerFeature(argv[2]);
+ case 'l':
+ if (argc != 3) {
+ chars = wsprintf(msg, "usage: %s -l <linker option>\n"
+ "Tests for whether link.exe supports an option\n"
+ "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
+ return 2;
+ }
+ return CheckForLinkerFeature(argv[2]);
+ case 'f':
+ if (argc == 2) {
+ chars = wsprintf(msg, "usage: %s -f <string> <substring>\n"
+ "Find a substring within another\n"
+ "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
+ return 2;
+ } else if (argc == 3) {
+ /* if the string is blank, there is no match */
+ return 0;
+ } else {
+ return IsIn(argv[2], argv[3]);
+ }
+ case 'v':
+ if (argc != 4) {
+ chars = wsprintf(msg, "usage: %s -v <tcl.h> <tk.h>\n"
+ "Search for versions from the tcl and tk headers.",
+ argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
+ return 0;
+ }
+ return GetVersionFromHeader(argv[2], argv[3]);
+ }
+ }
+ chars = wsprintf(msg, "usage: %s -c|-l|-f ...\n"
+ "This is a little helper app to equalize shell differences between WinNT and\n"
+ "Win9x and get nmake.exe to accomplish its job.\n",
+ argv[0]);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
+ return 2;
+}
+
+int
+CheckForCompilerFeature (const char *option)
+{
+ STARTUPINFO si;
+ PROCESS_INFORMATION pi;
+ SECURITY_ATTRIBUTES sa;
+ DWORD threadID;
+ char msg[300];
+ BOOL ok;
+ HANDLE hProcess, h, pipeThreads[2];
+ char cmdline[100];
+
+ hProcess = GetCurrentProcess();
+
+ ZeroMemory(&pi, sizeof(PROCESS_INFORMATION));
+ ZeroMemory(&si, sizeof(STARTUPINFO));
+ si.cb = sizeof(STARTUPINFO);
+ si.dwFlags = STARTF_USESTDHANDLES;
+ si.hStdInput = INVALID_HANDLE_VALUE;
+
+ ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
+ sa.nLength = sizeof(SECURITY_ATTRIBUTES);
+ sa.lpSecurityDescriptor = NULL;
+ sa.bInheritHandle = FALSE;
+
+ /* create a non-inheritible pipe. */
+ CreatePipe(&Out.pipe, &h, &sa, 0);
+
+ /* dupe the write side, make it inheritible, and close the original. */
+ DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput,
+ 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
+
+ /* Same as above, but for the error side. */
+ CreatePipe(&Err.pipe, &h, &sa, 0);
+ DuplicateHandle(hProcess, h, hProcess, &si.hStdError,
+ 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
+
+ /* base command line */
+ strcpy(cmdline, "cl.exe -nologo -c -TC -Fdtemp ");
+ /* append our option for testing */
+ strcat(cmdline, option);
+ /* filename to compile, which exists, but is nothing and empty. */
+ strcat(cmdline, " nul");
+
+ ok = CreateProcess(
+ NULL, /* Module name. */
+ cmdline, /* Command line. */
+ NULL, /* Process handle not inheritable. */
+ NULL, /* Thread handle not inheritable. */
+ TRUE, /* yes, inherit handles. */
+ DETACHED_PROCESS, /* No console for you. */
+ NULL, /* Use parent's environment block. */
+ NULL, /* Use parent's starting directory. */
+ &si, /* Pointer to STARTUPINFO structure. */
+ &pi); /* Pointer to PROCESS_INFORMATION structure. */
+
+ if (!ok) {
+ DWORD err = GetLastError();
+ int chars = wsprintf(msg, "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
+
+ FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS |
+ FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID) &msg[chars],
+ (300-chars), 0);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, strlen(msg), &err, NULL);
+ return 2;
+ }
+
+ /* close our references to the write handles that have now been inherited. */
+ CloseHandle(si.hStdOutput);
+ CloseHandle(si.hStdError);
+
+ WaitForInputIdle(pi.hProcess, 5000);
+ CloseHandle(pi.hThread);
+
+ /* start the pipe reader threads. */
+ pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID);
+ pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID);
+
+ /* block waiting for the process to end. */
+ WaitForSingleObject(pi.hProcess, INFINITE);
+ CloseHandle(pi.hProcess);
+
+ /* clean up temporary files before returning */
+ DeleteFile("temp.idb");
+ DeleteFile("temp.pdb");
+
+ /* wait for our pipe to get done reading, should it be a little slow. */
+ WaitForMultipleObjects(2, pipeThreads, TRUE, 500);
+ CloseHandle(pipeThreads[0]);
+ CloseHandle(pipeThreads[1]);
+
+ /* look for the commandline warning code in both streams. */
+ return !(strstr(Out.buffer, "D4002") != NULL || strstr(Err.buffer, "D4002") != NULL);
+}
+
+int
+CheckForLinkerFeature (const char *option)
+{
+ STARTUPINFO si;
+ PROCESS_INFORMATION pi;
+ SECURITY_ATTRIBUTES sa;
+ DWORD threadID;
+ char msg[300];
+ BOOL ok;
+ HANDLE hProcess, h, pipeThreads[2];
+ char cmdline[100];
+
+ hProcess = GetCurrentProcess();
+
+ ZeroMemory(&pi, sizeof(PROCESS_INFORMATION));
+ ZeroMemory(&si, sizeof(STARTUPINFO));
+ si.cb = sizeof(STARTUPINFO);
+ si.dwFlags = STARTF_USESTDHANDLES;
+ si.hStdInput = INVALID_HANDLE_VALUE;
+
+ ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
+ sa.nLength = sizeof(SECURITY_ATTRIBUTES);
+ sa.lpSecurityDescriptor = NULL;
+ sa.bInheritHandle = TRUE;
+
+ /* create a non-inheritible pipe. */
+ CreatePipe(&Out.pipe, &h, &sa, 0);
+
+ /* dupe the write side, make it inheritible, and close the original. */
+ DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput,
+ 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
+
+ /* Same as above, but for the error side. */
+ CreatePipe(&Err.pipe, &h, &sa, 0);
+ DuplicateHandle(hProcess, h, hProcess, &si.hStdError,
+ 0, TRUE, DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
+
+ /* base command line */
+ strcpy(cmdline, "link.exe -nologo ");
+ /* append our option for testing */
+ strcat(cmdline, option);
+ /* filename to compile, which exists, but is nothing and empty. */
+// strcat(cmdline, " nul");
+
+ ok = CreateProcess(
+ NULL, /* Module name. */
+ cmdline, /* Command line. */
+ NULL, /* Process handle not inheritable. */
+ NULL, /* Thread handle not inheritable. */
+ TRUE, /* yes, inherit handles. */
+ DETACHED_PROCESS, /* No console for you. */
+ NULL, /* Use parent's environment block. */
+ NULL, /* Use parent's starting directory. */
+ &si, /* Pointer to STARTUPINFO structure. */
+ &pi); /* Pointer to PROCESS_INFORMATION structure. */
+
+ if (!ok) {
+ DWORD err = GetLastError();
+ int chars = wsprintf(msg, "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
+
+ FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS |
+ FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID) &msg[chars],
+ (300-chars), 0);
+ WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, strlen(msg), &err, NULL);
+ return 2;
+ }
+
+ /* close our references to the write handles that have now been inherited. */
+ CloseHandle(si.hStdOutput);
+ CloseHandle(si.hStdError);
+
+ WaitForInputIdle(pi.hProcess, 5000);
+ CloseHandle(pi.hThread);
+
+ /* start the pipe reader threads. */
+ pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID);
+ pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID);
+
+ /* block waiting for the process to end. */
+ WaitForSingleObject(pi.hProcess, INFINITE);
+ CloseHandle(pi.hProcess);
+
+ /* wait for our pipe to get done reading, should it be a little slow. */
+ WaitForMultipleObjects(2, pipeThreads, TRUE, 500);
+ CloseHandle(pipeThreads[0]);
+ CloseHandle(pipeThreads[1]);
+
+ /* look for the commandline warning code in the stderr stream. */
+ return !(strstr(Out.buffer, "LNK1117") != NULL || strstr(Err.buffer, "LNK1117") != NULL);
+}
+
+DWORD WINAPI
+ReadFromPipe (LPVOID args)
+{
+ pipeinfo *pi = (pipeinfo *) args;
+ char *lastBuf = pi->buffer;
+ DWORD dwRead;
+ BOOL ok;
+
+again:
+ ok = ReadFile(pi->pipe, lastBuf, 25, &dwRead, 0L);
+ if (!ok || dwRead == 0) {
+ CloseHandle(pi->pipe);
+ return 0;
+ }
+ lastBuf += dwRead;
+ goto again;
+
+ return 0; /* makes the compiler happy */
+}
+
+int
+IsIn (const char *string, const char *substring)
+{
+ return (strstr(string, substring) != NULL);
+}
+
+
+static double
+ReadVersionFromHeader(const char *file, const char *macro)
+{
+ double d = 0.0;
+ CHAR szBuffer[100];
+ LPSTR p;
+ DWORD cbBuffer = 100;
+ FILE *fp = fopen(file, "r");
+ if (fp != NULL) {
+ while (fgets(szBuffer, cbBuffer, fp) != NULL) {
+ if ((p = strstr(szBuffer, macro)) != NULL) {
+ while (*p && !isdigit(*p)) ++p;
+ d = strtod(p, NULL);
+ break;
+ }
+ }
+ fclose(fp);
+ }
+ return d;
+}
+
+int
+GetVersionFromHeader(const char *tclh, const char *tkh)
+{
+ double dTcl = 0.0, dTk = 0.0;
+
+ if (tclh != NULL)
+ dTcl = ReadVersionFromHeader(tclh, "TCL_VERSION");
+ if (tkh != NULL)
+ dTk = ReadVersionFromHeader(tkh, "TK_VERSION");
+
+ if (dTcl > 0 || dTk > 0) {
+ FILE *ofp = fopen("version.vc", "w");
+ if (dTcl > 0)
+ fprintf(ofp, "TCL_DOTVERSION\t= %0.1f\nTCL_VERSION\t= %u\n",
+ dTcl, (int)(dTcl * 10.0));
+ if (dTk > 0)
+ fprintf(ofp, "TK_DOTVERSION\t= %0.1f\nTK_VERSION\t= %u\n",
+ dTk, (int)(dTk * 10.0));
+ fclose(ofp);
+ return 0;
+ }
+ return 1;
+}
--- /dev/null
+#------------------------------------------------------------------------------
+# rules.vc --
+#
+# Microsoft Visual C++ makefile include for decoding the commandline
+# macros. This file does not need editing to build Tcl.
+#
+# This version is modified from the Tcl source version to support
+# building extensions using nmake.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Copyright (c) 2001-2002 David Gravereaux.
+# Copyright (c) 2003 Patrick Thoyts
+#
+#------------------------------------------------------------------------------
+# RCS: @(#) $Id$
+#------------------------------------------------------------------------------
+
+!ifndef _RULES_VC
+_RULES_VC = 1
+
+cc32 = $(CC) # built-in default.
+link32 = link
+lib32 = lib
+rc32 = $(RC) # built-in default.
+
+!ifndef INSTALLDIR
+### Assume the normal default.
+_INSTALLDIR = C:\Program Files\Tcl
+!else
+### Fix the path separators.
+_INSTALLDIR = $(INSTALLDIR:/=\)
+!endif
+
+!ifndef MACHINE
+MACHINE = IX86
+!endif
+
+!ifndef CFG_ENCODING
+CFG_ENCODING = \"cp1252\"
+!endif
+
+#----------------------------------------------------------
+# Set the proper copy method to avoid overwrite questions
+# to the user when copying files and selecting the right
+# "delete all" method.
+#----------------------------------------------------------
+
+!if "$(OS)" == "Windows_NT"
+RMDIR = rmdir /S /Q
+!if ![ver | find "4.0" > nul]
+CPY = echo y | xcopy /i
+!else
+CPY = xcopy /i /y
+!endif
+!else
+CPY = xcopy /i
+RMDIR = deltree /Y
+!endif
+
+
+!message ===============================================================================
+
+#----------------------------------------------------------
+# build the helper app we need to overcome nmake's limiting
+# environment.
+#----------------------------------------------------------
+
+!if !exist(nmakehlp.exe)
+!if [$(cc32) -nologo -ML nmakehlp.c -link -subsystem:console > nul]
+!endif
+!endif
+
+#----------------------------------------------------------
+# Test for compiler features
+#----------------------------------------------------------
+
+### test for optimizations
+!if [nmakehlp -c -Otip]
+!message *** Compiler has 'Optimizations'
+OPTIMIZING = 1
+!else
+!message *** Compiler doesn't have 'Optimizations'
+OPTIMIZING = 0
+!endif
+
+!if "$(MACHINE)" == "IX86"
+### test for pentium errata
+!if [nmakehlp -c -QI0f]
+!message *** Compiler has 'Pentium 0x0f fix'
+PENT_0F_ERRATA = 1
+!else
+!message *** Compiler doesn't have 'Pentium 0x0f fix'
+PENT_0F_ERRATA = 0
+!endif
+### test for -align:4096, when align:512 will do.
+!if [nmakehlp -l -opt:nowin98]
+!message *** Linker has 'Win98 alignment problem'
+ALIGN98_HACK = 1
+!else
+!message *** Linker doesn't have 'Win98 alignment problem'
+ALIGN98_HACK = 0
+!endif
+!else
+PENT_0F_ERRATA = 0
+ALIGN98_HACK = 0
+!endif
+
+!if "$(MACHINE)" == "IA64"
+### test for Itanium errata
+!if [nmakehlp -c -QIA64_Bx]
+!message *** Compiler has 'B-stepping errata workarounds'
+ITAN_B_ERRATA = 1
+!else
+!message *** Compiler doesn't have 'B-stepping errata workarounds'
+ITAN_B_ERRATA = 0
+!endif
+!else
+ITAN_B_ERRATA = 0
+!endif
+
+#----------------------------------------------------------
+# Decode the options requested.
+#----------------------------------------------------------
+
+!if "$(OPTS)" == "" || [nmakehlp -f "$(OPTS)" "none"]
+STATIC_BUILD = 0
+TCL_THREADS = 0
+DEBUG = 0
+PROFILE = 0
+MSVCRT = 0
+LOIMPACT = 0
+TCL_USE_STATIC_PACKAGES = 0
+USE_THREAD_ALLOC = 0
+!else
+!if [nmakehlp -f $(OPTS) "static"]
+!message *** Doing static
+STATIC_BUILD = 1
+!else
+STATIC_BUILD = 0
+!endif
+!if [nmakehlp -f $(OPTS) "msvcrt"]
+!message *** Doing msvcrt
+MSVCRT = 1
+!else
+MSVCRT = 0
+!endif
+!if [nmakehlp -f $(OPTS) "staticpkg"]
+!message *** Doing staticpkg
+TCL_USE_STATIC_PACKAGES = 1
+!else
+TCL_USE_STATIC_PACKAGES = 0
+!endif
+!if [nmakehlp -f $(OPTS) "threads"]
+!message *** Doing threads
+TCL_THREADS = 1
+!else
+TCL_THREADS = 0
+!endif
+!if [nmakehlp -f $(OPTS) "symbols"]
+!message *** Doing symbols
+DEBUG = 1
+!else
+DEBUG = 0
+!endif
+!if [nmakehlp -f $(OPTS) "profile"]
+!message *** Doing profile
+PROFILE = 1
+!else
+PROFILE = 0
+!endif
+!if [nmakehlp -f $(OPTS) "loimpact"]
+!message *** Doing loimpact
+LOIMPACT = 1
+!else
+LOIMPACT = 0
+!endif
+!if [nmakehlp -f $(OPTS) "thrdalloc"]
+!message *** Doing thrdalloc
+USE_THREAD_ALLOC = 1
+!else
+USE_THREAD_ALLOC = 0
+!endif
+!endif
+
+
+!if !$(STATIC_BUILD)
+# Make sure we don't build overly fat DLLs.
+MSVCRT = 1
+# We shouldn't statically put the extensions inside the shell when dynamic.
+TCL_USE_STATIC_PACKAGES = 0
+!endif
+
+
+#----------------------------------------------------------
+# Figure-out how to name our intermediate and output directories.
+# We wouldn't want different builds to use the same .obj files
+# by accident.
+#----------------------------------------------------------
+
+SUFX = tsgx
+
+!if $(DEBUG)
+BUILDDIRTOP = Debug
+DBGX = g
+!else
+BUILDDIRTOP = Release
+DBGX =
+SUFX = $(SUFX:g=)
+!endif
+
+TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX
+
+!if !$(STATIC_BUILD)
+TMP_DIRFULL = $(TMP_DIRFULL:Static=)
+SUFX = $(SUFX:s=)
+EXT = dll
+!if $(MSVCRT)
+TMP_DIRFULL = $(TMP_DIRFULL:X=)
+SUFX = $(SUFX:x=)
+!endif
+!else
+TMP_DIRFULL = $(TMP_DIRFULL:Dynamic=)
+EXT = lib
+!if !$(MSVCRT)
+TMP_DIRFULL = $(TMP_DIRFULL:X=)
+SUFX = $(SUFX:x=)
+!endif
+!endif
+
+!if !$(TCL_THREADS)
+TMP_DIRFULL = $(TMP_DIRFULL:Threaded=)
+SUFX = $(SUFX:t=)
+!endif
+
+!ifndef TMP_DIR
+TMP_DIR = $(TMP_DIRFULL)
+!ifndef OUT_DIR
+OUT_DIR = .\$(BUILDDIRTOP)
+!endif
+!else
+!ifndef OUT_DIR
+OUT_DIR = $(TMP_DIR)
+!endif
+!endif
+
+
+#----------------------------------------------------------
+# Decode the statistics requested.
+#----------------------------------------------------------
+
+!if "$(STATS)" == "" || [nmakehlp -f "$(STATS)" "none"]
+TCL_MEM_DEBUG = 0
+TCL_COMPILE_DEBUG = 0
+!else
+!if [nmakehlp -f $(STATS) "memdbg"]
+!message *** Doing memdbg
+TCL_MEM_DEBUG = 1
+!else
+TCL_MEM_DEBUG = 0
+!endif
+!if [nmakehlp -f $(STATS) "compdbg"]
+!message *** Doing compdbg
+TCL_COMPILE_DEBUG = 1
+!else
+TCL_COMPILE_DEBUG = 0
+!endif
+!endif
+
+
+#----------------------------------------------------------
+# Set our defines now armed with our options.
+#----------------------------------------------------------
+
+OPTDEFINES = -DTCL_CFGVAL_ENCODING=$(CFG_ENCODING)
+
+!if $(TCL_MEM_DEBUG)
+OPTDEFINES = -DTCL_MEM_DEBUG
+!endif
+!if $(TCL_COMPILE_DEBUG)
+OPTDEFINES = $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
+!endif
+!if $(TCL_THREADS)
+OPTDEFINES = $(OPTDEFINES) -DTCL_THREADS=1
+!if $(USE_THREAD_ALLOC)
+OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_ALLOC=1
+!endif
+!endif
+!if $(STATIC_BUILD)
+OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD
+!endif
+
+!if $(DEBUG)
+OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DEBUG
+!elseif $(OPTIMIZING)
+OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_OPTIMIZED
+!endif
+!if $(PROFILE)
+OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_PROFILED
+!endif
+!if "$(MACHINE)" == "IA64"
+OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DO64BIT
+!endif
+
+
+#----------------------------------------------------------
+# Get common info used when building extensions.
+#----------------------------------------------------------
+
+!if "$(PROJECT)" != "tcl"
+
+# If INSTALLDIR set to tcl root dir then reset to the lib dir.
+!if exist("$(_INSTALLDIR)\include\tcl.h")
+_INSTALLDIR=$(_INSTALLDIR)\lib
+!endif
+
+!if !defined(TCLDIR)
+!if exist("$(_INSTALLDIR)\..\include\tcl.h")
+TCLINSTALL = 1
+_TCLDIR = $(_INSTALLDIR)\..
+_TCL_H = $(_INSTALLDIR)\..\include\tcl.h
+TCLDIR = $(_INSTALLDIR)\..
+!else
+MSG=^
+Failed to find tcl.h. Set the TCLDIR macro.
+!error $(MSG)
+!endif
+!else
+_TCLDIR = $(TCLDIR:/=\)
+!if exist("$(_TCLDIR)\include\tcl.h")
+TCLINSTALL = 1
+_TCL_H = $(_TCLDIR)\include\tcl.h
+!elseif exist("$(_TCLDIR)\generic\tcl.h")
+TCLINSTALL = 0
+_TCL_H = $(_TCLDIR)\generic\tcl.h
+!else
+MSG =^
+Failed to find tcl.h. The TCLDIR macro does not appear correct.
+!error $(MSG)
+!endif
+!endif
+
+!if [nmakehlp -v $(_TCL_H) ""] == 0
+!include version.vc
+!else
+TCL_DOTVERSION = 8.5
+TCL_VERSION = $(TCL_DOTVERSION:.=)
+!endif
+
+!if $(TCLINSTALL)
+TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe"
+TCLSTUBLIB = "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib"
+TCLIMPLIB = "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib"
+TCL_LIBRARY = $(_TCLDIR)\lib
+TCL_INCLUDES = -I"$(_TCLDIR)\include"
+!else
+TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX).exe"
+TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib"
+TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib"
+TCL_LIBRARY = $(_TCLDIR)\library
+TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
+!endif
+
+!endif
+
+#----------------------------------------------------------
+# Get Tk info for building extensions.
+#----------------------------------------------------------
+
+!if "$(PROJECT)" != "tcl" && "$(PROJECT)" != "tk"
+
+!if !defined(TKDIR)
+!if exist("$(_INSTALLDIR)\..\include\tk.h")
+TKINSTALL = 1
+_TKDIR = $(_INSTALLDIR)\..
+_TK_H = $(_TKDIR)\include\tk.h
+TKDIR = $(_TKDIR)
+!elseif exist("$(_TCLDIR)\include\tk.h")
+TKINSTALL = 1
+_TKDIR = $(_TCLDIR)
+_TK_H = $(_TKDIR)\include\tk.h
+TKDIR = $(_TKDIR)
+!else
+MSG =^
+Failed to find tk.h. Set the TKDIR macro.
+!error $(MSG)
+!endif
+!else
+_TKDIR = $(TKDIR:/=\)
+!if exist("$(_TKDIR)\include\tk.h")
+TKINSTALL = 1
+_TK_H = $(_TKDIR)\include\tk.h
+!elseif exist("$(_TKDIR)\generic\tk.h")
+TKINSTALL = 0
+_TK_H = $(_TKDIR)\generic\tk.h
+!else
+MSG =^
+Failed to find tk.h. The TKDIR macro does not appear correct.
+!error $(MSG)
+!endif
+!endif
+
+!if [nmakehlp -v $(_TCL_H) $(_TK_H)] == 0
+!include version.vc
+!else
+TK_DOTVERSION = 8.5
+TK_VERSION = $(TK_DOTVERSION:.=)
+!endif
+
+!if $(TKINSTALL)
+WISH = "$(_TKDIR)\bin\wish$(TK_VERSION)$(SUFX).exe"
+TKSTUBLIB = "$(_TKDIR)\lib\tkstub$(TK_VERSION).lib"
+TKIMPLIB = "$(_TKDIR)\lib\tk$(TK_VERSION)$(SUFX).lib"
+TK_INCLUDES = -I"$(_TKDIR)\include"
+!else
+WISH = "$(_TKDIR)\win\$(BUILDDIRTOP)\wish$(TCL_VERSION)$(SUFX).exe"
+TKSTUBLIB = "$(_TKDIR)\win\$(BUILDDIRTOP)\tkstub$(TCL_VERSION).lib"
+TKIMPLIB = "$(_TKDIR)\win\$(BUILDDIRTOP)\tk$(TCL_VERSION)$(SUFX).lib"
+TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib"
+!endif
+
+!endif
+
+
+
+#----------------------------------------------------------
+# Display stats being used.
+#----------------------------------------------------------
+
+!message *** Intermediate directory will be '$(TMP_DIR)'
+!message *** Output directory will be '$(OUT_DIR)'
+!message *** Suffix for binaries will be '$(SUFX)'
+!message *** Optional defines are '$(OPTDEFINES)'
+
+!endif
--- /dev/null
+/* tclstorage.c - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sf.net>
+ *
+ * This file is Tcl extension that adds a 'storage' command to Tcl
+ * and provides access to Microsoft's "Structured Storage" file format.
+ * Structured storages are used extensively to provide persistence for
+ * OLE or COM components. The format presents a filesystem-like
+ * hierarchy of storages and streams that maps well into Tcl's
+ * virtual filesystem model.
+ *
+ * Notable users of structured storages are Microsoft Word and Excel.
+ *
+ * Usage:
+ * storage open filename mode
+ * mode is as per the Tcl open command "[raw]+?"
+ * returns a storage command. The storage will remain open
+ * as long as the command exists. You can close the storage file
+ * using either the close subcommand or renaming the command.
+ * eg: % storage open document.doc r+
+ * stg1
+ *
+ * object commands:
+ * opendir name ?mode? open or create a sub-storage
+ * open name ?mode? open or create a stream as a Tcl channel
+ * close close the storage or sub-storage
+ * stat name varname get information about the named item
+ * commit not used
+ * rename oldname newname rename a stream or sub-storage
+ * remove name deletes a stream or sub-storage + contents
+ * names list all items in the current storage
+ *
+ * ----------------------------------------------------------------------
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * ----------------------------------------------------------------------
+ *
+ * @(#) $Id$
+ */
+
+
+#ifndef PACKAGE_NAME
+#define PACKAGE_NAME "Storage"
+#endif
+#ifndef PACKAGE_VERSION
+#define PACKAGE_VERSION "1.0.0"
+#endif
+
+#define WIN32_LEAN_AND_MEAN
+#define STRICT
+#include <ole2.h>
+#include <tcl.h>
+#include <errno.h>
+#include <time.h>
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLEXPORT
+
+#if _MSC_VER >= 1000
+#pragma comment(lib, "ole32")
+#pragma comment(lib, "advapi32")
+#endif
+
+typedef struct Ensemble {
+ const char *name; /* subcommand name */
+ Tcl_ObjCmdProc *command; /* implementation OR */
+ struct Ensemble *ensemble; /* subcommand ensemble */
+} Ensemble;
+
+typedef struct EnsembleCmdData {
+ struct Ensemble *ensemble;
+ ClientData clientData;
+} EnsembleCmdData;
+
+typedef struct {
+ IStorage *pstg;
+ int mode;
+ Tcl_Obj *children;
+} Storage;
+
+EXTERN int Storage_Init(Tcl_Interp *interp);
+EXTERN int Storage_SafeInit(Tcl_Interp *interp);
+EXTERN Tcl_ObjCmdProc Storage_OpenStorage;
+
+static Tcl_ObjCmdProc TclEnsembleCmd;
+static Tcl_ObjCmdProc StorageCmd;
+static Tcl_CmdDeleteProc StorageCmdDeleteProc;
+static Tcl_ObjCmdProc StorageObjCmd;
+static Tcl_CmdDeleteProc StorageObjDeleteProc;
+static Tcl_ObjCmdProc StorageOpendirCmd;
+static Tcl_ObjCmdProc StorageOpenCmd;
+static Tcl_ObjCmdProc StorageStatCmd;
+static Tcl_ObjCmdProc StorageRenameCmd;
+static Tcl_ObjCmdProc StorageRemoveCmd;
+static Tcl_ObjCmdProc StorageCloseCmd;
+static Tcl_ObjCmdProc StorageCommitCmd;
+static Tcl_ObjCmdProc StorageNamesCmd;
+
+
+static Tcl_Obj *Win32Error(const char * szPrefix, HRESULT hr);
+static long UNIQUEID = 0;
+
+static int GetItemInfo(Tcl_Interp *interp, IStorage *pstg,
+ Tcl_Obj *pathObj, STATSTG *pstatstg);
+static void TimeToFileTime(time_t t, LPFILETIME pft);
+static time_t TimeFromFileTime(const FILETIME *pft);
+
+
+static Tcl_DriverCloseProc StorageChannelClose;
+static Tcl_DriverInputProc StorageChannelInput;
+static Tcl_DriverOutputProc StorageChannelOutput;
+static Tcl_DriverSeekProc StorageChannelSeek;
+static Tcl_DriverWatchProc StorageChannelWatch;
+static Tcl_DriverGetHandleProc StorageChannelGetHandle;
+static Tcl_DriverWideSeekProc StorageChannelWideSeek;
+
+typedef struct {
+ Tcl_Interp *interp;
+ DWORD grfMode;
+ int watchmask;
+ int validmask;
+ IStream *pstm;
+} StorageChannel;
+
+static Tcl_ChannelType StorageChannelType = {
+ "storage",
+ (Tcl_ChannelTypeVersion)TCL_CHANNEL_VERSION_2,
+ StorageChannelClose,
+ StorageChannelInput,
+ StorageChannelOutput,
+ StorageChannelSeek,
+ /* StorageChannelSetOptions */ NULL,
+ /* StorageChannelGetOptions */ NULL,
+ StorageChannelWatch,
+ StorageChannelGetHandle,
+ /* StorageChannelClose2 */ NULL,
+ /* StorageChannelBlockMode */ NULL,
+ /* StorageChannelFlush */ NULL,
+ /* StorageChannelHandler */ NULL,
+ StorageChannelWideSeek
+};
+
+
+static Ensemble StorageEnsemble[] = {
+ { "open", Storage_OpenStorage, 0 },
+ { NULL, 0, 0 }
+};
+
+static Ensemble StorageObjEnsemble[] = {
+ { "opendir", StorageOpendirCmd,0 },
+ { "open", StorageOpenCmd, 0 },
+ { "close", StorageCloseCmd, 0 },
+ { "stat", StorageStatCmd, 0 },
+ { "commit", StorageCommitCmd, 0 },
+ { "rename", StorageRenameCmd, 0 },
+ { "remove", StorageRemoveCmd, 0 },
+ { "names", StorageNamesCmd, 0 },
+ { NULL, 0, 0 }
+};
+
+/* ---------------------------------------------------------------------- */
+
+#define STGM_APPEND 0x00000004 /* unused bit in Win32 enum */
+#define STGM_TRUNC 0x00004000 /* " " */
+#define STGM_WIN32MASK 0xFFFFBFFB /* mask to remove private bits */
+#define STGM_STREAMMASK 0xFFFFAFF8 /* mask off the access, create and
+ append bits */
+
+typedef struct {
+ const char *s;
+ const int posixmode;
+ const DWORD f;
+} stgm_map_t;
+const stgm_map_t stgm_map[] = {
+ { "r", 0x01, STGM_READ },
+ { "r+", 0x05, STGM_READWRITE },
+ { "w", 0x12, STGM_WRITE|STGM_CREATE },
+ { "w+", 0x16, STGM_READWRITE|STGM_CREATE },
+ { "a", 0x02, STGM_WRITE|STGM_APPEND },
+ { "a+", 0x06, STGM_READWRITE|STGM_APPEND },
+ { NULL, 0}
+};
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * GetStorageFlagsFromObj --
+ *
+ * Converts a mode string as documented for the 'open' command
+ * into a set of STGM enumeration flags for use with the
+ * storage implementaiton.
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * The location contained in the flags pointer will have bits set.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+static GetStorageFlagsFromObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr, int *flagsPtr)
+{
+ int index = 0, objc, n, r = TCL_OK;
+ Tcl_Obj **objv;
+
+ r = Tcl_ListObjGetElements(interp, objPtr, &objc, &objv);
+ if (r == TCL_OK) {
+ for (n = 0; n < objc; n++) {
+ r = Tcl_GetIndexFromObjStruct(interp, objv[n],
+ stgm_map, sizeof(stgm_map[0]), "storage flag", 0, &index);
+ if (r == TCL_OK)
+ *flagsPtr |= stgm_map[index].f;
+ }
+ }
+ return r;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Storage_Init --
+ *
+ * Initialize the Storage package.
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * The Storage package is provided.
+ * One new command 'storage' is added to the current interpreter.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+Storage_Init(Tcl_Interp *interp)
+{
+ EnsembleCmdData *dataPtr;
+
+#ifdef USE_TCL_STUBS
+ if (Tcl_InitStubs(interp, "8.2", 0) == NULL) {
+ return TCL_ERROR;
+ }
+#endif
+
+ dataPtr = (EnsembleCmdData *)ckalloc(sizeof(EnsembleCmdData));
+ dataPtr->ensemble = StorageEnsemble;
+ dataPtr->clientData = NULL;
+ Tcl_CreateObjCommand(interp, "storage", TclEnsembleCmd,
+ (ClientData)dataPtr,
+ (Tcl_CmdDeleteProc *)StorageCmdDeleteProc);
+ return Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Storage_SafeInit -
+ *
+ * Initialize the package in a safe interpreter.
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * See Storage_Init.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+Storage_SafeInit(Tcl_Interp *interp)
+{
+ return Storage_Init(interp);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageCmdDeleteProc -
+ *
+ * Clean up the allocated memory associated with the storage command.
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * Memory free'd
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+StorageCmdDeleteProc(ClientData clientData)
+{
+ EnsembleCmdData *data = (EnsembleCmdData *)clientData;
+ ckfree((char *)data);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * CreateStorageCommand -
+ *
+ * Utility function to create a unique Tcl command to represent
+ * a Structured storage instance.
+ *
+ * Results:
+ * A standard Tcl result. The name of the new command is returned
+ * as the interp result.
+ *
+ * Side effects:
+ * A new command is created in the Tcl interpreter.
+ * The command name is added to a list held by the parent storage.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+CreateStorageCommand(Tcl_Interp *interp, Storage *parentPtr,
+ IStorage *pstg, int mode)
+{
+ EnsembleCmdData *dataPtr = NULL;
+ Storage *storagePtr = NULL;
+ Tcl_Obj *nameObj = NULL;
+ char name[3 + TCL_INTEGER_SPACE];
+ long id = InterlockedIncrement(&UNIQUEID);
+
+ _snprintf(name, 3 + TCL_INTEGER_SPACE, "stg%lu", id);
+ nameObj = Tcl_NewStringObj(name, -1);
+
+ dataPtr = (EnsembleCmdData *)ckalloc(sizeof(EnsembleCmdData));
+ storagePtr = (Storage *)ckalloc(sizeof(Storage));
+ storagePtr->mode = mode;
+ storagePtr->pstg = pstg;
+ storagePtr->children = Tcl_NewListObj(0, NULL);
+
+ Tcl_IncrRefCount(storagePtr->children);
+
+ dataPtr->clientData = storagePtr;
+ dataPtr->ensemble = StorageObjEnsemble;
+
+ Tcl_CreateObjCommand(interp, name, TclEnsembleCmd,
+ (ClientData)dataPtr, (Tcl_CmdDeleteProc *)StorageObjDeleteProc);
+
+ if (parentPtr) {
+ Tcl_ListObjAppendElement(interp, parentPtr->children, nameObj);
+ }
+
+ Tcl_SetObjResult(interp, nameObj);
+ return TCL_OK;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Storage_OpenStorage -
+ *
+ * Creates or opens a structured storage file. This will create
+ * a unique command in the Tcl interpreter that can be used to
+ * access the contents of the storage. The file will remain
+ * open with exclusive access until this command is destroyed either
+ * by the use of the close sub-command or by renaming the command
+ * to {}.
+ * The mode string is as per the Tcl open command. If w is specified
+ * the file will be created.
+ *
+ * Results:
+ * A standard Tcl result. The name of the new command is placed in
+ * the interpreters result.
+ *
+ * Side effects:
+ * The named storage is opened exclusively according to the mode
+ * given and a new Tcl command is created.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+Storage_OpenStorage(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ HRESULT hr = S_OK;
+ int r = TCL_OK;
+ int mode = STGM_DIRECT | STGM_SHARE_EXCLUSIVE;
+ IStorage *pstg = NULL;
+
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "filename ?access?");
+ return TCL_ERROR;
+ }
+ if (objc == 4) {
+ r = GetStorageFlagsFromObj(interp, objv[3], &mode);
+ } else {
+ mode |= STGM_READ;
+ }
+
+ if (r == TCL_OK) {
+ if (mode & STGM_CREATE)
+ hr = StgCreateDocfile(Tcl_GetUnicode(objv[2]),
+ mode & STGM_WIN32MASK, 0, &pstg);
+ else
+ hr = StgOpenStorage(Tcl_GetUnicode(objv[2]), NULL,
+ mode & STGM_WIN32MASK, NULL, 0, &pstg);
+
+ if (SUCCEEDED(hr)) {
+ r = CreateStorageCommand(interp, NULL, pstg, mode);
+ } else {
+ Tcl_Obj *errObj = Win32Error("failed to open storage", hr);
+ Tcl_SetObjResult(interp, errObj);
+ r = TCL_ERROR;
+ }
+ }
+ return r;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageObjDeleteProc -
+ *
+ * Callback to handle storage object command deletion.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Allocated resources are free'd and the IStorage pointer is
+ * released which frees COM resources. This also unlocks the
+ * associated file.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+StorageObjDeleteProc(ClientData clientData)
+{
+ EnsembleCmdData *dataPtr = (EnsembleCmdData *)clientData;
+ Storage *storagePtr = (Storage *)dataPtr->clientData;
+
+ if (storagePtr->pstg)
+ storagePtr->pstg->lpVtbl->Release(storagePtr->pstg);
+ Tcl_DecrRefCount(storagePtr->children);
+ ckfree((char *)storagePtr);
+ ckfree((char *)dataPtr);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageCloseCmd -
+ *
+ * Closes the storage instance and deletes the command.
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * See StorageObjDeleteProc
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageCloseCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ Storage *storagePtr = (Storage *)clientData;
+ IStorage *pstg = storagePtr->pstg;
+ int r = TCL_OK;
+
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, "");
+ r = TCL_ERROR;
+ } else {
+ /* We may need to delete all child storages too, because they
+ * will become unusable anyway. Alternatively we could refuse
+ * to close this one because it has children? At the moment
+ * the tcl code in the vfs package does this for us.
+ */
+ Tcl_DeleteCommand(interp, Tcl_GetString(objv[0]));
+ }
+ return r;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageCommitCmd -
+ *
+ * Flush changes to the underlying file.
+ * At the moment we always use STGM_DIRECT. In the future we may
+ * support transacted mode in which case this would do something.
+ * However, for multimegabyte files there is a _significant_
+ * performance hit when using transacted mode - especially during
+ * the commit.
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * None. In the future this may flush unsaved changes to the file.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageCommitCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ Storage *storagePtr = (Storage *)clientData;
+ IStorage *pstg = storagePtr->pstg;
+ HRESULT hr = S_OK;
+ int r = TCL_OK;
+
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, "");
+ r = TCL_ERROR;
+ } else {
+ hr = pstg->lpVtbl->Commit(pstg, 0);
+ if (FAILED(hr)) {
+ Tcl_SetObjResult(interp, Win32Error("commit error", hr));
+ r = TCL_ERROR;
+ }
+ }
+ return r;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageOpendirCmd -
+ *
+ * Opens a sub-storage. A new Tcl command is created to manage the
+ * resource and the mode is as per the Tcl open command. If 'w'
+ * is specified then the sub-storage is created as a child of the
+ * current storage if it is not already present.
+ * Note: Storages may be read-only or write-only or read-write.
+ *
+ * The sub-storage is only usable if all it's parents are still
+ * open. This limitation is part of the COM architecture.
+ * If a parent storage is closed then the only valid command
+ * on its children is a close.
+ *
+ * Results:
+ * A standard Tcl result. The name of the new command is placed
+ * in the interpreter's result.
+ *
+ * Side effects:
+ * A new command is created in the Tcl interpreter and associated
+ * with the sub-storage.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageOpendirCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ Storage *storagePtr = (Storage *)clientData;
+ IStorage *pstg = storagePtr->pstg;
+ IStorage *pstgNew = NULL;
+ HRESULT hr = S_OK;
+ int mode = storagePtr->mode;
+ int r = TCL_OK;
+
+
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "dirname mode");
+ return TCL_ERROR;
+ }
+
+ if (objc == 4) {
+ mode &= STGM_STREAMMASK;
+ r = GetStorageFlagsFromObj(interp, objv[3], &mode);
+ } else {
+ mode &= ~STGM_CREATE;
+ }
+
+ hr = pstg->lpVtbl->OpenStorage(pstg, Tcl_GetUnicode(objv[2]), NULL,
+ (mode & ~STGM_CREATE) & STGM_WIN32MASK, NULL, 0, &pstgNew);
+ if (FAILED(hr)) {
+ if (mode & STGM_CREATE) {
+ hr = pstg->lpVtbl->CreateStorage(pstg, Tcl_GetUnicode(objv[2]),
+ mode & STGM_WIN32MASK, 0, 0, &pstgNew);
+ }
+ if (FAILED(hr)) {
+ Tcl_Obj *errObj = Tcl_NewStringObj("", 0);
+ Tcl_AppendStringsToObj(errObj, "could not ",
+ (mode & STGM_CREATE) ? "create" : "open",
+ " \"", Tcl_GetString(objv[2]), "\"", (char *)NULL);
+ Tcl_AppendObjToObj(errObj, Win32Error("", hr));
+ Tcl_SetObjResult(interp, errObj);
+ r = TCL_ERROR;
+ }
+ }
+ if (SUCCEEDED(hr)) {
+ r = CreateStorageCommand(interp, storagePtr, pstgNew, mode);
+ }
+
+ return r;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageOpenCmd -
+ *
+ * Open a file within the storage. This opens the named item
+ * and creates a Tcl channel to support reading and writing
+ * data. Modes are as per the Tcl 'open' command and may depend upon
+ * the mode settings of the owning storage.
+ *
+ * Results:
+ * A standard Tcl result. The channel name is returned in the Tcl
+ * interpreter result.
+ *
+ * Side effects:
+ * A new stream may be created with the given name.
+ * A Tcl channel is created in the Tcl interpreter.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageOpenCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ Storage *storagePtr = (Storage *)clientData;
+ IStorage *pstg = storagePtr->pstg;
+ IStream *pstm = NULL;
+ int r = TCL_OK;
+ int mode = storagePtr->mode;
+
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "filename mode");
+ return TCL_ERROR;
+ }
+ if (objc == 4) {
+ mode &= STGM_STREAMMASK;
+ r = GetStorageFlagsFromObj(interp, objv[3], &mode);
+ } else {
+ mode &= STGM_STREAMMASK;
+ mode |= STGM_READ;
+ }
+
+ if (r == TCL_OK) {
+
+ HRESULT hr = S_OK;
+ if (mode & STGM_CREATE) {
+ hr = pstg->lpVtbl->CreateStream(pstg, Tcl_GetUnicode(objv[2]),
+ mode & STGM_WIN32MASK, 0, 0, &pstm);
+ } else {
+ hr = pstg->lpVtbl->OpenStream(pstg, Tcl_GetUnicode(objv[2]),
+ NULL, mode & STGM_WIN32MASK, 0, &pstm);
+ if (FAILED(hr) && mode & STGM_APPEND) {
+ hr = pstg->lpVtbl->CreateStream(pstg, Tcl_GetUnicode(objv[2]),
+ mode & STGM_WIN32MASK, 0, 0, &pstm);
+ }
+ }
+
+ if (FAILED(hr)) {
+ Tcl_Obj *errObj = Tcl_NewStringObj("", 0);
+ Tcl_AppendStringsToObj(errObj, "error opening \"",
+ Tcl_GetString(objv[2]), "\"", (char *)NULL);
+ Tcl_AppendObjToObj(errObj, Win32Error("", hr));
+ Tcl_SetObjResult(interp, errObj);
+ r = TCL_ERROR;
+ } else {
+ StorageChannel *inst;
+ char name[3 + TCL_INTEGER_SPACE];
+ Tcl_Channel chan;
+
+ _snprintf(name, 3 + TCL_INTEGER_SPACE, "stm%ld",
+ InterlockedIncrement(&UNIQUEID));
+ inst = (StorageChannel *)ckalloc(sizeof(StorageChannel));
+ inst->pstm = pstm;
+ inst->grfMode = mode;
+ inst->interp = interp;
+ inst->watchmask = 0;
+ /* bit0 set then not readable */
+ inst->validmask = (mode & STGM_WRITE) ? 0 : TCL_READABLE;
+ inst->validmask |= (mode & (STGM_WRITE|STGM_READWRITE))
+ ? TCL_WRITABLE : 0;
+ chan = Tcl_CreateChannel(&StorageChannelType, name,
+ inst, inst->validmask);
+ Tcl_RegisterChannel(interp, chan);
+ if (mode & STGM_APPEND) {
+ Tcl_Seek(chan, 0, SEEK_END);
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1));
+ r = TCL_OK;
+ }
+ }
+ return r;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageStatCmd -
+ *
+ * Fetch information about the named item as per [file stat]
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * The array variable passed in will have a number of values added
+ * or modified.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageStatCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ Storage *storagePtr = (Storage *)clientData;
+ IStorage *pstg = storagePtr->pstg;
+ int r = TCL_OK;
+
+ if (objc != 4) {
+
+ Tcl_WrongNumArgs(interp, 2, objv, "name varName");
+ r = TCL_ERROR;
+
+ } else {
+
+ STATSTG stat;
+ int posixmode = 0;
+ const stgm_map_t *p = NULL;
+
+ if (r == TCL_OK) {
+ r = GetItemInfo(interp, pstg, objv[2], &stat);
+ if (r == TCL_OK) {
+ Tcl_ObjSetVar2(interp, objv[3], Tcl_NewStringObj("type", -1),
+ (stat.type == STGTY_STORAGE)
+ ? Tcl_NewStringObj("directory", -1)
+ : Tcl_NewStringObj("file", -1),
+ 0);
+ Tcl_ObjSetVar2(interp, objv[3], Tcl_NewStringObj("size", -1),
+ Tcl_NewWideIntObj(stat.cbSize.QuadPart), 0);
+ Tcl_ObjSetVar2(interp, objv[3], Tcl_NewStringObj("atime", -1),
+ Tcl_NewLongObj(TimeFromFileTime(&stat.atime)), 0);
+ Tcl_ObjSetVar2(interp, objv[3], Tcl_NewStringObj("mtime", -1),
+ Tcl_NewLongObj(TimeFromFileTime(&stat.mtime)), 0);
+ Tcl_ObjSetVar2(interp, objv[3], Tcl_NewStringObj("ctime", -1),
+ Tcl_NewLongObj(TimeFromFileTime(&stat.ctime)), 0);
+ Tcl_ObjSetVar2(interp, objv[3],
+ Tcl_NewStringObj("gid", -1), Tcl_NewLongObj(0), 0);
+ Tcl_ObjSetVar2(interp, objv[3],
+ Tcl_NewStringObj("uid", -1), Tcl_NewLongObj(0), 0);
+ Tcl_ObjSetVar2(interp, objv[3],
+ Tcl_NewStringObj("ino", -1), Tcl_NewLongObj(0), 0);
+ Tcl_ObjSetVar2(interp, objv[3],
+ Tcl_NewStringObj("dev", -1), Tcl_NewLongObj(0), 0);
+
+ for (p = stgm_map; p->s != NULL; p++) {
+ if ((storagePtr->mode & ~(STGM_STREAMMASK)) == p->f) {
+ posixmode = p->posixmode;
+ break;
+ }
+ }
+ Tcl_ObjSetVar2(interp, objv[3], Tcl_NewStringObj("mode", -1),
+ Tcl_NewLongObj(posixmode), 0);
+
+ if (stat.pwcsName) {
+ CoTaskMemFree(stat.pwcsName);
+ }
+ }
+ }
+ }
+ return r;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageNamesCmd -
+ *
+ * Obtain a list of all item names contained in this storage.
+ *
+ * Results:
+ * A standard Tcl result. The list of names is returned in the
+ * interpreters result.
+ *
+ * Side effects:
+ * None.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageNamesCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ Storage *storagePtr = (Storage *)clientData;
+ IStorage *pstg = storagePtr->pstg;
+ IEnumSTATSTG *penum = NULL;
+ STATSTG stats[12];
+ ULONG count, n, found = 0;
+ int r = TCL_OK;
+
+ if (objc > 2) {
+
+ Tcl_WrongNumArgs(interp, 2, objv, "");
+ r = TCL_ERROR;
+
+ } else {
+
+ HRESULT hr = pstg->lpVtbl->EnumElements(pstg, 0, NULL, 0, &penum);
+ if (FAILED(hr)) {
+ Tcl_SetObjResult(interp, Win32Error("names error", hr));
+ r = TCL_ERROR;
+ } else {
+ Tcl_Obj *listObj = Tcl_NewListObj(0, NULL);
+ while (hr == S_OK) {
+ hr = penum->lpVtbl->Next(penum, 12, stats, &count);
+ for (n = 0; SUCCEEDED(hr) && n < count; n++) {
+ Tcl_ListObjAppendElement(interp, listObj,
+ Tcl_NewUnicodeObj(stats[n].pwcsName, -1));
+ CoTaskMemFree(stats[n].pwcsName);
+ }
+ }
+ penum->lpVtbl->Release(penum);
+ Tcl_SetObjResult(interp, listObj);
+ }
+ }
+ return r;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageRenameCmd -
+ *
+ * Change the name of a storage item.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * The items name is changed or an error is raised.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageRenameCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ Storage *storagePtr = (Storage *)clientData;
+ IStorage *pstg = storagePtr->pstg;
+ int r = TCL_OK;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "oldname newname");
+ r = TCL_ERROR;
+ } else {
+ HRESULT hr = pstg->lpVtbl->RenameElement(pstg,
+ Tcl_GetUnicode(objv[2]), Tcl_GetUnicode(objv[3]));
+ if (FAILED(hr)) {
+ Tcl_Obj *errObj = Tcl_NewStringObj("", 0);
+ Tcl_AppendStringsToObj(errObj, "error renaming \"",
+ Tcl_GetString(objv[2]),
+ "\": no such file or directory", (char *)NULL);
+ Tcl_SetObjResult(interp, errObj);
+ r = TCL_ERROR;
+ }
+ }
+ return r;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageRemoveCmd -
+ *
+ * Removes the item from the storage. If the named item is a
+ * sub-storage then it is removed EVEN IF NOT EMPTY.
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * The named item may be deleted from the storage.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageRemoveCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ Storage *storagePtr = (Storage *)clientData;
+ IStorage *pstg = storagePtr->pstg;
+ int r = TCL_OK;
+
+ if (objc != 3) {
+
+ Tcl_WrongNumArgs(interp, 2, objv, "name");
+ r = TCL_ERROR;
+
+ } else {
+
+ HRESULT hr = pstg->lpVtbl->DestroyElement(pstg,
+ Tcl_GetUnicode(objv[2]));
+ if (FAILED(hr) && hr != STG_E_FILENOTFOUND) {
+ Tcl_Obj *errObj = Tcl_NewStringObj("", 0);
+ Tcl_AppendStringsToObj(errObj, "error removing \"",
+ Tcl_GetString(objv[2]), "\"", (char *)NULL);
+ Tcl_AppendObjToObj(errObj, Win32Error("", hr));
+ Tcl_SetObjResult(interp, errObj);
+ r = TCL_ERROR;
+ }
+ }
+ return r;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageChannelClose -
+ *
+ * Called by the Tcl channel layer to close the channel.
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * Closes the stream and releases allocated resources.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageChannelClose(ClientData instanceData, Tcl_Interp *interp)
+{
+ StorageChannel *chan = (StorageChannel *)instanceData;
+
+ if (chan->pstm)
+ chan->pstm->lpVtbl->Release(chan->pstm);
+ ckfree((char *)chan);
+
+ return TCL_OK;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageChannelInput -
+ *
+ * Called by the Tcl channel layer to read data from the channel
+ *
+ * Results:
+ * The number of bytes read or -1 on error.
+ *
+ * Side effects:
+ * Copies bytes from the stream into the buffer.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageChannelInput(ClientData instanceData,
+ char *buffer, int toRead, int *errorCodePtr)
+{
+ StorageChannel *chan = (StorageChannel *)instanceData;
+ int cb = 0;
+
+ if (chan->pstm) {
+ HRESULT hr = chan->pstm->lpVtbl->Read(chan->pstm, buffer, toRead, &cb);
+ if (FAILED(hr)) {
+ cb = -1;
+ *errorCodePtr = EINVAL;
+ }
+ }
+
+ return cb;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageChannelOutput -
+ *
+ * Called by the Tcl channel layer to write data to the channel.
+ *
+ * Results:
+ * The number of bytes written or -1 on error.
+ *
+ * Side effects:
+ * Copies bytes from the buffer into the stream.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageChannelOutput(ClientData instanceData,
+ CONST84 char *buffer, int toWrite, int *errorCodePtr)
+{
+ StorageChannel *chan = (StorageChannel *)instanceData;
+ int cb = 0;
+
+ if (chan->pstm) {
+ HRESULT hr = chan->pstm->lpVtbl->Write(chan->pstm, buffer,
+ toWrite, &cb);
+ if (FAILED(hr)) {
+ cb = -1;
+ *errorCodePtr = EINVAL;
+ }
+ }
+
+ return cb;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageChannelSeek -
+ *
+ * Called by the Tcl channel layer to change the stream position.
+ *
+ * Results:
+ * The new seek position.
+ *
+ * Side effects:
+ * Moves the stream position.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageChannelSeek(ClientData instanceData,
+ long offset, int mode, int *errorCodePtr)
+{
+ return Tcl_WideAsLong(StorageChannelWideSeek(instanceData,
+ Tcl_LongAsWide(offset), mode, errorCodePtr));
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageChannelWideSeek -
+ *
+ * Wide version of the seek operation.
+ *
+ * Results:
+ * The new seek position as a wide value.
+ *
+ * Side effects:
+ * Moves the seek position.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_WideInt
+StorageChannelWideSeek(ClientData instanceData, Tcl_WideInt offset,
+ int seekMode, int *errorCodePtr)
+{
+ StorageChannel *chan = (StorageChannel *)instanceData;
+ HRESULT hr = S_OK;
+ int cb = 0;
+ LARGE_INTEGER li;
+ ULARGE_INTEGER uli;
+
+ li.QuadPart = offset;
+ uli.QuadPart = 0;
+ if (chan->pstm) {
+ DWORD grfMode = STREAM_SEEK_SET;
+ if (seekMode == SEEK_END)
+ grfMode = STREAM_SEEK_END;
+ else if (seekMode == SEEK_CUR)
+ grfMode = STREAM_SEEK_CUR;
+ hr = chan->pstm->lpVtbl->Seek(chan->pstm, li, grfMode, &uli);
+ if (FAILED(hr)) {
+ *errorCodePtr = EINVAL;
+ } else {
+ *errorCodePtr = (int)hr;
+ }
+ }
+ return uli.QuadPart;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageChannelWatch -
+ *
+ * Called by the Tcl channel layer to check that we are ready for
+ * file events. We are.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Will cause the notifier to poll.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+StorageChannelWatch(ClientData instanceData, int mask)
+{
+ StorageChannel *chan = (StorageChannel *)instanceData;
+ Tcl_Time blockTime = { 0, 0 };
+
+ /* Set the block time to zero - we are always ready for events. */
+ chan->watchmask = mask & chan->validmask;
+ if (chan->watchmask) {
+ Tcl_SetMaxBlockTime(&blockTime);
+ }
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * StorageChannelGetHandle -
+ *
+ * Provides a properly COM AddRef'd interface pointer to the
+ * underlying IStream. The caller is responsible for Release'ing
+ * this (normal COM rules).
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * An extra reference to the stream is returned to the called.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+StorageChannelGetHandle(ClientData instanceData,
+ int direction, ClientData *handlePtr)
+{
+ StorageChannel *chan = (StorageChannel *)instanceData;
+ HRESULT hr = chan->pstm->lpVtbl->QueryInterface(chan->pstm,
+ &IID_IStream, handlePtr);
+ return SUCCEEDED(hr) ? TCL_OK : TCL_ERROR;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclEnsembleCmd -
+ *
+ * A general purpose ensemble command implementation. This
+ * lets us define a command in terms of it's sub-commands as
+ * a structure.
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * A sub-command will be called - anything may happen.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+TclEnsembleCmd(ClientData clientData, Tcl_Interp *interp,
+ int objc, Tcl_Obj *const objv[])
+{
+ EnsembleCmdData *data = (EnsembleCmdData *)clientData;
+ Ensemble *ensemble = data->ensemble;
+ int option = 1;
+ int index;
+ while (option < objc) {
+ if (Tcl_GetIndexFromObjStruct(interp, objv[option], ensemble,
+ sizeof(ensemble[0]), "command", 0, &index)
+ != TCL_OK)
+ {
+ return TCL_ERROR;
+ }
+ if (ensemble[index].command) {
+ return ensemble[index].command(data->clientData,
+ interp, objc, objv);
+ }
+ ensemble = ensemble[index].ensemble;
+ option++;
+ }
+ Tcl_WrongNumArgs(interp, option, objv, "option ?arg arg ...?");
+ return TCL_ERROR;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * GetItemInfo -
+ *
+ * Iterate over the items in the storage and return the
+ * STATSTG structure for the matching item or generate
+ * a suitable Tcl error message.
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * None.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+GetItemInfo(Tcl_Interp *interp, IStorage *pstg,
+ Tcl_Obj *pathObj, STATSTG *pstatstg)
+{
+ IEnumSTATSTG *penum = NULL;
+ STATSTG stats[12];
+ ULONG count, n, objc, found = 0, r = TCL_OK;
+ Tcl_Obj **objv;
+ HRESULT hr = S_OK;
+
+ r = Tcl_ListObjGetElements(interp, pathObj, &objc, &objv);
+ if (r == TCL_OK) {
+ if (objc < 1) {
+ hr = pstg->lpVtbl->Stat(pstg, pstatstg, STATFLAG_DEFAULT);
+ found = 1;
+ } else {
+ LPCOLESTR pwcsName = Tcl_GetUnicode(objv[objc-1]);
+ hr = pstg->lpVtbl->EnumElements(pstg, 0, NULL, 0, &penum);
+ while (hr == S_OK) {
+ hr = penum->lpVtbl->Next(penum, 12, stats, &count);
+ for (n = 0; SUCCEEDED(hr) && n < count; n++) {
+ if (!found && wcscmp(pwcsName, stats[n].pwcsName) == 0) {
+ /* we must finish the loop to cleanup the strings */
+ found = 1;
+ CopyMemory(pstatstg, &stats[n], sizeof(STATSTG));
+ hr = S_FALSE; /* avoid any additional calls to Next */
+ } else {
+ CoTaskMemFree(stats[n].pwcsName);
+ }
+ }
+ }
+ }
+ if (penum)
+ penum->lpVtbl->Release(penum);
+ if (!found) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("file does not exist", -1));
+ r = TCL_ERROR;
+ }
+ }
+ return r;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * Win32Error -
+ *
+ * Convert COM errors into Tcl string objects.
+ *
+ * Results:
+ * A tcl string object
+ *
+ * Side effects:
+ * None.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+Win32Error(const char * szPrefix, HRESULT hr)
+{
+ Tcl_Obj *msgObj = NULL;
+ char * lpBuffer = NULL;
+ DWORD dwLen = 0;
+
+ /* deal with a few known values */
+ switch (hr) {
+ case STG_E_FILENOTFOUND:
+ return Tcl_NewStringObj(": file not found", -1);
+ case STG_E_ACCESSDENIED:
+ return Tcl_NewStringObj(": permission denied", -1);
+ }
+
+ dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
+ | FORMAT_MESSAGE_FROM_SYSTEM,
+ NULL, (DWORD)hr, LANG_NEUTRAL,
+ (LPTSTR)&lpBuffer, 0, NULL);
+ if (dwLen < 1) {
+ dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER
+ | FORMAT_MESSAGE_FROM_STRING
+ | FORMAT_MESSAGE_ARGUMENT_ARRAY,
+ "code 0x%1!08X!%n", 0, LANG_NEUTRAL,
+ (LPTSTR)&lpBuffer, 0, (va_list *)&hr);
+ }
+
+ msgObj = Tcl_NewStringObj(szPrefix, -1);
+ if (dwLen > 0) {
+ char *p = lpBuffer + dwLen - 1; /* remove cr-lf at end */
+ for ( ; p && *p && isspace(*p); p--)
+ ;
+ *++p = 0;
+ Tcl_AppendToObj(msgObj, ": ", 2);
+ Tcl_AppendToObj(msgObj, lpBuffer, -1);
+ }
+ LocalFree((HLOCAL)lpBuffer);
+ return msgObj;
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TimeToFileTime -
+ *
+ * Convert a time_t value into Win32 FILETIME.
+ *
+ * Results:
+ * The filetime value is modified.
+ *
+ * Side effects:
+ * None.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+TimeToFileTime(time_t t, LPFILETIME pft)
+{
+ LONGLONG t64 = Int32x32To64(t, 10000000) + 116444736000000000;
+ pft->dwLowDateTime = (DWORD)(t64);
+ pft->dwHighDateTime = (DWORD)(t64 >> 32);
+}
+\f
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TimeFromFileTime
+ *
+ * Convert a FILETIME value into a localtime time_t value.
+ *
+ * Results:
+ * The localtime in unix epoch seconds.
+ *
+ * Side effects:
+ * None.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static time_t
+TimeFromFileTime(const FILETIME *pft)
+{
+ LONGLONG t64 = pft->dwHighDateTime;
+ t64 <<= 32;
+ t64 |= pft->dwLowDateTime;
+ t64 -= 116444736000000000;
+ return (time_t)(t64 / 10000000);
+}
+\f
+/* ----------------------------------------------------------------------
+ *
+ * Local variables:
+ * mode: c
+ * indent-tabs-mode: nil
+ * End:
+ */
--- /dev/null
+// tclstorage.rc - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sf.net>
+//
+// $Id$
+
+#include <winver.h>
+
+VS_VERSION_INFO VERSIONINFO
+ FILEVERSION COMMAVERSION
+ PRODUCTVERSION COMMAVERSION
+ FILEFLAGSMASK 0x3fL
+#ifdef DEBUG
+ FILEFLAGS 0x0L
+#else
+ FILEFLAGS 0x0L
+#endif
+ FILEOS 0x4L
+ FILETYPE 0x1L
+ FILESUBTYPE 0x0L
+BEGIN
+ BLOCK "StringFileInfo"
+ BEGIN
+ BLOCK "040904b0"
+ BEGIN
+ VALUE "FileDescription", "Tcl structured storage extension.\0"
+ VALUE "OriginalFilename", "tclstorage" VERSION ".dll\0"
+ VALUE "CompanyName", "Patrick Thoyts\0"
+ VALUE "FileVersion", DOTVERSION "\0"
+ VALUE "LegalCopyright", "Copyright \251 2003 Patrick Thoyts\0"
+ VALUE "ProductName", "Tcl storage extension\0"
+ VALUE "ProductVersion", DOTVERSION "\0"
+ END
+ END
+ BLOCK "VarFileInfo"
+ BEGIN
+ VALUE "Translation", 0x409, 1200
+ END
+END
--- /dev/null
+# all.tcl --
+#
+# This file contains a top-level script to run all of the Tcl
+# tests. Execute it by invoking "source all.test" when running tcltest
+# in this directory.
+#
+# Copyright (c) 1998-2000 by Scriptics Corporation.
+# All rights reserved.
+#
+# RCS: @(#) $Id$
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import ::tcltest::*
+}
+
+set ::tcltest::testSingleFile false
+set ::tcltest::testsDirectory [file dir [info script]]
+
+# We need to ensure that the testsDirectory is absolute
+if {[catch {::tcltest::normalizePath ::tcltest::testsDirectory}]} {
+ # The version of tcltest we have here does not support
+ # 'normalizePath', so we have to do this on our own.
+
+ set oldpwd [pwd]
+ catch {cd $::tcltest::testsDirectory}
+ set ::tcltest::testsDirectory [pwd]
+ cd $oldpwd
+}
+
+set chan $::tcltest::outputChannel
+
+puts $chan "Tests running in interp: [info nameofexecutable]"
+puts $chan "Tests running with pwd: [pwd]"
+puts $chan "Tests running in working dir: $::tcltest::testsDirectory"
+if {[llength $::tcltest::skip] > 0} {
+ puts $chan "Skipping tests that match: $::tcltest::skip"
+}
+if {[llength $::tcltest::match] > 0} {
+ puts $chan "Only running tests that match: $::tcltest::match"
+}
+
+if {[llength $::tcltest::skipFiles] > 0} {
+ puts $chan "Skipping test files that match: $::tcltest::skipFiles"
+}
+if {[llength $::tcltest::matchFiles] > 0} {
+ puts $chan "Only sourcing test files that match: $::tcltest::matchFiles"
+}
+
+set timeCmd {clock format [clock seconds]}
+puts $chan "Tests began at [eval $timeCmd]"
+
+# source each of the specified tests
+foreach file [lsort [::tcltest::getMatchingFiles]] {
+ set tail [file tail $file]
+ puts $chan $tail
+ if {[catch {source $file} msg]} {
+ puts $chan $msg
+ }
+}
+
+# cleanup
+puts $chan "\nTests ended at [eval $timeCmd]"
+::tcltest::cleanupTests 1
+return
+
--- /dev/null
+# tclstorage.test: tests for the tclstorage package -*- tcl -*-
+#
+# $Id$
+
+# -------------------------------------------------------------------------
+# Initialize the test package
+#
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import ::tcltest::*
+}
+
+package require Storage
+
+# -------------------------------------------------------------------------
+# Setup any constraints
+#
+
+# -------------------------------------------------------------------------
+# Now the package specific tests....
+# -------------------------------------------------------------------------
+
+puts "- Storage [package present Storage]"
+
+# -------------------------------------------------------------------------
+
+test storage-1.0 {create storage} \
+ -body {
+ list [catch {
+ set stg [storage open xyzzy.stg w]
+ set result [list [string match "stg*" $stg] \
+ [file exists xyzzy.stg]]
+ $stg close
+ set result
+ } msg] $msg
+ } \
+ -cleanup {
+ file delete -force xyzzy.stg
+ } \
+ -result {0 {1 1}}
+
+test storage-1.1 {open storage} \
+ -setup {
+ set stg [storage open xyzzy.stg w]
+ $stg close
+ } \
+ -body {
+ list [catch {
+ set stg [storage open xyzzy.stg r]
+ set result [list [string match "stg*" $stg] \
+ [file exists xyzzy.stg]]
+ $stg close
+ set result
+ } msg] $msg
+ } \
+ -cleanup {
+ file delete -force xyzzy.stg
+ } \
+ -result {0 {1 1}}
+
+test storage-1.2 {create stream} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test w+]
+ set result [fconfigure $stm]
+ close $stm
+ string match stm* $stm
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result {0 1}
+
+test storage-1.3 {create stream and write data} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test w+]
+ puts $stm "Hello, world"
+ close $stm
+ string match "stm*" $stm
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result {0 1}
+
+test storage-1.4 {create stream and write and read} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w+]
+ puts -nonewline $stm "Hello, world"
+ close $stm
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test r]
+ set data [read $stm]
+ close $stm
+ set data
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result {0 {Hello, world}}
+
+test storage-1.5 {open non-existent stream} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test r]
+ close $stm
+ string match "stm*" $stm
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result {1 {error opening "test": file not found}}
+
+test storage-1.6 {write on read-only stream} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w]
+ puts -nonewline $stm "testdata"
+ close $stm
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test r]
+ puts -nonewline $stm "moredata"
+ close $stm
+ string match "stm*" $stm
+ } msg] [regsub {stm\d+} $msg {STM}]
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 1 "channel \"STM\" wasn't opened for writing"]
+
+test storage-1.7 {read from write-only stream} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test w]
+ set d [read $stm]
+ close $stm
+ string match "stm*" $stm
+ } msg] [regsub {stm\d+} $msg {STM}]
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 1 "channel \"STM\" wasn't opened for reading"]
+
+test storage-1.8 {append to stream} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w]
+ puts -nonewline $stm ABCDE
+ close $stm
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test a]
+ puts -nonewline $stm FGH
+ close $stm
+ set stm [$stg open test r]
+ set data [read $stm]
+ close $stm
+ set data
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 ABCDEFGH]
+
+test storage-1.9 {append to readable stream} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w]
+ puts -nonewline $stm ABCDE
+ close $stm
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test a+]
+ puts -nonewline $stm FGH
+ set data [read $stm]
+ close $stm
+ set data
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 {}]
+
+test storage-2.0 {seek to start} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w]
+ puts -nonewline $stm ABCDEFGH
+ close $stm
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test a+]
+ seek $stm 0
+ set data [read $stm]
+ close $stm
+ set data
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 ABCDEFGH]
+
+test storage-2.1 {seek to start + 5} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w]
+ puts -nonewline $stm ABCDEFGH
+ close $stm
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test a+]
+ seek $stm 5 start
+ set data [read $stm]
+ close $stm
+ set data
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 FGH]
+
+test storage-2.1 {seek to end - 1} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w]
+ puts -nonewline $stm ABCDEFGH
+ close $stm
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test r]
+ seek $stm -2 end
+ set data [read $stm]
+ close $stm
+ set data
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 GH]
+
+test storage-2.2 {seek to current + 2} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w]
+ puts -nonewline $stm ABCDEFGH
+ close $stm
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test r]
+ read $stm 2
+ seek $stm 2 cur
+ set data [read $stm]
+ close $stm
+ set data
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 EFGH]
+
+test storage-2.3 {seek to current - 2} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w]
+ puts -nonewline $stm ABCDEFGH
+ close $stm
+ } \
+ -body {
+ list [catch {
+ set stm [$stg open test r]
+ read $stm 5
+ seek $stm -2 cur
+ set data [read $stm]
+ close $stm
+ set data
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 DEFGH]
+
+test storage-3.0 {list storage contents} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ foreach name {one two three} {
+ set stm [$stg open $name w]
+ puts -nonewline $stm ABCDEFGH
+ close $stm
+ }
+ } \
+ -body {
+ list [catch {
+ $stg names
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 [list one two three]]
+
+test storage-3.1 {create substorage} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ } \
+ -body {
+ list [catch {
+ set sub [$stg opendir subdir w]
+ $sub close
+ $stg names
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 [list subdir]]
+
+test storage-3.2 {create sub-sub-storage} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set sub [$stg opendir subdir w+]
+ } \
+ -body {
+ list [catch {
+ set subsub [$sub opendir subsubdir w]
+ $subsub close
+ $sub names
+ } msg] $msg
+ } \
+ -cleanup {
+ $sub close
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 [list subsubdir]]
+
+test storage-3.3 {create substorage files} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set sub [$stg opendir subdir w+]
+ } \
+ -body {
+ list [catch {
+ set stm [$sub open test w+]
+ puts -nonewline $stm ABCDEFG
+ flush $stm
+ seek $stm 0
+ set d [read $stm]
+ close $stm
+ list [$sub names] $d
+ } msg] $msg
+ } \
+ -cleanup {
+ $sub close
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 [list test ABCDEFG]]
+
+test storage-3.4 {delete file} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w]
+ puts -nonewline $stm ABCDEF
+ close $stm
+ } \
+ -body {
+ list [catch {
+ set result [$stg names]
+ $stg remove test
+ lappend result [$stg names]
+ set result
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 [list test {}]]
+
+test storage-3.5 {rename file} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w]
+ puts -nonewline $stm ABCDEF
+ close $stm
+ } \
+ -body {
+ list [catch {
+ set result [$stg names]
+ $stg rename test renamed
+ lappend result [$stg names]
+ set result
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 [list test renamed]]
+
+test storage-3.6 {stat file} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w]
+ puts -nonewline $stm ABCDEF
+ close $stm
+ } \
+ -body {
+ list [catch {
+ $stg stat test a
+ list $a(type) $a(size)
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 [list file 6]]
+
+test storage-3.7 {stat file: timestamps} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set stm [$stg open test w]
+ puts -nonewline $stm ABCDEF
+ close $stm
+ } \
+ -body {
+ list [catch {
+ file stat xyzzy.stg s
+ $stg stat test a
+ if {$s(ctime) == $a(ctime)} {
+ list 1
+ } else {
+ list $s(ctime) != $a(ctime)
+ }
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 [list 1]]
+
+test storage-3.8 {open sub-storage for reading} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set sub [$stg opendir subdir w+]
+ set stm [$sub open test w]
+ close $stm
+ $sub close
+ } \
+ -body {
+ list [catch {
+ set sub [$stg opendir subdir r]
+ set result [$sub names]
+ $sub close
+ set result
+ } msg] $msg
+ } \
+ -cleanup {
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result [list 0 [list test]]
+
+test storage-3.9 {open sub-storage for reading - fail write} \
+ -setup {
+ set stg [storage open xyzzy.stg w+]
+ set sub [$stg opendir subdir w]
+ $sub close
+ set sub [$stg opendir subdir r]
+ } \
+ -body {
+ list [catch {
+ set stm [$sub open test w]
+ close $stm
+ $sub names
+ } msg] $msg
+ } \
+ -cleanup {
+ $sub close
+ $stg close
+ file delete -force xyzzy.stg
+ } \
+ -result {1 {error opening "test": permission denied}}
+
+# -------------------------------------------------------------------------
+
+::tcltest::cleanupTests
+
+# -------------------------------------------------------------------------
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:
projects / tclstorage / commitdiff