12 changed files with 4068 additions and 37 deletions
@ -0,0 +1,704 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application modpod 0.1.3 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin modpod_module_modpod 0 0.1.3] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require modpod] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of modpod |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by modpod |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require struct::set ;#review |
||||||
|
package require punk::lib |
||||||
|
package require punk::args |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6-}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval modpod::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval modpod { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
|
||||||
|
variable connected |
||||||
|
if {![info exists connected(to)]} { |
||||||
|
set connected(to) list |
||||||
|
} |
||||||
|
variable modpodscript |
||||||
|
set modpodscript [info script] |
||||||
|
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
||||||
|
set connected(self) [file dirname $modpodscript] |
||||||
|
} else { |
||||||
|
#expecting a .tm |
||||||
|
set connected(self) $modpodscript |
||||||
|
} |
||||||
|
variable loadables [info sharedlibextension] |
||||||
|
variable sourceables {.tcl .tk} ;# .tm ? |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod}] |
||||||
|
#[para] Core API functions for modpod |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
#old tar connect mechanism - review - not needed? |
||||||
|
proc connect {args} { |
||||||
|
puts stderr "modpod::connect--->>$args" |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
@id -id ::modpod::connect |
||||||
|
-type -default "" |
||||||
|
@values -min 1 -max 1 |
||||||
|
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
||||||
|
} $args] |
||||||
|
catch { |
||||||
|
punk::lib::showdict $argd ;#heavy dependencies |
||||||
|
} |
||||||
|
set opt_path [dict get $argd values path] |
||||||
|
variable connected |
||||||
|
set original_connectpath $opt_path |
||||||
|
set modpodpath [modpod::system::normalize $opt_path] ;# |
||||||
|
|
||||||
|
if {$modpodpath in $connected(to)} { |
||||||
|
return [dict create ok ALREADY_CONNECTED] |
||||||
|
} |
||||||
|
lappend connected(to) $modpodpath |
||||||
|
|
||||||
|
set connected(connectpath,$opt_path) $original_connectpath |
||||||
|
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] |
||||||
|
|
||||||
|
set connected(location,$modpodpath) [file dirname $modpodpath] |
||||||
|
set connected(startdata,$modpodpath) -1 |
||||||
|
set connected(type,$modpodpath) [dict get $argd opts -type] |
||||||
|
set connected(fh,$modpodpath) "" |
||||||
|
|
||||||
|
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
||||||
|
set connected(type,$modpodpath) "unwrapped" |
||||||
|
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||||
|
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
||||||
|
|
||||||
|
} else { |
||||||
|
#connect to .tm but may still be unwrapped version available |
||||||
|
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||||
|
set this_pkg_tm_folder [file dirname $modpodpath] |
||||||
|
if {$connected(type,$modpodpath) ne "unwrapped"} { |
||||||
|
#Not directly connected to unwrapped version - but may still be redirected there |
||||||
|
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
||||||
|
if {[file exists $unwrappedFolder]} { |
||||||
|
#folder with exact version-match must exist for redirect to 'unwrapped' |
||||||
|
set con(type,$modpodpath) "modpod-redirecting" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
||||||
|
set connected(tmfile,$modpodpath) |
||||||
|
set tail_segments [list] |
||||||
|
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
||||||
|
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||||
|
foreach lc_mpath $lcase_modulepaths { |
||||||
|
set mpath_segments [file split $lc_mpath] |
||||||
|
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||||
|
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $tail_segments]} { |
||||||
|
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
||||||
|
} else { |
||||||
|
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
||||||
|
} |
||||||
|
|
||||||
|
switch -exact -- $connected(type,$modpodpath) { |
||||||
|
"modpod-redirecting" { |
||||||
|
#redirect to the unwrapped version |
||||||
|
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
||||||
|
|
||||||
|
} |
||||||
|
"unwrapped" { |
||||||
|
if {[info commands ::thread::id] ne ""} { |
||||||
|
set from [pid],[thread::id] |
||||||
|
} else { |
||||||
|
set from [pid] |
||||||
|
} |
||||||
|
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
||||||
|
return [list ok ""] |
||||||
|
} |
||||||
|
default { |
||||||
|
#autodetect .tm - zip/tar ? |
||||||
|
#todo - use vfs ? |
||||||
|
|
||||||
|
#connect to tarball - start at 1st header |
||||||
|
set connected(startdata,$modpodpath) 0 |
||||||
|
set fh [open $modpodpath r] |
||||||
|
set connected(fh,$modpodpath) $fh |
||||||
|
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
||||||
|
|
||||||
|
if {$connected(startdata,$modpodpath) >= 0} { |
||||||
|
#verify we have a valid tar header |
||||||
|
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { |
||||||
|
seek $fh $connected(startdata,$modpodpath) start |
||||||
|
return [list ok $fh] |
||||||
|
} else { |
||||||
|
#error "cannot verify tar header" |
||||||
|
} |
||||||
|
} |
||||||
|
lpop connected(to) end |
||||||
|
set connected(startdata,$modpodpath) -1 |
||||||
|
unset connected(fh,$modpodpath) |
||||||
|
catch {close $fh} |
||||||
|
return [dict create err {Does not appear to be a valid modpod}] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc disconnect {{modpod ""}} { |
||||||
|
variable connected |
||||||
|
if {![llength $connected(to)]} { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {$modpod eq ""} { |
||||||
|
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
||||||
|
set modpod [lindex $connected(to) end] |
||||||
|
} |
||||||
|
|
||||||
|
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
||||||
|
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {[string length $connected(fh,$modpod)]} { |
||||||
|
close $connected(fh,$modpod) |
||||||
|
} |
||||||
|
array unset connected *,$modpod |
||||||
|
set connected(to) [lreplace $connected(to) $posn $posn] |
||||||
|
return 1 |
||||||
|
} |
||||||
|
proc get {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
-from -default "" -help "path to pod" |
||||||
|
*values -min 1 -max 1 |
||||||
|
filename |
||||||
|
} $args] |
||||||
|
set frompod [dict get $argd opts -from] |
||||||
|
set filename [dict get $argd values filename] |
||||||
|
|
||||||
|
variable connected |
||||||
|
#//review |
||||||
|
set modpod [::modpod::system::connect_if_not $frompod] |
||||||
|
set fh $connected(fh,$modpod) |
||||||
|
if {$connected(type,$modpod) eq "unwrapped"} { |
||||||
|
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
||||||
|
if {[string range $filename 0 0 eq "/"]} { |
||||||
|
#absolute path (?) |
||||||
|
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
||||||
|
} else { |
||||||
|
#relative path - use #modpod-xxx as base |
||||||
|
set path [file join $connected(location,$modpod) $filename] |
||||||
|
} |
||||||
|
set fd [open $path r] |
||||||
|
#utf-8? |
||||||
|
#fconfigure $fd -encoding iso8859-1 -translation binary |
||||||
|
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
||||||
|
} else { |
||||||
|
#read from vfs |
||||||
|
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace modpod ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval modpod::lib { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
proc is_valid_tm_version {versionpart} { |
||||||
|
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||||
|
if {![catch [list package vcompare $versionparts $versionparts]]} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#zipfile is a pure zip at this point - ie no script/exe header |
||||||
|
proc make_zip_modpod {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
@id -id ::modpod::lib::make_zip_modpod |
||||||
|
-offsettype -default "archive" -choices {archive file} -help\ |
||||||
|
"Whether zip offsets are relative to start of file or start of zip-data within the file. |
||||||
|
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, |
||||||
|
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) |
||||||
|
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. |
||||||
|
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" |
||||||
|
@values -min 2 -max 2 |
||||||
|
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
||||||
|
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" |
||||||
|
} $args] |
||||||
|
set zipfile [dict get $argd values zipfile] |
||||||
|
set outfile [dict get $argd values outfile] |
||||||
|
set opt_offsettype [dict get $argd opts -offsettype] |
||||||
|
|
||||||
|
|
||||||
|
set mount_stub [string map [list %offsettype% $opt_offsettype] { |
||||||
|
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. |
||||||
|
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. |
||||||
|
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile> |
||||||
|
if {[catch {file normalize [info script]} modfile]} { |
||||||
|
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
||||||
|
} |
||||||
|
if {$modfile eq "" || ![file exists $modfile]} { |
||||||
|
error "modpod zip stub error. Unable to determine module path" |
||||||
|
} |
||||||
|
set moddir [file dirname $modfile] |
||||||
|
set mod_and_ver [file rootname [file tail $modfile]] |
||||||
|
lassign [split $mod_and_ver -] moduletail version |
||||||
|
if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { |
||||||
|
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||||
|
} else { |
||||||
|
#determine module namespace so we can mount appropriately |
||||||
|
proc intersect {A B} { |
||||||
|
if {[llength $A] == 0} {return {}} |
||||||
|
if {[llength $B] == 0} {return {}} |
||||||
|
if {[llength $B] > [llength $A]} { |
||||||
|
set res $A |
||||||
|
set A $B |
||||||
|
set B $res |
||||||
|
} |
||||||
|
set res {} |
||||||
|
foreach x $A {set ($x) {}} |
||||||
|
foreach x $B { |
||||||
|
if {[info exists ($x)]} { |
||||||
|
lappend res $x |
||||||
|
} |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
set lcase_tmfile_segments [string tolower [file split $moddir]] |
||||||
|
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||||
|
foreach lc_mpath $lcase_modulepaths { |
||||||
|
set mpath_segments [file split $lc_mpath] |
||||||
|
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||||
|
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $tail_segments]} { |
||||||
|
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
||||||
|
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
||||||
|
} else { |
||||||
|
set fullpackage $moduletail |
||||||
|
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
||||||
|
} |
||||||
|
|
||||||
|
if {[info commands tcl::zipfs::mount] ne ""} { |
||||||
|
#argument order changed to be consistent with vfs::zip::Mount etc |
||||||
|
#early versions: zipfs::Mount mountpoint zipname |
||||||
|
#since 2023-09: zipfs::Mount zipname mountpoint |
||||||
|
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
||||||
|
#This is presumably related to // being interpreted as a network path |
||||||
|
set mountpoints [dict keys [tcl::zipfs::mount]] |
||||||
|
if {"//zipfs:/$mount_at" ni $mountpoints} { |
||||||
|
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
||||||
|
if {[catch { |
||||||
|
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
||||||
|
#puts "tcl::zipfs::mount $modfile $mount_at" |
||||||
|
tcl::zipfs::mount $modfile $mount_at |
||||||
|
} errM]} { |
||||||
|
#try old api |
||||||
|
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
||||||
|
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
||||||
|
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
||||||
|
} |
||||||
|
} |
||||||
|
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||||
|
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
||||||
|
#tcl::zipfs::unmount //zipfs:/$mount_at |
||||||
|
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||||
|
} |
||||||
|
} |
||||||
|
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
||||||
|
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||||
|
} else { |
||||||
|
#fallback to slower vfs::zip |
||||||
|
#NB. We don't create the intermediate dirs - but the mount still works |
||||||
|
if {![file exists $moddir/$mount_at]} { |
||||||
|
if {[catch {package require vfs::zip} errM]} { |
||||||
|
set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" |
||||||
|
append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." |
||||||
|
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
||||||
|
error $msg |
||||||
|
} else { |
||||||
|
set fd [vfs::zip::Mount $modfile $moddir/$mount_at] |
||||||
|
if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||||
|
vfs::zip::Unmount $fd $moddir/$mount_at |
||||||
|
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||||
|
} |
||||||
|
} |
||||||
|
#zipped data follows |
||||||
|
}] |
||||||
|
#todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? |
||||||
|
append mount_stub \x1A |
||||||
|
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval modpod::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
#deflate,store only supported |
||||||
|
|
||||||
|
#zipfile here is plain zip - no script/exe prefix part. |
||||||
|
proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { |
||||||
|
set inzip [open $zipfile r] |
||||||
|
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||||
|
set out [open $outfile w+] |
||||||
|
fconfigure $out -encoding iso8859-1 -translation binary |
||||||
|
puts -nonewline $out $mount_stub |
||||||
|
set stuboffset [tell $out] |
||||||
|
lappend report "stub size: $stuboffset" |
||||||
|
fcopy $inzip $out |
||||||
|
close $inzip |
||||||
|
|
||||||
|
set size [tell $out] |
||||||
|
lappend report "modpod::system::make_mountable_zip" |
||||||
|
lappend report "tmfile : [file tail $outfile]" |
||||||
|
lappend report "output size : $size" |
||||||
|
lappend report "offsettype : $offsettype" |
||||||
|
|
||||||
|
if {$offsettype eq "file"} { |
||||||
|
#make zip offsets relative to start of whole file including prepended script. |
||||||
|
#same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 |
||||||
|
#2025 - zipfs mkimg fixed to use 'archive' offset. |
||||||
|
#not editable by 7z,nanazip,peazip |
||||||
|
|
||||||
|
#we aren't adding any new files/folders so we can edit the offsets in place |
||||||
|
|
||||||
|
#Now seek in $out to find the end of directory signature: |
||||||
|
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
||||||
|
if {$size < 65559} { |
||||||
|
set tailsearch_start 0 |
||||||
|
} else { |
||||||
|
set tailsearch_start [expr {$size - 65559}] |
||||||
|
} |
||||||
|
seek $out $tailsearch_start |
||||||
|
set data [read $out] |
||||||
|
#EOCD - End of Central Directory record |
||||||
|
#PK\5\6 |
||||||
|
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
||||||
|
#set start_of_end [expr {$start_of_end + $seek}] |
||||||
|
#incr start_of_end $seek |
||||||
|
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||||
|
|
||||||
|
lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" |
||||||
|
|
||||||
|
seek $out $filerelative_eocd_posn |
||||||
|
set end_of_ctrl_dir [read $out] |
||||||
|
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||||
|
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||||
|
|
||||||
|
lappend report "End of central directory: [array get eocd]" |
||||||
|
seek $out [expr {$filerelative_eocd_posn+16}] |
||||||
|
|
||||||
|
#adjust offset of start of central directory by the length of our sfx stub |
||||||
|
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] |
||||||
|
flush $out |
||||||
|
|
||||||
|
seek $out $filerelative_eocd_posn |
||||||
|
set end_of_ctrl_dir [read $out] |
||||||
|
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||||
|
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||||
|
|
||||||
|
# 0x06054b50 - end of central dir signature |
||||||
|
puts stderr "$end_of_ctrl_dir" |
||||||
|
puts stderr "comment_len: $eocd(comment_len)" |
||||||
|
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
||||||
|
lappend report "New dir offset: $eocd(diroffset)" |
||||||
|
lappend report "Adjusting $eocd(totalnum) zip file items." |
||||||
|
catch { |
||||||
|
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
||||||
|
} |
||||||
|
|
||||||
|
seek $out $eocd(diroffset) |
||||||
|
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
||||||
|
set current_file [tell $out] |
||||||
|
set fileheader [read $out 46] |
||||||
|
puts -------------- |
||||||
|
puts [ansistring VIEW -lf 1 $fileheader] |
||||||
|
puts -------------- |
||||||
|
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||||
|
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||||
|
|
||||||
|
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||||
|
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||||
|
set ::last_header $fileheader |
||||||
|
|
||||||
|
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
||||||
|
puts "ver: $x(version)" |
||||||
|
puts "method: $x(method)" |
||||||
|
|
||||||
|
#PK\1\2 |
||||||
|
#33639248 dec = 0x02014b50 - central directory file header signature |
||||||
|
if { $x(sig) != 33639248 } { |
||||||
|
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
||||||
|
} |
||||||
|
|
||||||
|
foreach size $x(lengths) var {filename extrafield comment} { |
||||||
|
if { $size > 0 } { |
||||||
|
set x($var) [read $out $size] |
||||||
|
} else { |
||||||
|
set x($var) "" |
||||||
|
} |
||||||
|
} |
||||||
|
set next_file [tell $out] |
||||||
|
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
||||||
|
|
||||||
|
seek $out [expr {$current_file+42}] |
||||||
|
puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] |
||||||
|
|
||||||
|
#verify: |
||||||
|
flush $out |
||||||
|
seek $out $current_file |
||||||
|
set fileheader [read $out 46] |
||||||
|
lappend report "old $x(offset) + $stuboffset" |
||||||
|
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||||
|
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||||
|
lappend report "new $x(offset)" |
||||||
|
|
||||||
|
seek $out $next_file |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
close $out |
||||||
|
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
||||||
|
#don't fall over just because of that |
||||||
|
catch { |
||||||
|
punk::lib::showdict -roottype list -chan stderr $report |
||||||
|
} |
||||||
|
#puts [join $report \n] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc connect_if_not {{podpath ""}} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set podpath [::modpod::system::normalize $podpath] |
||||||
|
set docon 0 |
||||||
|
if {![llength $connected(to)]} { |
||||||
|
if {![string length $podpath]} { |
||||||
|
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
||||||
|
} else { |
||||||
|
set docon 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {![string length $podpath]} { |
||||||
|
set podpath [lindex $connected(to) end] |
||||||
|
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
||||||
|
} else { |
||||||
|
if {$podpath ni $connected(to)} { |
||||||
|
set docon 1 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {$docon} { |
||||||
|
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
||||||
|
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
||||||
|
} else { |
||||||
|
return $podpath |
||||||
|
} |
||||||
|
} |
||||||
|
#we were already connected |
||||||
|
return $podpath |
||||||
|
} |
||||||
|
|
||||||
|
proc myversion {} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set script [info script] |
||||||
|
if {![string length $script]} { |
||||||
|
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
||||||
|
} |
||||||
|
set fname [file tail [file rootname [file normalize $script]]] |
||||||
|
set scriptdir [file dirname $script] |
||||||
|
|
||||||
|
if {![string match "#modpod-*" $fname]} { |
||||||
|
lassign [lrange [split $fname -] end-1 end] _pkgname version |
||||||
|
} else { |
||||||
|
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
||||||
|
if {![string length $version]} { |
||||||
|
#try again on the name of the containing folder |
||||||
|
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
||||||
|
#todo - proper walk up the directory tree |
||||||
|
if {![string length $version]} { |
||||||
|
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
||||||
|
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
||||||
|
return $version |
||||||
|
} |
||||||
|
|
||||||
|
proc myname {} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set script [info script] |
||||||
|
if {![string length $script]} { |
||||||
|
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
||||||
|
} |
||||||
|
return $connected(fullpackage,$script) |
||||||
|
} |
||||||
|
proc myfullname {} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set script [info script] |
||||||
|
#set script [::tarjar::normalize $script] |
||||||
|
set script [file normalize $script] |
||||||
|
if {![string length $script]} { |
||||||
|
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
||||||
|
} |
||||||
|
return $::tarjar::connected(fullpackage,$script) |
||||||
|
} |
||||||
|
proc normalize {path} { |
||||||
|
#newer versions of Tcl don't do tilde sub |
||||||
|
|
||||||
|
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
||||||
|
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
||||||
|
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
||||||
|
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
||||||
|
set path [file normalize $path] |
||||||
|
#set path [string tolower $path] ;#must do this after file normalize |
||||||
|
return [string map [list $matilda ~] $path] ;#get our tildes back. |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide modpod [namespace eval modpod { |
||||||
|
variable pkg modpod |
||||||
|
variable version |
||||||
|
set version 0.1.3 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,366 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application dictn 0.1.2 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval dictn { |
||||||
|
namespace export {[a-z]*} |
||||||
|
namespace ensemble create |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
## ::dictn::append |
||||||
|
#This can of course 'ruin' a nested dict if applied to the wrong element |
||||||
|
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: |
||||||
|
# %set list {a b {c d}} |
||||||
|
# %append list x |
||||||
|
# a b {c d}x |
||||||
|
# IOW - don't do that unless you really know that's what you want. |
||||||
|
# |
||||||
|
proc ::dictn::append {dictvar path {value {}}} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict append $dictvar $path $value] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set str [dict get $dvar {*}$path] |
||||||
|
append str $val |
||||||
|
dict set dvar {*}$path $str |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::create {args} { |
||||||
|
::set data {} |
||||||
|
foreach {path val} $args { |
||||||
|
dict set data {*}$path $val |
||||||
|
} |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::exists {dictval path} { |
||||||
|
return [dict exists $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::filter {dictval path filterType args} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict filter $sub $filterType {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::for {keyvalvars dictval path body} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict for $keyvalvars $sub $body |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::get {dictval {path {}}} { |
||||||
|
return [dict get $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[info commands ::tcl::dict::getdef] ne ""} { |
||||||
|
#tcl 9+ |
||||||
|
proc ::dictn::getdef {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getwithdefault {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#tcl < 9 |
||||||
|
proc ::dictn::getdef {dictval path default} { |
||||||
|
if {[tcl::dict::exists $dictval {*}$path]} { |
||||||
|
return [tcl::dict::get $dictval {*}$path] |
||||||
|
} else { |
||||||
|
return $default |
||||||
|
} |
||||||
|
} |
||||||
|
proc ::dictn::getwithdefault {dictval path default} { |
||||||
|
if {[tcl::dict::exists $dictval {*}$path]} { |
||||||
|
return [tcl::dict::get $dictval {*}$path] |
||||||
|
} else { |
||||||
|
return $default |
||||||
|
} |
||||||
|
} |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
if {![dict exists $dvar {*}$path]} { |
||||||
|
::set val 0 |
||||||
|
} else { |
||||||
|
::set val [dict get $dvar {*}$path] |
||||||
|
} |
||||||
|
::set newval [expr {$val + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::info {dictval {path {}}} { |
||||||
|
if {![string length $path]} { |
||||||
|
return [dict info $dictval] |
||||||
|
} else { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
return [dict info $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::keys {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict keys $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict keys $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::lappend {dictvar path args} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict lappend $dictvar $path {*}$args] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set list [dict get $dvar {*}$path] |
||||||
|
::lappend list {*}$args |
||||||
|
dict set dvar {*}$path $list |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::merge {args} { |
||||||
|
error "nested merge not yet supported" |
||||||
|
} |
||||||
|
|
||||||
|
#dictn remove dictionaryValue ?path ...? |
||||||
|
proc ::dictn::remove {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) removals to do in a single call. |
||||||
|
|
||||||
|
foreach path $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict remove $sub [lindex $path end]] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict remove $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::replace {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. |
||||||
|
|
||||||
|
foreach {path val} $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path $val |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict replace $sub [lindex $path end] $val] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict replace $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::set {dictvar path newval} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict set dvar {*}$path $newval] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::size {dictval {path {}}} { |
||||||
|
return [dict size [dict get $dictval {*}$path]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::unset {dictvar path} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict unset dvar {*}$path |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::update {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
upvar 1 $var $var |
||||||
|
if {![::info exists $var]} { |
||||||
|
uplevel 1 [list dict unset $dictvar {*}$path] |
||||||
|
} else { |
||||||
|
uplevel 1 [list dict set $dictvar {*}$path [::set $var]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
#an experiment. |
||||||
|
proc ::dictn::Applyupdate {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set headscript "" |
||||||
|
::set i 0 |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
#uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
::lappend arglist $var |
||||||
|
::lappend vallist [dict get $dvar {*}$path] |
||||||
|
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] |
||||||
|
::append headscript \n |
||||||
|
::incr i |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
::set body $headscript\r\n$body |
||||||
|
|
||||||
|
puts stderr "BODY: $body" |
||||||
|
|
||||||
|
#set result [apply [list args $body] {*}$vallist] |
||||||
|
catch {apply [list args $body] {*}$vallist} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path] && [::info exists $var]} { |
||||||
|
dict set dvar {*}$path [::set $var] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::values {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict values $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict values $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Standard form: |
||||||
|
#'dictn with dictVariable path body' |
||||||
|
# |
||||||
|
# Extended form: |
||||||
|
#'dictn with dictVariable path arrayVariable body' |
||||||
|
# |
||||||
|
proc ::dictn::with {dictvar path args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
::set body [lindex $args 0] |
||||||
|
return [uplevel 1 [list dict with $dictvar {*}$path $body]] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
::lassign $args arrayname body |
||||||
|
|
||||||
|
upvar 1 $arrayname arr |
||||||
|
array set arr [dict get $dvar {*}$path] |
||||||
|
::set prevkeys [array names arr] |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
|
||||||
|
foreach k $prevkeys { |
||||||
|
if {![::info exists arr($k)]} { |
||||||
|
dict unset $dvar {*}$path $k |
||||||
|
} |
||||||
|
} |
||||||
|
foreach k [array names arr] { |
||||||
|
dict set $dvar {*}$path $k $arr($k) |
||||||
|
} |
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide dictn [namespace eval dictn { |
||||||
|
variable version |
||||||
|
::set version 0.1.2 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,704 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application modpod 0.1.3 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin modpod_module_modpod 0 0.1.3] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require modpod] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of modpod |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by modpod |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require struct::set ;#review |
||||||
|
package require punk::lib |
||||||
|
package require punk::args |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6-}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval modpod::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval modpod { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
|
||||||
|
variable connected |
||||||
|
if {![info exists connected(to)]} { |
||||||
|
set connected(to) list |
||||||
|
} |
||||||
|
variable modpodscript |
||||||
|
set modpodscript [info script] |
||||||
|
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
||||||
|
set connected(self) [file dirname $modpodscript] |
||||||
|
} else { |
||||||
|
#expecting a .tm |
||||||
|
set connected(self) $modpodscript |
||||||
|
} |
||||||
|
variable loadables [info sharedlibextension] |
||||||
|
variable sourceables {.tcl .tk} ;# .tm ? |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod}] |
||||||
|
#[para] Core API functions for modpod |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
#old tar connect mechanism - review - not needed? |
||||||
|
proc connect {args} { |
||||||
|
puts stderr "modpod::connect--->>$args" |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
@id -id ::modpod::connect |
||||||
|
-type -default "" |
||||||
|
@values -min 1 -max 1 |
||||||
|
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
||||||
|
} $args] |
||||||
|
catch { |
||||||
|
punk::lib::showdict $argd ;#heavy dependencies |
||||||
|
} |
||||||
|
set opt_path [dict get $argd values path] |
||||||
|
variable connected |
||||||
|
set original_connectpath $opt_path |
||||||
|
set modpodpath [modpod::system::normalize $opt_path] ;# |
||||||
|
|
||||||
|
if {$modpodpath in $connected(to)} { |
||||||
|
return [dict create ok ALREADY_CONNECTED] |
||||||
|
} |
||||||
|
lappend connected(to) $modpodpath |
||||||
|
|
||||||
|
set connected(connectpath,$opt_path) $original_connectpath |
||||||
|
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] |
||||||
|
|
||||||
|
set connected(location,$modpodpath) [file dirname $modpodpath] |
||||||
|
set connected(startdata,$modpodpath) -1 |
||||||
|
set connected(type,$modpodpath) [dict get $argd opts -type] |
||||||
|
set connected(fh,$modpodpath) "" |
||||||
|
|
||||||
|
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
||||||
|
set connected(type,$modpodpath) "unwrapped" |
||||||
|
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||||
|
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
||||||
|
|
||||||
|
} else { |
||||||
|
#connect to .tm but may still be unwrapped version available |
||||||
|
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||||
|
set this_pkg_tm_folder [file dirname $modpodpath] |
||||||
|
if {$connected(type,$modpodpath) ne "unwrapped"} { |
||||||
|
#Not directly connected to unwrapped version - but may still be redirected there |
||||||
|
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
||||||
|
if {[file exists $unwrappedFolder]} { |
||||||
|
#folder with exact version-match must exist for redirect to 'unwrapped' |
||||||
|
set con(type,$modpodpath) "modpod-redirecting" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
||||||
|
set connected(tmfile,$modpodpath) |
||||||
|
set tail_segments [list] |
||||||
|
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
||||||
|
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||||
|
foreach lc_mpath $lcase_modulepaths { |
||||||
|
set mpath_segments [file split $lc_mpath] |
||||||
|
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||||
|
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $tail_segments]} { |
||||||
|
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
||||||
|
} else { |
||||||
|
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
||||||
|
} |
||||||
|
|
||||||
|
switch -exact -- $connected(type,$modpodpath) { |
||||||
|
"modpod-redirecting" { |
||||||
|
#redirect to the unwrapped version |
||||||
|
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
||||||
|
|
||||||
|
} |
||||||
|
"unwrapped" { |
||||||
|
if {[info commands ::thread::id] ne ""} { |
||||||
|
set from [pid],[thread::id] |
||||||
|
} else { |
||||||
|
set from [pid] |
||||||
|
} |
||||||
|
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
||||||
|
return [list ok ""] |
||||||
|
} |
||||||
|
default { |
||||||
|
#autodetect .tm - zip/tar ? |
||||||
|
#todo - use vfs ? |
||||||
|
|
||||||
|
#connect to tarball - start at 1st header |
||||||
|
set connected(startdata,$modpodpath) 0 |
||||||
|
set fh [open $modpodpath r] |
||||||
|
set connected(fh,$modpodpath) $fh |
||||||
|
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
||||||
|
|
||||||
|
if {$connected(startdata,$modpodpath) >= 0} { |
||||||
|
#verify we have a valid tar header |
||||||
|
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { |
||||||
|
seek $fh $connected(startdata,$modpodpath) start |
||||||
|
return [list ok $fh] |
||||||
|
} else { |
||||||
|
#error "cannot verify tar header" |
||||||
|
} |
||||||
|
} |
||||||
|
lpop connected(to) end |
||||||
|
set connected(startdata,$modpodpath) -1 |
||||||
|
unset connected(fh,$modpodpath) |
||||||
|
catch {close $fh} |
||||||
|
return [dict create err {Does not appear to be a valid modpod}] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc disconnect {{modpod ""}} { |
||||||
|
variable connected |
||||||
|
if {![llength $connected(to)]} { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {$modpod eq ""} { |
||||||
|
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
||||||
|
set modpod [lindex $connected(to) end] |
||||||
|
} |
||||||
|
|
||||||
|
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
||||||
|
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {[string length $connected(fh,$modpod)]} { |
||||||
|
close $connected(fh,$modpod) |
||||||
|
} |
||||||
|
array unset connected *,$modpod |
||||||
|
set connected(to) [lreplace $connected(to) $posn $posn] |
||||||
|
return 1 |
||||||
|
} |
||||||
|
proc get {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
-from -default "" -help "path to pod" |
||||||
|
*values -min 1 -max 1 |
||||||
|
filename |
||||||
|
} $args] |
||||||
|
set frompod [dict get $argd opts -from] |
||||||
|
set filename [dict get $argd values filename] |
||||||
|
|
||||||
|
variable connected |
||||||
|
#//review |
||||||
|
set modpod [::modpod::system::connect_if_not $frompod] |
||||||
|
set fh $connected(fh,$modpod) |
||||||
|
if {$connected(type,$modpod) eq "unwrapped"} { |
||||||
|
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
||||||
|
if {[string range $filename 0 0 eq "/"]} { |
||||||
|
#absolute path (?) |
||||||
|
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
||||||
|
} else { |
||||||
|
#relative path - use #modpod-xxx as base |
||||||
|
set path [file join $connected(location,$modpod) $filename] |
||||||
|
} |
||||||
|
set fd [open $path r] |
||||||
|
#utf-8? |
||||||
|
#fconfigure $fd -encoding iso8859-1 -translation binary |
||||||
|
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
||||||
|
} else { |
||||||
|
#read from vfs |
||||||
|
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace modpod ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval modpod::lib { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
proc is_valid_tm_version {versionpart} { |
||||||
|
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||||
|
if {![catch [list package vcompare $versionparts $versionparts]]} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#zipfile is a pure zip at this point - ie no script/exe header |
||||||
|
proc make_zip_modpod {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
@id -id ::modpod::lib::make_zip_modpod |
||||||
|
-offsettype -default "archive" -choices {archive file} -help\ |
||||||
|
"Whether zip offsets are relative to start of file or start of zip-data within the file. |
||||||
|
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, |
||||||
|
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) |
||||||
|
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. |
||||||
|
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" |
||||||
|
@values -min 2 -max 2 |
||||||
|
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
||||||
|
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" |
||||||
|
} $args] |
||||||
|
set zipfile [dict get $argd values zipfile] |
||||||
|
set outfile [dict get $argd values outfile] |
||||||
|
set opt_offsettype [dict get $argd opts -offsettype] |
||||||
|
|
||||||
|
|
||||||
|
set mount_stub [string map [list %offsettype% $opt_offsettype] { |
||||||
|
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. |
||||||
|
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. |
||||||
|
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile> |
||||||
|
if {[catch {file normalize [info script]} modfile]} { |
||||||
|
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
||||||
|
} |
||||||
|
if {$modfile eq "" || ![file exists $modfile]} { |
||||||
|
error "modpod zip stub error. Unable to determine module path" |
||||||
|
} |
||||||
|
set moddir [file dirname $modfile] |
||||||
|
set mod_and_ver [file rootname [file tail $modfile]] |
||||||
|
lassign [split $mod_and_ver -] moduletail version |
||||||
|
if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { |
||||||
|
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||||
|
} else { |
||||||
|
#determine module namespace so we can mount appropriately |
||||||
|
proc intersect {A B} { |
||||||
|
if {[llength $A] == 0} {return {}} |
||||||
|
if {[llength $B] == 0} {return {}} |
||||||
|
if {[llength $B] > [llength $A]} { |
||||||
|
set res $A |
||||||
|
set A $B |
||||||
|
set B $res |
||||||
|
} |
||||||
|
set res {} |
||||||
|
foreach x $A {set ($x) {}} |
||||||
|
foreach x $B { |
||||||
|
if {[info exists ($x)]} { |
||||||
|
lappend res $x |
||||||
|
} |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
set lcase_tmfile_segments [string tolower [file split $moddir]] |
||||||
|
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||||
|
foreach lc_mpath $lcase_modulepaths { |
||||||
|
set mpath_segments [file split $lc_mpath] |
||||||
|
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||||
|
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $tail_segments]} { |
||||||
|
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
||||||
|
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
||||||
|
} else { |
||||||
|
set fullpackage $moduletail |
||||||
|
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
||||||
|
} |
||||||
|
|
||||||
|
if {[info commands tcl::zipfs::mount] ne ""} { |
||||||
|
#argument order changed to be consistent with vfs::zip::Mount etc |
||||||
|
#early versions: zipfs::Mount mountpoint zipname |
||||||
|
#since 2023-09: zipfs::Mount zipname mountpoint |
||||||
|
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
||||||
|
#This is presumably related to // being interpreted as a network path |
||||||
|
set mountpoints [dict keys [tcl::zipfs::mount]] |
||||||
|
if {"//zipfs:/$mount_at" ni $mountpoints} { |
||||||
|
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
||||||
|
if {[catch { |
||||||
|
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
||||||
|
#puts "tcl::zipfs::mount $modfile $mount_at" |
||||||
|
tcl::zipfs::mount $modfile $mount_at |
||||||
|
} errM]} { |
||||||
|
#try old api |
||||||
|
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
||||||
|
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
||||||
|
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
||||||
|
} |
||||||
|
} |
||||||
|
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||||
|
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
||||||
|
#tcl::zipfs::unmount //zipfs:/$mount_at |
||||||
|
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||||
|
} |
||||||
|
} |
||||||
|
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
||||||
|
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||||
|
} else { |
||||||
|
#fallback to slower vfs::zip |
||||||
|
#NB. We don't create the intermediate dirs - but the mount still works |
||||||
|
if {![file exists $moddir/$mount_at]} { |
||||||
|
if {[catch {package require vfs::zip} errM]} { |
||||||
|
set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" |
||||||
|
append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." |
||||||
|
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
||||||
|
error $msg |
||||||
|
} else { |
||||||
|
set fd [vfs::zip::Mount $modfile $moddir/$mount_at] |
||||||
|
if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||||
|
vfs::zip::Unmount $fd $moddir/$mount_at |
||||||
|
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||||
|
} |
||||||
|
} |
||||||
|
#zipped data follows |
||||||
|
}] |
||||||
|
#todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? |
||||||
|
append mount_stub \x1A |
||||||
|
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval modpod::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
#deflate,store only supported |
||||||
|
|
||||||
|
#zipfile here is plain zip - no script/exe prefix part. |
||||||
|
proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { |
||||||
|
set inzip [open $zipfile r] |
||||||
|
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||||
|
set out [open $outfile w+] |
||||||
|
fconfigure $out -encoding iso8859-1 -translation binary |
||||||
|
puts -nonewline $out $mount_stub |
||||||
|
set stuboffset [tell $out] |
||||||
|
lappend report "stub size: $stuboffset" |
||||||
|
fcopy $inzip $out |
||||||
|
close $inzip |
||||||
|
|
||||||
|
set size [tell $out] |
||||||
|
lappend report "modpod::system::make_mountable_zip" |
||||||
|
lappend report "tmfile : [file tail $outfile]" |
||||||
|
lappend report "output size : $size" |
||||||
|
lappend report "offsettype : $offsettype" |
||||||
|
|
||||||
|
if {$offsettype eq "file"} { |
||||||
|
#make zip offsets relative to start of whole file including prepended script. |
||||||
|
#same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 |
||||||
|
#2025 - zipfs mkimg fixed to use 'archive' offset. |
||||||
|
#not editable by 7z,nanazip,peazip |
||||||
|
|
||||||
|
#we aren't adding any new files/folders so we can edit the offsets in place |
||||||
|
|
||||||
|
#Now seek in $out to find the end of directory signature: |
||||||
|
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
||||||
|
if {$size < 65559} { |
||||||
|
set tailsearch_start 0 |
||||||
|
} else { |
||||||
|
set tailsearch_start [expr {$size - 65559}] |
||||||
|
} |
||||||
|
seek $out $tailsearch_start |
||||||
|
set data [read $out] |
||||||
|
#EOCD - End of Central Directory record |
||||||
|
#PK\5\6 |
||||||
|
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
||||||
|
#set start_of_end [expr {$start_of_end + $seek}] |
||||||
|
#incr start_of_end $seek |
||||||
|
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||||
|
|
||||||
|
lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" |
||||||
|
|
||||||
|
seek $out $filerelative_eocd_posn |
||||||
|
set end_of_ctrl_dir [read $out] |
||||||
|
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||||
|
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||||
|
|
||||||
|
lappend report "End of central directory: [array get eocd]" |
||||||
|
seek $out [expr {$filerelative_eocd_posn+16}] |
||||||
|
|
||||||
|
#adjust offset of start of central directory by the length of our sfx stub |
||||||
|
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] |
||||||
|
flush $out |
||||||
|
|
||||||
|
seek $out $filerelative_eocd_posn |
||||||
|
set end_of_ctrl_dir [read $out] |
||||||
|
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||||
|
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||||
|
|
||||||
|
# 0x06054b50 - end of central dir signature |
||||||
|
puts stderr "$end_of_ctrl_dir" |
||||||
|
puts stderr "comment_len: $eocd(comment_len)" |
||||||
|
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
||||||
|
lappend report "New dir offset: $eocd(diroffset)" |
||||||
|
lappend report "Adjusting $eocd(totalnum) zip file items." |
||||||
|
catch { |
||||||
|
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
||||||
|
} |
||||||
|
|
||||||
|
seek $out $eocd(diroffset) |
||||||
|
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
||||||
|
set current_file [tell $out] |
||||||
|
set fileheader [read $out 46] |
||||||
|
puts -------------- |
||||||
|
puts [ansistring VIEW -lf 1 $fileheader] |
||||||
|
puts -------------- |
||||||
|
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||||
|
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||||
|
|
||||||
|
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||||
|
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||||
|
set ::last_header $fileheader |
||||||
|
|
||||||
|
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
||||||
|
puts "ver: $x(version)" |
||||||
|
puts "method: $x(method)" |
||||||
|
|
||||||
|
#PK\1\2 |
||||||
|
#33639248 dec = 0x02014b50 - central directory file header signature |
||||||
|
if { $x(sig) != 33639248 } { |
||||||
|
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
||||||
|
} |
||||||
|
|
||||||
|
foreach size $x(lengths) var {filename extrafield comment} { |
||||||
|
if { $size > 0 } { |
||||||
|
set x($var) [read $out $size] |
||||||
|
} else { |
||||||
|
set x($var) "" |
||||||
|
} |
||||||
|
} |
||||||
|
set next_file [tell $out] |
||||||
|
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
||||||
|
|
||||||
|
seek $out [expr {$current_file+42}] |
||||||
|
puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] |
||||||
|
|
||||||
|
#verify: |
||||||
|
flush $out |
||||||
|
seek $out $current_file |
||||||
|
set fileheader [read $out 46] |
||||||
|
lappend report "old $x(offset) + $stuboffset" |
||||||
|
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||||
|
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||||
|
lappend report "new $x(offset)" |
||||||
|
|
||||||
|
seek $out $next_file |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
close $out |
||||||
|
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
||||||
|
#don't fall over just because of that |
||||||
|
catch { |
||||||
|
punk::lib::showdict -roottype list -chan stderr $report |
||||||
|
} |
||||||
|
#puts [join $report \n] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc connect_if_not {{podpath ""}} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set podpath [::modpod::system::normalize $podpath] |
||||||
|
set docon 0 |
||||||
|
if {![llength $connected(to)]} { |
||||||
|
if {![string length $podpath]} { |
||||||
|
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
||||||
|
} else { |
||||||
|
set docon 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {![string length $podpath]} { |
||||||
|
set podpath [lindex $connected(to) end] |
||||||
|
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
||||||
|
} else { |
||||||
|
if {$podpath ni $connected(to)} { |
||||||
|
set docon 1 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {$docon} { |
||||||
|
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
||||||
|
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
||||||
|
} else { |
||||||
|
return $podpath |
||||||
|
} |
||||||
|
} |
||||||
|
#we were already connected |
||||||
|
return $podpath |
||||||
|
} |
||||||
|
|
||||||
|
proc myversion {} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set script [info script] |
||||||
|
if {![string length $script]} { |
||||||
|
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
||||||
|
} |
||||||
|
set fname [file tail [file rootname [file normalize $script]]] |
||||||
|
set scriptdir [file dirname $script] |
||||||
|
|
||||||
|
if {![string match "#modpod-*" $fname]} { |
||||||
|
lassign [lrange [split $fname -] end-1 end] _pkgname version |
||||||
|
} else { |
||||||
|
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
||||||
|
if {![string length $version]} { |
||||||
|
#try again on the name of the containing folder |
||||||
|
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
||||||
|
#todo - proper walk up the directory tree |
||||||
|
if {![string length $version]} { |
||||||
|
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
||||||
|
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
||||||
|
return $version |
||||||
|
} |
||||||
|
|
||||||
|
proc myname {} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set script [info script] |
||||||
|
if {![string length $script]} { |
||||||
|
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
||||||
|
} |
||||||
|
return $connected(fullpackage,$script) |
||||||
|
} |
||||||
|
proc myfullname {} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set script [info script] |
||||||
|
#set script [::tarjar::normalize $script] |
||||||
|
set script [file normalize $script] |
||||||
|
if {![string length $script]} { |
||||||
|
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
||||||
|
} |
||||||
|
return $::tarjar::connected(fullpackage,$script) |
||||||
|
} |
||||||
|
proc normalize {path} { |
||||||
|
#newer versions of Tcl don't do tilde sub |
||||||
|
|
||||||
|
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
||||||
|
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
||||||
|
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
||||||
|
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
||||||
|
set path [file normalize $path] |
||||||
|
#set path [string tolower $path] ;#must do this after file normalize |
||||||
|
return [string map [list $matilda ~] $path] ;#get our tildes back. |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide modpod [namespace eval modpod { |
||||||
|
variable pkg modpod |
||||||
|
variable version |
||||||
|
set version 0.1.3 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,366 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application dictn 0.1.2 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval dictn { |
||||||
|
namespace export {[a-z]*} |
||||||
|
namespace ensemble create |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
## ::dictn::append |
||||||
|
#This can of course 'ruin' a nested dict if applied to the wrong element |
||||||
|
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: |
||||||
|
# %set list {a b {c d}} |
||||||
|
# %append list x |
||||||
|
# a b {c d}x |
||||||
|
# IOW - don't do that unless you really know that's what you want. |
||||||
|
# |
||||||
|
proc ::dictn::append {dictvar path {value {}}} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict append $dictvar $path $value] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set str [dict get $dvar {*}$path] |
||||||
|
append str $val |
||||||
|
dict set dvar {*}$path $str |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::create {args} { |
||||||
|
::set data {} |
||||||
|
foreach {path val} $args { |
||||||
|
dict set data {*}$path $val |
||||||
|
} |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::exists {dictval path} { |
||||||
|
return [dict exists $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::filter {dictval path filterType args} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict filter $sub $filterType {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::for {keyvalvars dictval path body} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict for $keyvalvars $sub $body |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::get {dictval {path {}}} { |
||||||
|
return [dict get $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[info commands ::tcl::dict::getdef] ne ""} { |
||||||
|
#tcl 9+ |
||||||
|
proc ::dictn::getdef {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getwithdefault {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#tcl < 9 |
||||||
|
proc ::dictn::getdef {dictval path default} { |
||||||
|
if {[tcl::dict::exists $dictval {*}$path]} { |
||||||
|
return [tcl::dict::get $dictval {*}$path] |
||||||
|
} else { |
||||||
|
return $default |
||||||
|
} |
||||||
|
} |
||||||
|
proc ::dictn::getwithdefault {dictval path default} { |
||||||
|
if {[tcl::dict::exists $dictval {*}$path]} { |
||||||
|
return [tcl::dict::get $dictval {*}$path] |
||||||
|
} else { |
||||||
|
return $default |
||||||
|
} |
||||||
|
} |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
if {![dict exists $dvar {*}$path]} { |
||||||
|
::set val 0 |
||||||
|
} else { |
||||||
|
::set val [dict get $dvar {*}$path] |
||||||
|
} |
||||||
|
::set newval [expr {$val + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::info {dictval {path {}}} { |
||||||
|
if {![string length $path]} { |
||||||
|
return [dict info $dictval] |
||||||
|
} else { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
return [dict info $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::keys {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict keys $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict keys $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::lappend {dictvar path args} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict lappend $dictvar $path {*}$args] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set list [dict get $dvar {*}$path] |
||||||
|
::lappend list {*}$args |
||||||
|
dict set dvar {*}$path $list |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::merge {args} { |
||||||
|
error "nested merge not yet supported" |
||||||
|
} |
||||||
|
|
||||||
|
#dictn remove dictionaryValue ?path ...? |
||||||
|
proc ::dictn::remove {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) removals to do in a single call. |
||||||
|
|
||||||
|
foreach path $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict remove $sub [lindex $path end]] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict remove $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::replace {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. |
||||||
|
|
||||||
|
foreach {path val} $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path $val |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict replace $sub [lindex $path end] $val] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict replace $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::set {dictvar path newval} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict set dvar {*}$path $newval] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::size {dictval {path {}}} { |
||||||
|
return [dict size [dict get $dictval {*}$path]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::unset {dictvar path} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict unset dvar {*}$path |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::update {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
upvar 1 $var $var |
||||||
|
if {![::info exists $var]} { |
||||||
|
uplevel 1 [list dict unset $dictvar {*}$path] |
||||||
|
} else { |
||||||
|
uplevel 1 [list dict set $dictvar {*}$path [::set $var]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
#an experiment. |
||||||
|
proc ::dictn::Applyupdate {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set headscript "" |
||||||
|
::set i 0 |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
#uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
::lappend arglist $var |
||||||
|
::lappend vallist [dict get $dvar {*}$path] |
||||||
|
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] |
||||||
|
::append headscript \n |
||||||
|
::incr i |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
::set body $headscript\r\n$body |
||||||
|
|
||||||
|
puts stderr "BODY: $body" |
||||||
|
|
||||||
|
#set result [apply [list args $body] {*}$vallist] |
||||||
|
catch {apply [list args $body] {*}$vallist} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path] && [::info exists $var]} { |
||||||
|
dict set dvar {*}$path [::set $var] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::values {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict values $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict values $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Standard form: |
||||||
|
#'dictn with dictVariable path body' |
||||||
|
# |
||||||
|
# Extended form: |
||||||
|
#'dictn with dictVariable path arrayVariable body' |
||||||
|
# |
||||||
|
proc ::dictn::with {dictvar path args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
::set body [lindex $args 0] |
||||||
|
return [uplevel 1 [list dict with $dictvar {*}$path $body]] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
::lassign $args arrayname body |
||||||
|
|
||||||
|
upvar 1 $arrayname arr |
||||||
|
array set arr [dict get $dvar {*}$path] |
||||||
|
::set prevkeys [array names arr] |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
|
||||||
|
foreach k $prevkeys { |
||||||
|
if {![::info exists arr($k)]} { |
||||||
|
dict unset $dvar {*}$path $k |
||||||
|
} |
||||||
|
} |
||||||
|
foreach k [array names arr] { |
||||||
|
dict set $dvar {*}$path $k $arr($k) |
||||||
|
} |
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide dictn [namespace eval dictn { |
||||||
|
variable version |
||||||
|
::set version 0.1.2 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,704 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application modpod 0.1.3 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin modpod_module_modpod 0 0.1.3] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require modpod] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of modpod |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by modpod |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require struct::set ;#review |
||||||
|
package require punk::lib |
||||||
|
package require punk::args |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6-}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval modpod::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval modpod { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
|
||||||
|
variable connected |
||||||
|
if {![info exists connected(to)]} { |
||||||
|
set connected(to) list |
||||||
|
} |
||||||
|
variable modpodscript |
||||||
|
set modpodscript [info script] |
||||||
|
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
||||||
|
set connected(self) [file dirname $modpodscript] |
||||||
|
} else { |
||||||
|
#expecting a .tm |
||||||
|
set connected(self) $modpodscript |
||||||
|
} |
||||||
|
variable loadables [info sharedlibextension] |
||||||
|
variable sourceables {.tcl .tk} ;# .tm ? |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod}] |
||||||
|
#[para] Core API functions for modpod |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
#old tar connect mechanism - review - not needed? |
||||||
|
proc connect {args} { |
||||||
|
puts stderr "modpod::connect--->>$args" |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
@id -id ::modpod::connect |
||||||
|
-type -default "" |
||||||
|
@values -min 1 -max 1 |
||||||
|
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
||||||
|
} $args] |
||||||
|
catch { |
||||||
|
punk::lib::showdict $argd ;#heavy dependencies |
||||||
|
} |
||||||
|
set opt_path [dict get $argd values path] |
||||||
|
variable connected |
||||||
|
set original_connectpath $opt_path |
||||||
|
set modpodpath [modpod::system::normalize $opt_path] ;# |
||||||
|
|
||||||
|
if {$modpodpath in $connected(to)} { |
||||||
|
return [dict create ok ALREADY_CONNECTED] |
||||||
|
} |
||||||
|
lappend connected(to) $modpodpath |
||||||
|
|
||||||
|
set connected(connectpath,$opt_path) $original_connectpath |
||||||
|
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] |
||||||
|
|
||||||
|
set connected(location,$modpodpath) [file dirname $modpodpath] |
||||||
|
set connected(startdata,$modpodpath) -1 |
||||||
|
set connected(type,$modpodpath) [dict get $argd opts -type] |
||||||
|
set connected(fh,$modpodpath) "" |
||||||
|
|
||||||
|
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
||||||
|
set connected(type,$modpodpath) "unwrapped" |
||||||
|
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||||
|
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
||||||
|
|
||||||
|
} else { |
||||||
|
#connect to .tm but may still be unwrapped version available |
||||||
|
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||||
|
set this_pkg_tm_folder [file dirname $modpodpath] |
||||||
|
if {$connected(type,$modpodpath) ne "unwrapped"} { |
||||||
|
#Not directly connected to unwrapped version - but may still be redirected there |
||||||
|
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
||||||
|
if {[file exists $unwrappedFolder]} { |
||||||
|
#folder with exact version-match must exist for redirect to 'unwrapped' |
||||||
|
set con(type,$modpodpath) "modpod-redirecting" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
||||||
|
set connected(tmfile,$modpodpath) |
||||||
|
set tail_segments [list] |
||||||
|
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
||||||
|
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||||
|
foreach lc_mpath $lcase_modulepaths { |
||||||
|
set mpath_segments [file split $lc_mpath] |
||||||
|
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||||
|
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $tail_segments]} { |
||||||
|
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
||||||
|
} else { |
||||||
|
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
||||||
|
} |
||||||
|
|
||||||
|
switch -exact -- $connected(type,$modpodpath) { |
||||||
|
"modpod-redirecting" { |
||||||
|
#redirect to the unwrapped version |
||||||
|
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
||||||
|
|
||||||
|
} |
||||||
|
"unwrapped" { |
||||||
|
if {[info commands ::thread::id] ne ""} { |
||||||
|
set from [pid],[thread::id] |
||||||
|
} else { |
||||||
|
set from [pid] |
||||||
|
} |
||||||
|
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
||||||
|
return [list ok ""] |
||||||
|
} |
||||||
|
default { |
||||||
|
#autodetect .tm - zip/tar ? |
||||||
|
#todo - use vfs ? |
||||||
|
|
||||||
|
#connect to tarball - start at 1st header |
||||||
|
set connected(startdata,$modpodpath) 0 |
||||||
|
set fh [open $modpodpath r] |
||||||
|
set connected(fh,$modpodpath) $fh |
||||||
|
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
||||||
|
|
||||||
|
if {$connected(startdata,$modpodpath) >= 0} { |
||||||
|
#verify we have a valid tar header |
||||||
|
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { |
||||||
|
seek $fh $connected(startdata,$modpodpath) start |
||||||
|
return [list ok $fh] |
||||||
|
} else { |
||||||
|
#error "cannot verify tar header" |
||||||
|
} |
||||||
|
} |
||||||
|
lpop connected(to) end |
||||||
|
set connected(startdata,$modpodpath) -1 |
||||||
|
unset connected(fh,$modpodpath) |
||||||
|
catch {close $fh} |
||||||
|
return [dict create err {Does not appear to be a valid modpod}] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc disconnect {{modpod ""}} { |
||||||
|
variable connected |
||||||
|
if {![llength $connected(to)]} { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {$modpod eq ""} { |
||||||
|
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
||||||
|
set modpod [lindex $connected(to) end] |
||||||
|
} |
||||||
|
|
||||||
|
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
||||||
|
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {[string length $connected(fh,$modpod)]} { |
||||||
|
close $connected(fh,$modpod) |
||||||
|
} |
||||||
|
array unset connected *,$modpod |
||||||
|
set connected(to) [lreplace $connected(to) $posn $posn] |
||||||
|
return 1 |
||||||
|
} |
||||||
|
proc get {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
-from -default "" -help "path to pod" |
||||||
|
*values -min 1 -max 1 |
||||||
|
filename |
||||||
|
} $args] |
||||||
|
set frompod [dict get $argd opts -from] |
||||||
|
set filename [dict get $argd values filename] |
||||||
|
|
||||||
|
variable connected |
||||||
|
#//review |
||||||
|
set modpod [::modpod::system::connect_if_not $frompod] |
||||||
|
set fh $connected(fh,$modpod) |
||||||
|
if {$connected(type,$modpod) eq "unwrapped"} { |
||||||
|
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
||||||
|
if {[string range $filename 0 0 eq "/"]} { |
||||||
|
#absolute path (?) |
||||||
|
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
||||||
|
} else { |
||||||
|
#relative path - use #modpod-xxx as base |
||||||
|
set path [file join $connected(location,$modpod) $filename] |
||||||
|
} |
||||||
|
set fd [open $path r] |
||||||
|
#utf-8? |
||||||
|
#fconfigure $fd -encoding iso8859-1 -translation binary |
||||||
|
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
||||||
|
} else { |
||||||
|
#read from vfs |
||||||
|
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace modpod ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval modpod::lib { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
proc is_valid_tm_version {versionpart} { |
||||||
|
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||||
|
if {![catch [list package vcompare $versionparts $versionparts]]} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#zipfile is a pure zip at this point - ie no script/exe header |
||||||
|
proc make_zip_modpod {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
@id -id ::modpod::lib::make_zip_modpod |
||||||
|
-offsettype -default "archive" -choices {archive file} -help\ |
||||||
|
"Whether zip offsets are relative to start of file or start of zip-data within the file. |
||||||
|
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, |
||||||
|
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) |
||||||
|
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. |
||||||
|
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" |
||||||
|
@values -min 2 -max 2 |
||||||
|
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
||||||
|
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" |
||||||
|
} $args] |
||||||
|
set zipfile [dict get $argd values zipfile] |
||||||
|
set outfile [dict get $argd values outfile] |
||||||
|
set opt_offsettype [dict get $argd opts -offsettype] |
||||||
|
|
||||||
|
|
||||||
|
set mount_stub [string map [list %offsettype% $opt_offsettype] { |
||||||
|
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. |
||||||
|
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. |
||||||
|
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile> |
||||||
|
if {[catch {file normalize [info script]} modfile]} { |
||||||
|
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
||||||
|
} |
||||||
|
if {$modfile eq "" || ![file exists $modfile]} { |
||||||
|
error "modpod zip stub error. Unable to determine module path" |
||||||
|
} |
||||||
|
set moddir [file dirname $modfile] |
||||||
|
set mod_and_ver [file rootname [file tail $modfile]] |
||||||
|
lassign [split $mod_and_ver -] moduletail version |
||||||
|
if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { |
||||||
|
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||||
|
} else { |
||||||
|
#determine module namespace so we can mount appropriately |
||||||
|
proc intersect {A B} { |
||||||
|
if {[llength $A] == 0} {return {}} |
||||||
|
if {[llength $B] == 0} {return {}} |
||||||
|
if {[llength $B] > [llength $A]} { |
||||||
|
set res $A |
||||||
|
set A $B |
||||||
|
set B $res |
||||||
|
} |
||||||
|
set res {} |
||||||
|
foreach x $A {set ($x) {}} |
||||||
|
foreach x $B { |
||||||
|
if {[info exists ($x)]} { |
||||||
|
lappend res $x |
||||||
|
} |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
set lcase_tmfile_segments [string tolower [file split $moddir]] |
||||||
|
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||||
|
foreach lc_mpath $lcase_modulepaths { |
||||||
|
set mpath_segments [file split $lc_mpath] |
||||||
|
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||||
|
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $tail_segments]} { |
||||||
|
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
||||||
|
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
||||||
|
} else { |
||||||
|
set fullpackage $moduletail |
||||||
|
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
||||||
|
} |
||||||
|
|
||||||
|
if {[info commands tcl::zipfs::mount] ne ""} { |
||||||
|
#argument order changed to be consistent with vfs::zip::Mount etc |
||||||
|
#early versions: zipfs::Mount mountpoint zipname |
||||||
|
#since 2023-09: zipfs::Mount zipname mountpoint |
||||||
|
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
||||||
|
#This is presumably related to // being interpreted as a network path |
||||||
|
set mountpoints [dict keys [tcl::zipfs::mount]] |
||||||
|
if {"//zipfs:/$mount_at" ni $mountpoints} { |
||||||
|
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
||||||
|
if {[catch { |
||||||
|
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
||||||
|
#puts "tcl::zipfs::mount $modfile $mount_at" |
||||||
|
tcl::zipfs::mount $modfile $mount_at |
||||||
|
} errM]} { |
||||||
|
#try old api |
||||||
|
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
||||||
|
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
||||||
|
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
||||||
|
} |
||||||
|
} |
||||||
|
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||||
|
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
||||||
|
#tcl::zipfs::unmount //zipfs:/$mount_at |
||||||
|
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||||
|
} |
||||||
|
} |
||||||
|
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
||||||
|
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||||
|
} else { |
||||||
|
#fallback to slower vfs::zip |
||||||
|
#NB. We don't create the intermediate dirs - but the mount still works |
||||||
|
if {![file exists $moddir/$mount_at]} { |
||||||
|
if {[catch {package require vfs::zip} errM]} { |
||||||
|
set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" |
||||||
|
append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." |
||||||
|
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
||||||
|
error $msg |
||||||
|
} else { |
||||||
|
set fd [vfs::zip::Mount $modfile $moddir/$mount_at] |
||||||
|
if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||||
|
vfs::zip::Unmount $fd $moddir/$mount_at |
||||||
|
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||||
|
} |
||||||
|
} |
||||||
|
#zipped data follows |
||||||
|
}] |
||||||
|
#todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? |
||||||
|
append mount_stub \x1A |
||||||
|
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval modpod::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
#deflate,store only supported |
||||||
|
|
||||||
|
#zipfile here is plain zip - no script/exe prefix part. |
||||||
|
proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { |
||||||
|
set inzip [open $zipfile r] |
||||||
|
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||||
|
set out [open $outfile w+] |
||||||
|
fconfigure $out -encoding iso8859-1 -translation binary |
||||||
|
puts -nonewline $out $mount_stub |
||||||
|
set stuboffset [tell $out] |
||||||
|
lappend report "stub size: $stuboffset" |
||||||
|
fcopy $inzip $out |
||||||
|
close $inzip |
||||||
|
|
||||||
|
set size [tell $out] |
||||||
|
lappend report "modpod::system::make_mountable_zip" |
||||||
|
lappend report "tmfile : [file tail $outfile]" |
||||||
|
lappend report "output size : $size" |
||||||
|
lappend report "offsettype : $offsettype" |
||||||
|
|
||||||
|
if {$offsettype eq "file"} { |
||||||
|
#make zip offsets relative to start of whole file including prepended script. |
||||||
|
#same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 |
||||||
|
#2025 - zipfs mkimg fixed to use 'archive' offset. |
||||||
|
#not editable by 7z,nanazip,peazip |
||||||
|
|
||||||
|
#we aren't adding any new files/folders so we can edit the offsets in place |
||||||
|
|
||||||
|
#Now seek in $out to find the end of directory signature: |
||||||
|
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
||||||
|
if {$size < 65559} { |
||||||
|
set tailsearch_start 0 |
||||||
|
} else { |
||||||
|
set tailsearch_start [expr {$size - 65559}] |
||||||
|
} |
||||||
|
seek $out $tailsearch_start |
||||||
|
set data [read $out] |
||||||
|
#EOCD - End of Central Directory record |
||||||
|
#PK\5\6 |
||||||
|
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
||||||
|
#set start_of_end [expr {$start_of_end + $seek}] |
||||||
|
#incr start_of_end $seek |
||||||
|
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||||
|
|
||||||
|
lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" |
||||||
|
|
||||||
|
seek $out $filerelative_eocd_posn |
||||||
|
set end_of_ctrl_dir [read $out] |
||||||
|
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||||
|
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||||
|
|
||||||
|
lappend report "End of central directory: [array get eocd]" |
||||||
|
seek $out [expr {$filerelative_eocd_posn+16}] |
||||||
|
|
||||||
|
#adjust offset of start of central directory by the length of our sfx stub |
||||||
|
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] |
||||||
|
flush $out |
||||||
|
|
||||||
|
seek $out $filerelative_eocd_posn |
||||||
|
set end_of_ctrl_dir [read $out] |
||||||
|
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||||
|
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||||
|
|
||||||
|
# 0x06054b50 - end of central dir signature |
||||||
|
puts stderr "$end_of_ctrl_dir" |
||||||
|
puts stderr "comment_len: $eocd(comment_len)" |
||||||
|
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
||||||
|
lappend report "New dir offset: $eocd(diroffset)" |
||||||
|
lappend report "Adjusting $eocd(totalnum) zip file items." |
||||||
|
catch { |
||||||
|
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
||||||
|
} |
||||||
|
|
||||||
|
seek $out $eocd(diroffset) |
||||||
|
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
||||||
|
set current_file [tell $out] |
||||||
|
set fileheader [read $out 46] |
||||||
|
puts -------------- |
||||||
|
puts [ansistring VIEW -lf 1 $fileheader] |
||||||
|
puts -------------- |
||||||
|
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||||
|
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||||
|
|
||||||
|
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||||
|
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||||
|
set ::last_header $fileheader |
||||||
|
|
||||||
|
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
||||||
|
puts "ver: $x(version)" |
||||||
|
puts "method: $x(method)" |
||||||
|
|
||||||
|
#PK\1\2 |
||||||
|
#33639248 dec = 0x02014b50 - central directory file header signature |
||||||
|
if { $x(sig) != 33639248 } { |
||||||
|
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
||||||
|
} |
||||||
|
|
||||||
|
foreach size $x(lengths) var {filename extrafield comment} { |
||||||
|
if { $size > 0 } { |
||||||
|
set x($var) [read $out $size] |
||||||
|
} else { |
||||||
|
set x($var) "" |
||||||
|
} |
||||||
|
} |
||||||
|
set next_file [tell $out] |
||||||
|
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
||||||
|
|
||||||
|
seek $out [expr {$current_file+42}] |
||||||
|
puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] |
||||||
|
|
||||||
|
#verify: |
||||||
|
flush $out |
||||||
|
seek $out $current_file |
||||||
|
set fileheader [read $out 46] |
||||||
|
lappend report "old $x(offset) + $stuboffset" |
||||||
|
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||||
|
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||||
|
lappend report "new $x(offset)" |
||||||
|
|
||||||
|
seek $out $next_file |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
close $out |
||||||
|
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
||||||
|
#don't fall over just because of that |
||||||
|
catch { |
||||||
|
punk::lib::showdict -roottype list -chan stderr $report |
||||||
|
} |
||||||
|
#puts [join $report \n] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc connect_if_not {{podpath ""}} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set podpath [::modpod::system::normalize $podpath] |
||||||
|
set docon 0 |
||||||
|
if {![llength $connected(to)]} { |
||||||
|
if {![string length $podpath]} { |
||||||
|
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
||||||
|
} else { |
||||||
|
set docon 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {![string length $podpath]} { |
||||||
|
set podpath [lindex $connected(to) end] |
||||||
|
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
||||||
|
} else { |
||||||
|
if {$podpath ni $connected(to)} { |
||||||
|
set docon 1 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {$docon} { |
||||||
|
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
||||||
|
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
||||||
|
} else { |
||||||
|
return $podpath |
||||||
|
} |
||||||
|
} |
||||||
|
#we were already connected |
||||||
|
return $podpath |
||||||
|
} |
||||||
|
|
||||||
|
proc myversion {} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set script [info script] |
||||||
|
if {![string length $script]} { |
||||||
|
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
||||||
|
} |
||||||
|
set fname [file tail [file rootname [file normalize $script]]] |
||||||
|
set scriptdir [file dirname $script] |
||||||
|
|
||||||
|
if {![string match "#modpod-*" $fname]} { |
||||||
|
lassign [lrange [split $fname -] end-1 end] _pkgname version |
||||||
|
} else { |
||||||
|
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
||||||
|
if {![string length $version]} { |
||||||
|
#try again on the name of the containing folder |
||||||
|
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
||||||
|
#todo - proper walk up the directory tree |
||||||
|
if {![string length $version]} { |
||||||
|
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
||||||
|
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
||||||
|
return $version |
||||||
|
} |
||||||
|
|
||||||
|
proc myname {} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set script [info script] |
||||||
|
if {![string length $script]} { |
||||||
|
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
||||||
|
} |
||||||
|
return $connected(fullpackage,$script) |
||||||
|
} |
||||||
|
proc myfullname {} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set script [info script] |
||||||
|
#set script [::tarjar::normalize $script] |
||||||
|
set script [file normalize $script] |
||||||
|
if {![string length $script]} { |
||||||
|
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
||||||
|
} |
||||||
|
return $::tarjar::connected(fullpackage,$script) |
||||||
|
} |
||||||
|
proc normalize {path} { |
||||||
|
#newer versions of Tcl don't do tilde sub |
||||||
|
|
||||||
|
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
||||||
|
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
||||||
|
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
||||||
|
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
||||||
|
set path [file normalize $path] |
||||||
|
#set path [string tolower $path] ;#must do this after file normalize |
||||||
|
return [string map [list $matilda ~] $path] ;#get our tildes back. |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide modpod [namespace eval modpod { |
||||||
|
variable pkg modpod |
||||||
|
variable version |
||||||
|
set version 0.1.3 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,366 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2023 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application dictn 0.1.2 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
##e.g package require frobz |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval dictn { |
||||||
|
namespace export {[a-z]*} |
||||||
|
namespace ensemble create |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
## ::dictn::append |
||||||
|
#This can of course 'ruin' a nested dict if applied to the wrong element |
||||||
|
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: |
||||||
|
# %set list {a b {c d}} |
||||||
|
# %append list x |
||||||
|
# a b {c d}x |
||||||
|
# IOW - don't do that unless you really know that's what you want. |
||||||
|
# |
||||||
|
proc ::dictn::append {dictvar path {value {}}} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict append $dictvar $path $value] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set str [dict get $dvar {*}$path] |
||||||
|
append str $val |
||||||
|
dict set dvar {*}$path $str |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::create {args} { |
||||||
|
::set data {} |
||||||
|
foreach {path val} $args { |
||||||
|
dict set data {*}$path $val |
||||||
|
} |
||||||
|
return $data |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::exists {dictval path} { |
||||||
|
return [dict exists $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::filter {dictval path filterType args} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict filter $sub $filterType {*}$args |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::for {keyvalvars dictval path body} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
dict for $keyvalvars $sub $body |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::get {dictval {path {}}} { |
||||||
|
return [dict get $dictval {*}$path] |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[info commands ::tcl::dict::getdef] ne ""} { |
||||||
|
#tcl 9+ |
||||||
|
proc ::dictn::getdef {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::getwithdefault {dictval path default} { |
||||||
|
return [dict getdef $dictval {*}$path $default] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
#tcl < 9 |
||||||
|
proc ::dictn::getdef {dictval path default} { |
||||||
|
if {[tcl::dict::exists $dictval {*}$path]} { |
||||||
|
return [tcl::dict::get $dictval {*}$path] |
||||||
|
} else { |
||||||
|
return $default |
||||||
|
} |
||||||
|
} |
||||||
|
proc ::dictn::getwithdefault {dictval path default} { |
||||||
|
if {[tcl::dict::exists $dictval {*}$path]} { |
||||||
|
return [tcl::dict::get $dictval {*}$path] |
||||||
|
} else { |
||||||
|
return $default |
||||||
|
} |
||||||
|
} |
||||||
|
proc ::dictn::incr {dictvar path {increment {}} } { |
||||||
|
if {$increment eq ""} { |
||||||
|
::set increment 1 |
||||||
|
} |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict incr $dictvar $path $increment] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
if {![::info exists dvar]} { |
||||||
|
dict set dvar {*}$path $increment |
||||||
|
} else { |
||||||
|
if {![dict exists $dvar {*}$path]} { |
||||||
|
::set val 0 |
||||||
|
} else { |
||||||
|
::set val [dict get $dvar {*}$path] |
||||||
|
} |
||||||
|
::set newval [expr {$val + $increment}] |
||||||
|
dict set dvar {*}$path $newval |
||||||
|
} |
||||||
|
return $dvar |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::info {dictval {path {}}} { |
||||||
|
if {![string length $path]} { |
||||||
|
return [dict info $dictval] |
||||||
|
} else { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
return [dict info $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::keys {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict keys $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict keys $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::lappend {dictvar path args} { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
uplevel 1 [list dict lappend $dictvar $path {*}$args] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set list [dict get $dvar {*}$path] |
||||||
|
::lappend list {*}$args |
||||||
|
dict set dvar {*}$path $list |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::merge {args} { |
||||||
|
error "nested merge not yet supported" |
||||||
|
} |
||||||
|
|
||||||
|
#dictn remove dictionaryValue ?path ...? |
||||||
|
proc ::dictn::remove {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) removals to do in a single call. |
||||||
|
|
||||||
|
foreach path $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict remove $sub [lindex $path end]] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict remove $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::replace {dictval args} { |
||||||
|
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. |
||||||
|
|
||||||
|
foreach {path val} $args { |
||||||
|
if {[llength $path] == 1} { |
||||||
|
::lappend basic $path $val |
||||||
|
} else { |
||||||
|
#extract,modify,replace |
||||||
|
::set subpath [lrange $path 0 end-1] |
||||||
|
|
||||||
|
::set sub [dict get $dictval {*}$subpath] |
||||||
|
::set sub [dict replace $sub [lindex $path end] $val] |
||||||
|
|
||||||
|
dict set dictval {*}$subpath $sub |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
if {[llength $basic]} { |
||||||
|
return [dict replace $dictval {*}$basic] |
||||||
|
} else { |
||||||
|
return $dictval |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
proc ::dictn::set {dictvar path newval} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict set dvar {*}$path $newval] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::size {dictval {path {}}} { |
||||||
|
return [dict size [dict get $dictval {*}$path]] |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::unset {dictvar path} { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
return [dict unset dvar {*}$path |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::update {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
upvar 1 $var $var |
||||||
|
if {![::info exists $var]} { |
||||||
|
uplevel 1 [list dict unset $dictvar {*}$path] |
||||||
|
} else { |
||||||
|
uplevel 1 [list dict set $dictvar {*}$path [::set $var]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
#an experiment. |
||||||
|
proc ::dictn::Applyupdate {dictvar args} { |
||||||
|
::set body [lindex $args end] |
||||||
|
::set maplist [lrange $args 0 end-1] |
||||||
|
|
||||||
|
upvar 1 $dictvar dvar |
||||||
|
|
||||||
|
::set headscript "" |
||||||
|
::set i 0 |
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path]} { |
||||||
|
#uplevel 1 [list set $var [dict get $dvar $path]] |
||||||
|
::lappend arglist $var |
||||||
|
::lappend vallist [dict get $dvar {*}$path] |
||||||
|
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] |
||||||
|
::append headscript \n |
||||||
|
::incr i |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
::set body $headscript\r\n$body |
||||||
|
|
||||||
|
puts stderr "BODY: $body" |
||||||
|
|
||||||
|
#set result [apply [list args $body] {*}$vallist] |
||||||
|
catch {apply [list args $body] {*}$vallist} result |
||||||
|
|
||||||
|
foreach {path var} $maplist { |
||||||
|
if {[dict exists $dvar {*}$path] && [::info exists $var]} { |
||||||
|
dict set dvar {*}$path [::set $var] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
proc ::dictn::values {dictval {path {}} {glob {}}} { |
||||||
|
::set sub [dict get $dictval {*}$path] |
||||||
|
if {[string length $glob]} { |
||||||
|
return [dict values $sub $glob] |
||||||
|
} else { |
||||||
|
return [dict values $sub] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# Standard form: |
||||||
|
#'dictn with dictVariable path body' |
||||||
|
# |
||||||
|
# Extended form: |
||||||
|
#'dictn with dictVariable path arrayVariable body' |
||||||
|
# |
||||||
|
proc ::dictn::with {dictvar path args} { |
||||||
|
if {[llength $args] == 1} { |
||||||
|
::set body [lindex $args 0] |
||||||
|
return [uplevel 1 [list dict with $dictvar {*}$path $body]] |
||||||
|
} else { |
||||||
|
upvar 1 $dictvar dvar |
||||||
|
::lassign $args arrayname body |
||||||
|
|
||||||
|
upvar 1 $arrayname arr |
||||||
|
array set arr [dict get $dvar {*}$path] |
||||||
|
::set prevkeys [array names arr] |
||||||
|
|
||||||
|
catch {uplevel 1 $body} result |
||||||
|
|
||||||
|
|
||||||
|
foreach k $prevkeys { |
||||||
|
if {![::info exists arr($k)]} { |
||||||
|
dict unset $dvar {*}$path $k |
||||||
|
} |
||||||
|
} |
||||||
|
foreach k [array names arr] { |
||||||
|
dict set $dvar {*}$path $k $arr($k) |
||||||
|
} |
||||||
|
|
||||||
|
return $result |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide dictn [namespace eval dictn { |
||||||
|
variable version |
||||||
|
::set version 0.1.2 |
||||||
|
}] |
||||||
|
return |
||||||
@ -0,0 +1,704 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application modpod 0.1.3 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin modpod_module_modpod 0 0.1.3] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require modpod] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of modpod |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by modpod |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require struct::set ;#review |
||||||
|
package require punk::lib |
||||||
|
package require punk::args |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6-}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval modpod::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod::class}] |
||||||
|
#[para] class definitions |
||||||
|
if {[info commands [namespace current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval modpod { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
|
||||||
|
variable connected |
||||||
|
if {![info exists connected(to)]} { |
||||||
|
set connected(to) list |
||||||
|
} |
||||||
|
variable modpodscript |
||||||
|
set modpodscript [info script] |
||||||
|
if {[string tolower [file extension $modpodscript]] eq ".tcl"} { |
||||||
|
set connected(self) [file dirname $modpodscript] |
||||||
|
} else { |
||||||
|
#expecting a .tm |
||||||
|
set connected(self) $modpodscript |
||||||
|
} |
||||||
|
variable loadables [info sharedlibextension] |
||||||
|
variable sourceables {.tcl .tk} ;# .tm ? |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod}] |
||||||
|
#[para] Core API functions for modpod |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
#old tar connect mechanism - review - not needed? |
||||||
|
proc connect {args} { |
||||||
|
puts stderr "modpod::connect--->>$args" |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
@id -id ::modpod::connect |
||||||
|
-type -default "" |
||||||
|
@values -min 1 -max 1 |
||||||
|
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
||||||
|
} $args] |
||||||
|
catch { |
||||||
|
punk::lib::showdict $argd ;#heavy dependencies |
||||||
|
} |
||||||
|
set opt_path [dict get $argd values path] |
||||||
|
variable connected |
||||||
|
set original_connectpath $opt_path |
||||||
|
set modpodpath [modpod::system::normalize $opt_path] ;# |
||||||
|
|
||||||
|
if {$modpodpath in $connected(to)} { |
||||||
|
return [dict create ok ALREADY_CONNECTED] |
||||||
|
} |
||||||
|
lappend connected(to) $modpodpath |
||||||
|
|
||||||
|
set connected(connectpath,$opt_path) $original_connectpath |
||||||
|
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] |
||||||
|
|
||||||
|
set connected(location,$modpodpath) [file dirname $modpodpath] |
||||||
|
set connected(startdata,$modpodpath) -1 |
||||||
|
set connected(type,$modpodpath) [dict get $argd opts -type] |
||||||
|
set connected(fh,$modpodpath) "" |
||||||
|
|
||||||
|
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
||||||
|
set connected(type,$modpodpath) "unwrapped" |
||||||
|
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||||
|
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
||||||
|
|
||||||
|
} else { |
||||||
|
#connect to .tm but may still be unwrapped version available |
||||||
|
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
||||||
|
set this_pkg_tm_folder [file dirname $modpodpath] |
||||||
|
if {$connected(type,$modpodpath) ne "unwrapped"} { |
||||||
|
#Not directly connected to unwrapped version - but may still be redirected there |
||||||
|
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
||||||
|
if {[file exists $unwrappedFolder]} { |
||||||
|
#folder with exact version-match must exist for redirect to 'unwrapped' |
||||||
|
set con(type,$modpodpath) "modpod-redirecting" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
||||||
|
set connected(tmfile,$modpodpath) |
||||||
|
set tail_segments [list] |
||||||
|
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
||||||
|
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||||
|
foreach lc_mpath $lcase_modulepaths { |
||||||
|
set mpath_segments [file split $lc_mpath] |
||||||
|
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||||
|
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $tail_segments]} { |
||||||
|
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
||||||
|
} else { |
||||||
|
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
||||||
|
} |
||||||
|
|
||||||
|
switch -exact -- $connected(type,$modpodpath) { |
||||||
|
"modpod-redirecting" { |
||||||
|
#redirect to the unwrapped version |
||||||
|
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
||||||
|
|
||||||
|
} |
||||||
|
"unwrapped" { |
||||||
|
if {[info commands ::thread::id] ne ""} { |
||||||
|
set from [pid],[thread::id] |
||||||
|
} else { |
||||||
|
set from [pid] |
||||||
|
} |
||||||
|
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
||||||
|
return [list ok ""] |
||||||
|
} |
||||||
|
default { |
||||||
|
#autodetect .tm - zip/tar ? |
||||||
|
#todo - use vfs ? |
||||||
|
|
||||||
|
#connect to tarball - start at 1st header |
||||||
|
set connected(startdata,$modpodpath) 0 |
||||||
|
set fh [open $modpodpath r] |
||||||
|
set connected(fh,$modpodpath) $fh |
||||||
|
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
||||||
|
|
||||||
|
if {$connected(startdata,$modpodpath) >= 0} { |
||||||
|
#verify we have a valid tar header |
||||||
|
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { |
||||||
|
seek $fh $connected(startdata,$modpodpath) start |
||||||
|
return [list ok $fh] |
||||||
|
} else { |
||||||
|
#error "cannot verify tar header" |
||||||
|
} |
||||||
|
} |
||||||
|
lpop connected(to) end |
||||||
|
set connected(startdata,$modpodpath) -1 |
||||||
|
unset connected(fh,$modpodpath) |
||||||
|
catch {close $fh} |
||||||
|
return [dict create err {Does not appear to be a valid modpod}] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
proc disconnect {{modpod ""}} { |
||||||
|
variable connected |
||||||
|
if {![llength $connected(to)]} { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {$modpod eq ""} { |
||||||
|
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
||||||
|
set modpod [lindex $connected(to) end] |
||||||
|
} |
||||||
|
|
||||||
|
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
||||||
|
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
||||||
|
return 0 |
||||||
|
} |
||||||
|
if {[string length $connected(fh,$modpod)]} { |
||||||
|
close $connected(fh,$modpod) |
||||||
|
} |
||||||
|
array unset connected *,$modpod |
||||||
|
set connected(to) [lreplace $connected(to) $posn $posn] |
||||||
|
return 1 |
||||||
|
} |
||||||
|
proc get {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
-from -default "" -help "path to pod" |
||||||
|
*values -min 1 -max 1 |
||||||
|
filename |
||||||
|
} $args] |
||||||
|
set frompod [dict get $argd opts -from] |
||||||
|
set filename [dict get $argd values filename] |
||||||
|
|
||||||
|
variable connected |
||||||
|
#//review |
||||||
|
set modpod [::modpod::system::connect_if_not $frompod] |
||||||
|
set fh $connected(fh,$modpod) |
||||||
|
if {$connected(type,$modpod) eq "unwrapped"} { |
||||||
|
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
||||||
|
if {[string range $filename 0 0 eq "/"]} { |
||||||
|
#absolute path (?) |
||||||
|
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
||||||
|
} else { |
||||||
|
#relative path - use #modpod-xxx as base |
||||||
|
set path [file join $connected(location,$modpod) $filename] |
||||||
|
} |
||||||
|
set fd [open $path r] |
||||||
|
#utf-8? |
||||||
|
#fconfigure $fd -encoding iso8859-1 -translation binary |
||||||
|
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
||||||
|
} else { |
||||||
|
#read from vfs |
||||||
|
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace modpod ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval modpod::lib { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
proc is_valid_tm_version {versionpart} { |
||||||
|
#Needs to be suitable for use with Tcl's 'package vcompare' |
||||||
|
if {![catch [list package vcompare $versionparts $versionparts]]} { |
||||||
|
return 1 |
||||||
|
} else { |
||||||
|
return 0 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#zipfile is a pure zip at this point - ie no script/exe header |
||||||
|
proc make_zip_modpod {args} { |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
@id -id ::modpod::lib::make_zip_modpod |
||||||
|
-offsettype -default "archive" -choices {archive file} -help\ |
||||||
|
"Whether zip offsets are relative to start of file or start of zip-data within the file. |
||||||
|
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, |
||||||
|
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) |
||||||
|
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. |
||||||
|
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" |
||||||
|
@values -min 2 -max 2 |
||||||
|
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
||||||
|
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" |
||||||
|
} $args] |
||||||
|
set zipfile [dict get $argd values zipfile] |
||||||
|
set outfile [dict get $argd values outfile] |
||||||
|
set opt_offsettype [dict get $argd opts -offsettype] |
||||||
|
|
||||||
|
|
||||||
|
set mount_stub [string map [list %offsettype% $opt_offsettype] { |
||||||
|
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. |
||||||
|
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. |
||||||
|
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile> |
||||||
|
if {[catch {file normalize [info script]} modfile]} { |
||||||
|
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
||||||
|
} |
||||||
|
if {$modfile eq "" || ![file exists $modfile]} { |
||||||
|
error "modpod zip stub error. Unable to determine module path" |
||||||
|
} |
||||||
|
set moddir [file dirname $modfile] |
||||||
|
set mod_and_ver [file rootname [file tail $modfile]] |
||||||
|
lassign [split $mod_and_ver -] moduletail version |
||||||
|
if {[file exists $moddir/#modpod-$mod_and_ver.tm]} { |
||||||
|
source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||||
|
} else { |
||||||
|
#determine module namespace so we can mount appropriately |
||||||
|
proc intersect {A B} { |
||||||
|
if {[llength $A] == 0} {return {}} |
||||||
|
if {[llength $B] == 0} {return {}} |
||||||
|
if {[llength $B] > [llength $A]} { |
||||||
|
set res $A |
||||||
|
set A $B |
||||||
|
set B $res |
||||||
|
} |
||||||
|
set res {} |
||||||
|
foreach x $A {set ($x) {}} |
||||||
|
foreach x $B { |
||||||
|
if {[info exists ($x)]} { |
||||||
|
lappend res $x |
||||||
|
} |
||||||
|
} |
||||||
|
return $res |
||||||
|
} |
||||||
|
set lcase_tmfile_segments [string tolower [file split $moddir]] |
||||||
|
set lcase_modulepaths [string tolower [tcl::tm::list]] |
||||||
|
foreach lc_mpath $lcase_modulepaths { |
||||||
|
set mpath_segments [file split $lc_mpath] |
||||||
|
if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
||||||
|
set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use properly cased tail |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {[llength $tail_segments]} { |
||||||
|
set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require |
||||||
|
set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver |
||||||
|
} else { |
||||||
|
set fullpackage $moduletail |
||||||
|
set mount_at #modpod/#mounted-modpod-$mod_and_ver |
||||||
|
} |
||||||
|
|
||||||
|
if {[info commands tcl::zipfs::mount] ne ""} { |
||||||
|
#argument order changed to be consistent with vfs::zip::Mount etc |
||||||
|
#early versions: zipfs::Mount mountpoint zipname |
||||||
|
#since 2023-09: zipfs::Mount zipname mountpoint |
||||||
|
#don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on windows platform for non-existance) |
||||||
|
#This is presumably related to // being interpreted as a network path |
||||||
|
set mountpoints [dict keys [tcl::zipfs::mount]] |
||||||
|
if {"//zipfs:/$mount_at" ni $mountpoints} { |
||||||
|
#despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it |
||||||
|
if {[catch { |
||||||
|
#tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) |
||||||
|
#puts "tcl::zipfs::mount $modfile $mount_at" |
||||||
|
tcl::zipfs::mount $modfile $mount_at |
||||||
|
} errM]} { |
||||||
|
#try old api |
||||||
|
if {![catch {tcl::zipfs::mount //zipfs:/$mount_at $modfile}]} { |
||||||
|
puts stderr "modpod stub>>> tcl::zipfs::mount <file> <mountpoint> failed.\nbut old api: tcl::zipfs::mount <mountpoint> <file> succeeded\n tcl::zipfs::mount //zipfs://$mount_at $modfile" |
||||||
|
puts stderr "Consider upgrading tcl runtime to one with fixed zipfs API" |
||||||
|
} |
||||||
|
} |
||||||
|
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||||
|
puts stderr "modpod stub>>> mount at //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm failed\n zipfs mounts: [zipfs mount]" |
||||||
|
#tcl::zipfs::unmount //zipfs:/$mount_at |
||||||
|
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||||
|
} |
||||||
|
} |
||||||
|
# #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form |
||||||
|
source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||||
|
} else { |
||||||
|
#fallback to slower vfs::zip |
||||||
|
#NB. We don't create the intermediate dirs - but the mount still works |
||||||
|
if {![file exists $moddir/$mount_at]} { |
||||||
|
if {[catch {package require vfs::zip} errM]} { |
||||||
|
set msg "Unable to load vfs::zip package to mount module $mod_and_ver (and zipfs not available either)" |
||||||
|
append msg \n "If neither zipfs or vfs::zip are available - the module can still be loaded by manually unzipping the file $modfile in place." |
||||||
|
append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $modfile" |
||||||
|
error $msg |
||||||
|
} else { |
||||||
|
set fd [vfs::zip::Mount $modfile $moddir/$mount_at] |
||||||
|
if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||||
|
vfs::zip::Unmount $fd $moddir/$mount_at |
||||||
|
error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||||
|
} |
||||||
|
} |
||||||
|
#zipped data follows |
||||||
|
}] |
||||||
|
#todo - test if supplied zipfile has #modpod-loadcript.tcl or some other script/executable before even creating? |
||||||
|
append mount_stub \x1A |
||||||
|
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub $opt_offsettype |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace modpod::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval modpod::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpod::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
#deflate,store only supported |
||||||
|
|
||||||
|
#zipfile here is plain zip - no script/exe prefix part. |
||||||
|
proc make_mountable_zip {zipfile outfile mount_stub {offsettype "archive"}} { |
||||||
|
set inzip [open $zipfile r] |
||||||
|
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||||
|
set out [open $outfile w+] |
||||||
|
fconfigure $out -encoding iso8859-1 -translation binary |
||||||
|
puts -nonewline $out $mount_stub |
||||||
|
set stuboffset [tell $out] |
||||||
|
lappend report "stub size: $stuboffset" |
||||||
|
fcopy $inzip $out |
||||||
|
close $inzip |
||||||
|
|
||||||
|
set size [tell $out] |
||||||
|
lappend report "modpod::system::make_mountable_zip" |
||||||
|
lappend report "tmfile : [file tail $outfile]" |
||||||
|
lappend report "output size : $size" |
||||||
|
lappend report "offsettype : $offsettype" |
||||||
|
|
||||||
|
if {$offsettype eq "file"} { |
||||||
|
#make zip offsets relative to start of whole file including prepended script. |
||||||
|
#same offset structure as Tcl's older 'zipfs mkimg' as at 2024-10 |
||||||
|
#2025 - zipfs mkimg fixed to use 'archive' offset. |
||||||
|
#not editable by 7z,nanazip,peazip |
||||||
|
|
||||||
|
#we aren't adding any new files/folders so we can edit the offsets in place |
||||||
|
|
||||||
|
#Now seek in $out to find the end of directory signature: |
||||||
|
#The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text |
||||||
|
if {$size < 65559} { |
||||||
|
set tailsearch_start 0 |
||||||
|
} else { |
||||||
|
set tailsearch_start [expr {$size - 65559}] |
||||||
|
} |
||||||
|
seek $out $tailsearch_start |
||||||
|
set data [read $out] |
||||||
|
#EOCD - End of Central Directory record |
||||||
|
#PK\5\6 |
||||||
|
set start_of_end [string last "\x50\x4b\x05\x06" $data] |
||||||
|
#set start_of_end [expr {$start_of_end + $seek}] |
||||||
|
#incr start_of_end $seek |
||||||
|
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||||
|
|
||||||
|
lappend report "kitfile-relative START-OF-EOCD: $filerelative_eocd_posn" |
||||||
|
|
||||||
|
seek $out $filerelative_eocd_posn |
||||||
|
set end_of_ctrl_dir [read $out] |
||||||
|
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||||
|
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||||
|
|
||||||
|
lappend report "End of central directory: [array get eocd]" |
||||||
|
seek $out [expr {$filerelative_eocd_posn+16}] |
||||||
|
|
||||||
|
#adjust offset of start of central directory by the length of our sfx stub |
||||||
|
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $stuboffset}]] |
||||||
|
flush $out |
||||||
|
|
||||||
|
seek $out $filerelative_eocd_posn |
||||||
|
set end_of_ctrl_dir [read $out] |
||||||
|
binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||||
|
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||||
|
|
||||||
|
# 0x06054b50 - end of central dir signature |
||||||
|
puts stderr "$end_of_ctrl_dir" |
||||||
|
puts stderr "comment_len: $eocd(comment_len)" |
||||||
|
puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" |
||||||
|
lappend report "New dir offset: $eocd(diroffset)" |
||||||
|
lappend report "Adjusting $eocd(totalnum) zip file items." |
||||||
|
catch { |
||||||
|
punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies |
||||||
|
} |
||||||
|
|
||||||
|
seek $out $eocd(diroffset) |
||||||
|
for {set i 0} {$i <$eocd(totalnum)} {incr i} { |
||||||
|
set current_file [tell $out] |
||||||
|
set fileheader [read $out 46] |
||||||
|
puts -------------- |
||||||
|
puts [ansistring VIEW -lf 1 $fileheader] |
||||||
|
puts -------------- |
||||||
|
#binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||||
|
# x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||||
|
|
||||||
|
binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||||
|
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||||
|
set ::last_header $fileheader |
||||||
|
|
||||||
|
puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" |
||||||
|
puts "ver: $x(version)" |
||||||
|
puts "method: $x(method)" |
||||||
|
|
||||||
|
#PK\1\2 |
||||||
|
#33639248 dec = 0x02014b50 - central directory file header signature |
||||||
|
if { $x(sig) != 33639248 } { |
||||||
|
error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" |
||||||
|
} |
||||||
|
|
||||||
|
foreach size $x(lengths) var {filename extrafield comment} { |
||||||
|
if { $size > 0 } { |
||||||
|
set x($var) [read $out $size] |
||||||
|
} else { |
||||||
|
set x($var) "" |
||||||
|
} |
||||||
|
} |
||||||
|
set next_file [tell $out] |
||||||
|
lappend report "file $i: $x(offset) $x(sizes) $x(filename)" |
||||||
|
|
||||||
|
seek $out [expr {$current_file+42}] |
||||||
|
puts -nonewline $out [binary format i [expr {$x(offset)+$stuboffset}]] |
||||||
|
|
||||||
|
#verify: |
||||||
|
flush $out |
||||||
|
seek $out $current_file |
||||||
|
set fileheader [read $out 46] |
||||||
|
lappend report "old $x(offset) + $stuboffset" |
||||||
|
binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ |
||||||
|
x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) |
||||||
|
lappend report "new $x(offset)" |
||||||
|
|
||||||
|
seek $out $next_file |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
close $out |
||||||
|
#pdict/showdict reuire punk & textlib - ie lots of dependencies |
||||||
|
#don't fall over just because of that |
||||||
|
catch { |
||||||
|
punk::lib::showdict -roottype list -chan stderr $report |
||||||
|
} |
||||||
|
#puts [join $report \n] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc connect_if_not {{podpath ""}} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set podpath [::modpod::system::normalize $podpath] |
||||||
|
set docon 0 |
||||||
|
if {![llength $connected(to)]} { |
||||||
|
if {![string length $podpath]} { |
||||||
|
error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" |
||||||
|
} else { |
||||||
|
set docon 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
if {![string length $podpath]} { |
||||||
|
set podpath [lindex $connected(to) end] |
||||||
|
puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" |
||||||
|
} else { |
||||||
|
if {$podpath ni $connected(to)} { |
||||||
|
set docon 1 |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
if {$docon} { |
||||||
|
if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { |
||||||
|
error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" |
||||||
|
} else { |
||||||
|
return $podpath |
||||||
|
} |
||||||
|
} |
||||||
|
#we were already connected |
||||||
|
return $podpath |
||||||
|
} |
||||||
|
|
||||||
|
proc myversion {} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set script [info script] |
||||||
|
if {![string length $script]} { |
||||||
|
error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" |
||||||
|
} |
||||||
|
set fname [file tail [file rootname [file normalize $script]]] |
||||||
|
set scriptdir [file dirname $script] |
||||||
|
|
||||||
|
if {![string match "#modpod-*" $fname]} { |
||||||
|
lassign [lrange [split $fname -] end-1 end] _pkgname version |
||||||
|
} else { |
||||||
|
lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version |
||||||
|
if {![string length $version]} { |
||||||
|
#try again on the name of the containing folder |
||||||
|
lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version |
||||||
|
#todo - proper walk up the directory tree |
||||||
|
if {![string length $version]} { |
||||||
|
#try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) |
||||||
|
lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#tarjar::Log debug "'myversion' determined version for [info script]: $version" |
||||||
|
return $version |
||||||
|
} |
||||||
|
|
||||||
|
proc myname {} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set script [info script] |
||||||
|
if {![string length $script]} { |
||||||
|
error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" |
||||||
|
} |
||||||
|
return $connected(fullpackage,$script) |
||||||
|
} |
||||||
|
proc myfullname {} { |
||||||
|
upvar ::modpod::connected connected |
||||||
|
set script [info script] |
||||||
|
#set script [::tarjar::normalize $script] |
||||||
|
set script [file normalize $script] |
||||||
|
if {![string length $script]} { |
||||||
|
error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" |
||||||
|
} |
||||||
|
return $::tarjar::connected(fullpackage,$script) |
||||||
|
} |
||||||
|
proc normalize {path} { |
||||||
|
#newer versions of Tcl don't do tilde sub |
||||||
|
|
||||||
|
#Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) |
||||||
|
# we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. |
||||||
|
set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. |
||||||
|
set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after |
||||||
|
set path [file normalize $path] |
||||||
|
#set path [string tolower $path] ;#must do this after file normalize |
||||||
|
return [string map [list $matilda ~] $path] ;#get our tildes back. |
||||||
|
} |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide modpod [namespace eval modpod { |
||||||
|
variable pkg modpod |
||||||
|
variable version |
||||||
|
set version 0.1.3 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
Loading…
Reference in new issue