From c56caa8fe77cffd8f2c8235d62a892101333e789 Mon Sep 17 00:00:00 2001 From: Pat Thoyts Date: Fri, 8 Apr 2005 20:08:57 +0000 Subject: [PATCH 1/1] Initial checkin of version 1. --- Announce | 31 + doc/manpage.css | 218 +++++++ doc/stgvfs.man | 41 ++ doc/tclstorage.man | 121 ++++ library/stgvfs.tcl | 228 +++++++ makefile.vc | 438 +++++++++++++ nmakehlp.c | 355 +++++++++++ rules.vc | 436 +++++++++++++ tclstorage.c | 1364 +++++++++++++++++++++++++++++++++++++++++ tclstorage.rc | 37 ++ tests/all.tcl | 66 ++ tests/tclstorage.test | 547 +++++++++++++++++ 12 files changed, 3882 insertions(+) create mode 100644 Announce create mode 100644 doc/manpage.css create mode 100644 doc/stgvfs.man create mode 100644 doc/tclstorage.man create mode 100644 library/stgvfs.tcl create mode 100644 makefile.vc create mode 100644 nmakehlp.c create mode 100644 rules.vc create mode 100644 tclstorage.c create mode 100644 tclstorage.rc create mode 100644 tests/all.tcl create mode 100644 tests/tclstorage.test diff --git a/Announce b/Announce new file mode 100644 index 0000000..40d805a --- /dev/null +++ b/Announce @@ -0,0 +1,31 @@ +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 + diff --git a/doc/manpage.css b/doc/manpage.css new file mode 100644 index 0000000..8a4cfbd --- /dev/null +++ b/doc/manpage.css @@ -0,0 +1,218 @@ +/* + * $Id$ + * Author: Joe English, + * 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 */ diff --git a/doc/stgvfs.man b/doc/stgvfs.man new file mode 100644 index 0000000..798da15 --- /dev/null +++ b/doc/stgvfs.man @@ -0,0 +1,41 @@ +[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] diff --git a/doc/tclstorage.man b/doc/tclstorage.man new file mode 100644 index 0000000..2b2a0dc --- /dev/null +++ b/doc/tclstorage.man @@ -0,0 +1,121 @@ +[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] diff --git a/library/stgvfs.tcl b/library/stgvfs.tcl new file mode 100644 index 0000000..37a0ed2 --- /dev/null +++ b/library/stgvfs.tcl @@ -0,0 +1,228 @@ +# stgvfs.tcl - Copyright (C) 2004 Pat Thoyts +# +# +# + +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: diff --git a/makefile.vc b/makefile.vc new file mode 100644 index 0000000..f2f6283 --- /dev/null +++ b/makefile.vc @@ -0,0 +1,438 @@ +# 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. +# -- 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= +# 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= +# OUT_DIR= +# 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)\ by default. +# +# TESTPAT= +# 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 {} $$d {}] +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 diff --git a/nmakehlp.c b/nmakehlp.c new file mode 100644 index 0000000..30f81bf --- /dev/null +++ b/nmakehlp.c @@ -0,0 +1,355 @@ +/* ---------------------------------------------------------------------------- + * 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 +#include +#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 \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 \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 \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 \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; +} diff --git a/rules.vc b/rules.vc new file mode 100644 index 0000000..ba4b828 --- /dev/null +++ b/rules.vc @@ -0,0 +1,436 @@ +#------------------------------------------------------------------------------ +# 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 diff --git a/tclstorage.c b/tclstorage.c new file mode 100644 index 0000000..0402088 --- /dev/null +++ b/tclstorage.c @@ -0,0 +1,1364 @@ +/* tclstorage.c - Copyright (C) 2004 Pat Thoyts + * + * 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 +#include +#include +#include + +#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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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); +} + +/* + * ---------------------------------------------------------------------- + * + * 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); +} + +/* + * ---------------------------------------------------------------------- + * + * 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); +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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); +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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)); +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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); + } +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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; +} + +/* + * ---------------------------------------------------------------------- + * + * 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); +} + +/* + * ---------------------------------------------------------------------- + * + * 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); +} + +/* ---------------------------------------------------------------------- + * + * Local variables: + * mode: c + * indent-tabs-mode: nil + * End: + */ diff --git a/tclstorage.rc b/tclstorage.rc new file mode 100644 index 0000000..7d637f3 --- /dev/null +++ b/tclstorage.rc @@ -0,0 +1,37 @@ +// tclstorage.rc - Copyright (C) 2004 Pat Thoyts +// +// $Id$ + +#include + +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 diff --git a/tests/all.tcl b/tests/all.tcl new file mode 100644 index 0000000..b415887 --- /dev/null +++ b/tests/all.tcl @@ -0,0 +1,66 @@ +# 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 + diff --git a/tests/tclstorage.test b/tests/tclstorage.test new file mode 100644 index 0000000..4804c6d --- /dev/null +++ b/tests/tclstorage.test @@ -0,0 +1,547 @@ +# 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: -- 2.23.0