[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]
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 {
# stgvfs.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
#
-#
+# 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
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
}
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}
# 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 {
# 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} {
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]
}
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)
}
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]
}
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.
#define PACKAGE_NAME "Storage"
#endif
#ifndef PACKAGE_VERSION
-#define PACKAGE_VERSION "1.1.0"
+#define PACKAGE_VERSION "1.2.0"
#endif
#include "tclstorage.h"
* 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.
+ *
* ----------------------------------------------------------------------
*/
/* 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) {
projects / tclstorage / commitdiff