From: Pat Thoyts Date: Tue, 27 Jan 2009 21:06:50 +0000 (+0000) Subject: Various code cleanups and incremented version to 1.2.0 X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=53ef080624f6edcc8106dc7da306651767b92958;p=tclstorage Various code cleanups and incremented version to 1.2.0 --- diff --git a/Announce b/Announce index 55f82f4..f70d61c 100644 --- a/Announce +++ b/Announce @@ -42,7 +42,7 @@ Usage: ChangeLog: - 1.1.0+ Support creation of memory storages by providing an empty filename. + 1.2.0: Support creation of memory storages by providing an empty filename. 1.1.0: Added support for SummaryInformation and DocumentSummaryInformation property sets. Read and write properties and list them. diff --git a/doc/tclstorage.man b/doc/tclstorage.man index 382ba60..d05cec9 100644 --- a/doc/tclstorage.man +++ b/doc/tclstorage.man @@ -4,7 +4,7 @@ [moddesc {tclstorage}] [titledesc {Structured storage access tcl extension}] [require Tcl 8.2] -[require Storage [opt 1.1.0]] +[require Storage [opt 1.2.0]] [description] [para] @@ -102,6 +102,50 @@ sub-storage then it is removed [strong "even if not empty"]. 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. +[call "\$stg [cmd {propertyset open}] [arg name] [opt [arg mode]]"] + +Open a named property set. This returns a new Tcl command that permits +examination and manipulation of the propertyset items. +See [sectref {PROPERTYSET COMMANDS}]. +[nl] +[arg mode] is as per the Tcl [cmd open] command modes. + +[call "\$stg [cmd {propertyset delete}] [arg name]"] + +Delete the given propertyset. + +[call "\$stg [cmd {propertyset names}]"] + +List all the available property sets in this storage. + +[list_end] + +[section "PROPERTYSET COMMANDS"] + +[list_begin definitions] + +[call "\$propset [cmd names]"] + +Returns a list of all property names and types. + +[call "\$propset [cmd get] [arg propid]"] + +Returns the value of the given property. + +[call "\$propset [cmd set] [arg propid] [arg value] [opt [arg type]]"] + +Modify the value and optionally the type of the given property. + +[call "\$propset [cmd delete] [arg propid]"] + +Remove a property from the propertyset. + +[call "\$propset [cmd close]"] + +Closes the property set. The Tcl command is deleted and the COM +instance released. This must be done before the parent storage is +closed or any changes could be lost. + [list_end] [example { diff --git a/library/stgvfs.tcl b/library/stgvfs.tcl index 37a0ed2..ae32e83 100644 --- a/library/stgvfs.tcl +++ b/library/stgvfs.tcl @@ -1,6 +1,11 @@ # stgvfs.tcl - Copyright (C) 2004 Pat Thoyts # -# +# This maps an OLE Structured Storage into a Tcl virtual filesystem +# You can mount a DOC file (word or excel or any other such compound +# document) and then treat it as a filesystem. All sub-storages are +# presented as directories and all streams as files and can be opened +# as tcl channels. +# This vfs does not provide access to the property sets. # package require vfs 1; # tclvfs @@ -18,11 +23,12 @@ namespace eval ::vfs::stg { proc ::vfs::stg::Mount {path local} { variable uid - set stg [::storage open [::file normalize $path] r+] + set mode r+ + if {$path eq {}} { set mode w+ } + set stg [::storage open [::file normalize $path] $mode] set token [namespace current]::mount[incr uid] - variable $token - upvar \#0 $token state + upvar #0 $token state catch {unset state} set state(/stg) $stg set state(/root) $path @@ -34,9 +40,7 @@ proc ::vfs::stg::Mount {path local} { } proc ::vfs::stg::Unmount {token local} { - variable $token - upvar \#0 $token state - + upvar #0 $token state foreach path [array get state] { if {![string match "/*" $path]} { catch {$state($path) close} @@ -68,10 +72,16 @@ proc ::vfs::stg::handler {token cmd root relative actualpath args} { # Returns the final storage item in the path. # - path proc ::vfs::stg::PathToStg {token path} { - variable $token - upvar \#0 $token state + upvar #0 $token state set stg $state(/stg) - if {[string equal $path "."]} {return $stg} + if {[string equal $path "."]} { return $stg } + if {[info exists state($path)]} { + return $state($path) + } + if {[info exists state([file dirname $path])]} { + return $state([file dirname $path]) + } + set elements [file split $path] set path {} foreach dir $elements { @@ -92,30 +102,30 @@ proc ::vfs::stg::PathToStg {token path} { # The vfs handler procedures # ------------------------------------------------------------------------- -proc vfs::stg::access {token name mode} { - ::vfs::log "access: $token $name $mode" +proc vfs::stg::access {token path mode} { + ::vfs::log "access: $token $path $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) + if {[catch { + if {[string length $path] < 1} { return } + set stg [PathToStg $token [file dirname $path]] + ::vfs::log "access: check [file tail $path] within $stg" + if {[catch {$stg stat [file tail $path] sd} err]} { + ::vfs::log "access: error: $err" + ::vfs::filesystem posixerror $::vfs::posix(ENOENT) + } else { + if {($mode & 2) && !($sd(mode) & 2)} { + ::vfs::filesystem posixerror $::vfs::posix(EACCES) + } } - } + } err]} { ::vfs::log "access: error: $err" } return } proc vfs::stg::createdirectory {token path} { - ::vfs::log "createdirectory: $token $path" + ::vfs::log "createdirectory: $token \"$path\"" + upvar #0 $token state 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"] + set state($path) [$stg opendir [file tail $path] w+] } proc vfs::stg::stat {token path} { @@ -125,11 +135,6 @@ proc vfs::stg::stat {token path} { 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] @@ -157,7 +162,7 @@ proc vfs::stg::matchindirectory {token path actualpath pattern type} { } proc vfs::stg::open {token path mode permissions} { - ::vfs::log "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) @@ -167,8 +172,7 @@ proc vfs::stg::open {token path mode permissions} { } proc vfs::stg::removedirectory {token path recursive} { - ::vfs::log "removedirectory: $token $path $recursive" - variable $token + ::vfs::log "removedirectory: $token \"$path\" $recursive" upvar #0 $token state set stg [PathToStg $token [file dirname $path]] $stg remove [file tail $path] @@ -179,37 +183,24 @@ proc vfs::stg::removedirectory {token path recursive} { } proc ::vfs::stg::deletefile {token path} { - ::vfs::log "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 + ::vfs::log "fileattributes: $token \"$path\" $args" # We don't have any yet. + # We could show the guid and state fields from STATSTG possibly. 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) - } + 0 { return [list] } + 1 { return "" } + 2 { vfs::filesystem posixerror $::vfs::posix(EROFS) } } } proc ::vfs::stg::utime {token path atime mtime} { - #::vfs::log "utime: $path $atime $mtime" + ::vfs::log "utime: $token \"$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. diff --git a/makefile.vc b/makefile.vc index ffd1c2f..6eb63e3 100644 --- a/makefile.vc +++ b/makefile.vc @@ -156,7 +156,7 @@ Please `cd` to its location first. PROJECT = tclstorage !include "rules.vc" -DOTVERSION = 1.1.0 +DOTVERSION = 1.2.0 VERSION = $(DOTVERSION:.=) STUBPREFIX = $(PROJECT)stub diff --git a/tclstorage.c b/tclstorage.c index 6c4dca2..15aad3d 100644 --- a/tclstorage.c +++ b/tclstorage.c @@ -44,7 +44,7 @@ #define PACKAGE_NAME "Storage" #endif #ifndef PACKAGE_VERSION -#define PACKAGE_VERSION "1.1.0" +#define PACKAGE_VERSION "1.2.0" #endif #include "tclstorage.h" @@ -1119,6 +1119,11 @@ StorageChannelWatch(ClientData instanceData, int mask) * Side effects: * An extra reference to the stream is returned to the called. * + * NOTE: If anyone really intends to use this it might be better to + * add the interface pointer to the global interface table and + * return the cookie to the caller. This would ensure correct + * interface marshalling. + * * ---------------------------------------------------------------------- */ @@ -1262,14 +1267,20 @@ Win32Error(const char * szPrefix, HRESULT hr) /* 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); + case STG_E_FILENOTFOUND: { + msgObj = Tcl_NewStringObj(szPrefix, -1); + Tcl_AppendToObj(msgObj, ": file not found", -1); + return msgObj; + } + case STG_E_ACCESSDENIED: { + msgObj = Tcl_NewStringObj(szPrefix, -1); + Tcl_AppendToObj(msgObj, ": permission denied", -1); + return msgObj; + } } dwLen = FormatMessageA(FORMAT_MESSAGE_ALLOCATE_BUFFER - | FORMAT_MESSAGE_FROM_SYSTEM, + | FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, (DWORD)hr, LANG_NEUTRAL, (LPTSTR)&lpBuffer, 0, NULL); if (dwLen < 1) {