40 changed files with 12544 additions and 8163 deletions
@ -0,0 +1,699 @@ |
|||||||
|
# -*- 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.2 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin modpod_module_modpod 0 0.1.2] |
||||||
|
#[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 { |
||||||
|
-type -default "" |
||||||
|
*values -min 1 -max 1 |
||||||
|
path -type string -minlen 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 { |
||||||
|
-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 -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
||||||
|
outfile -type path -minlen 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]} { |
||||||
|
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 "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 'zipfs mkimg' as at 2024-10 |
||||||
|
#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.2 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -1,3 +1,3 @@ |
|||||||
%Major.Minor.Level% |
%Major.Minor.Level% |
||||||
#First line must be a semantic version number |
#First line must be a tcl package version number |
||||||
#all other lines are ignored. |
#all other lines are ignored. |
||||||
|
|||||||
@ -0,0 +1,600 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||||
|
# |
||||||
|
# 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) CMcC 2010 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::trie 0.1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::trie 0 0.1.0] |
||||||
|
#[copyright "2010"] |
||||||
|
#[titledesc {punk::trie API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {punk::trie}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::trie] |
||||||
|
#[keywords module datastructure trie] |
||||||
|
#[description] tcl trie implementation courtesy of CmcC (tcl wiki) |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::trie |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::trie |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::trie::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::trie::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[tcl::info::commands [tcl::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 |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::trie { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
proc Dolog {lvl txt} { |
||||||
|
#return "$lvl -- $txt" |
||||||
|
#logger calls this in such a way that a straight uplevel can get us the vars/commands in messages substituted |
||||||
|
set msg "[clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] punk::trie '[uplevel [list subst $txt]]'" |
||||||
|
puts stderr $msg |
||||||
|
} |
||||||
|
package require logger |
||||||
|
logger::initNamespace ::punk::trie |
||||||
|
foreach lvl [logger::levels] { |
||||||
|
interp alias {} ::punk::trie::Log_$lvl {} ::punk::trie::Dolog $lvl |
||||||
|
log::logproc $lvl ::punk::trie::Log_$lvl |
||||||
|
} |
||||||
|
#namespace path ::punk::trie::log |
||||||
|
|
||||||
|
#[para] class definitions |
||||||
|
if {[tcl::info::commands [tcl::namespace::current]::trieclass] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
oo::class create [tcl::namespace::current]::trieclass { |
||||||
|
variable trie id |
||||||
|
|
||||||
|
method matches {t what} { |
||||||
|
#*** !doctools |
||||||
|
#[call class::trieclass [method matches] [arg t] [arg what]] |
||||||
|
#[para] search for longest prefix, return matching prefix, element and suffix |
||||||
|
|
||||||
|
set matches {} |
||||||
|
set wlen [string length $what] |
||||||
|
foreach k [lsort -decreasing -dictionary [dict keys $t]] { |
||||||
|
set klen [string length $k] |
||||||
|
set match "" |
||||||
|
for {set i 0} {$i < $klen |
||||||
|
&& $i < $wlen |
||||||
|
&& [string index $k $i] eq [string index $what $i] |
||||||
|
} {incr i} { |
||||||
|
append match [string index $k $i] |
||||||
|
} |
||||||
|
if {$match ne ""} { |
||||||
|
lappend matches $match $k |
||||||
|
} |
||||||
|
} |
||||||
|
#Debug.trie {matches: $what -> $matches} |
||||||
|
::punk::trie::log::debug {matches: $what -> $matches} |
||||||
|
|
||||||
|
if {[dict size $matches]} { |
||||||
|
# find the longest matching prefix |
||||||
|
set match [lindex [lsort -dictionary [dict keys $matches]] end] |
||||||
|
set mel [dict get $matches $match] |
||||||
|
set suffix [string range $what [string length $match] end] |
||||||
|
|
||||||
|
return [list $match $mel $suffix] |
||||||
|
} else { |
||||||
|
return {} ;# no matches |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# return next unique id if there's no proffered value |
||||||
|
method id {value} { |
||||||
|
if {$value} { |
||||||
|
return $value |
||||||
|
} else { |
||||||
|
return [incr id] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# insert an element with a given optional value into trie |
||||||
|
# along path given by $args (no need to specify) |
||||||
|
method insert {what {value 0} args} { |
||||||
|
if {[llength $args]} { |
||||||
|
set t [dict get $trie {*}$args] |
||||||
|
} else { |
||||||
|
set t $trie |
||||||
|
} |
||||||
|
|
||||||
|
if {[dict exists $t $what]} { |
||||||
|
#Debug.trie {$what is an exact match on path ($args $what)} |
||||||
|
::punk::trie::log::debug {$what is an exact match on path ($args $what)} |
||||||
|
if {[catch {dict size [dict get $trie {*}$args $what]} size]} { |
||||||
|
# the match is a leaf - we're done |
||||||
|
} else { |
||||||
|
# the match is a dict - we have to add a null |
||||||
|
dict set trie {*}$args $what "" [my id $value] |
||||||
|
} |
||||||
|
|
||||||
|
return ;# exact match - no change |
||||||
|
} |
||||||
|
|
||||||
|
# search for longest prefix |
||||||
|
set match [my matches $t $what] |
||||||
|
|
||||||
|
if {![llength $match]} { |
||||||
|
;# no matching prefix - new element |
||||||
|
#Debug.trie {no matching prefix of '$what' in $t - add it on path ($args $what)} |
||||||
|
::punk::trie::log::debug {no matching prefix of '$what' in $t add it on path ($args $what)} |
||||||
|
dict set trie {*}$args $what [my id $value] |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
lassign $match match mel suffix ;# prefix, element of match, suffix |
||||||
|
|
||||||
|
if {$match ne $mel} { |
||||||
|
# the matching element shares a prefix, but has a variant suffix |
||||||
|
# it must be split |
||||||
|
#Debug.trie {splitting '$mel' along '$match'} |
||||||
|
::punk::trie::log::debug {splitting '$mel' along '$match'} |
||||||
|
|
||||||
|
set melC [dict get $t $mel] |
||||||
|
dict unset trie {*}$args $mel |
||||||
|
dict set trie {*}$args $match [string range $mel [string length $match] end] $melC |
||||||
|
} |
||||||
|
|
||||||
|
if {[catch {dict size [dict get $trie {*}$args $match]} size]} { |
||||||
|
# the match is a leaf - must be split |
||||||
|
if {$match eq $mel} { |
||||||
|
# the matching element shares a prefix, but has a variant suffix |
||||||
|
# it must be split |
||||||
|
#Debug.trie {splitting '$mel' along '$match'} |
||||||
|
::punk::trie::log::debug {splitting '$mel' along '$match'} |
||||||
|
set melC [dict get $t $mel] |
||||||
|
dict unset trie {*}$args $mel |
||||||
|
dict set trie {*}$args $match "" $melC |
||||||
|
} |
||||||
|
#Debug.trie {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'} |
||||||
|
::punk::trie::log::debug {'$mel' is the longest prefix '$match' but was a leaf - insert '$suffix'} |
||||||
|
set melid [dict get $t $mel] |
||||||
|
dict set trie {*}$args $match $suffix [my id $value] |
||||||
|
} else { |
||||||
|
# it's a dict - keep searching |
||||||
|
#Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} |
||||||
|
::punk::trie::log::debug {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} |
||||||
|
my insert $suffix $value {*}$args $match |
||||||
|
} |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
# find a path matching an element $what |
||||||
|
# if the element's not found, return the nearest path |
||||||
|
method find_path {what args} { |
||||||
|
if {[llength $args]} { |
||||||
|
set t [dict get $trie {*}$args] |
||||||
|
} else { |
||||||
|
set t $trie |
||||||
|
} |
||||||
|
|
||||||
|
if {[dict exists $t $what]} { |
||||||
|
#Debug.trie {$what is an exact match on path ($args $what)} |
||||||
|
return [list {*}$args $what] ;# exact match - no change |
||||||
|
} |
||||||
|
|
||||||
|
# search for longest prefix |
||||||
|
set match [my matches $t $what] |
||||||
|
|
||||||
|
if {![llength $match]} { |
||||||
|
return $args |
||||||
|
} |
||||||
|
|
||||||
|
lassign $match match mel suffix ;# prefix, element of match, suffix |
||||||
|
|
||||||
|
if {$match ne $mel} { |
||||||
|
# the matching element shares a prefix, but has a variant suffix |
||||||
|
# no match |
||||||
|
return $args |
||||||
|
} |
||||||
|
|
||||||
|
if {[catch {dict size [dict get $trie {*}$args $match]} size] || $size == 0} { |
||||||
|
# got to a non-matching leaf - no match |
||||||
|
return $args |
||||||
|
} else { |
||||||
|
# it's a dict - keep searching |
||||||
|
#Debug.trie {'$mel' is the longest prefix '$match' and is a dict - search for '$suffix' on path ($args $match)} |
||||||
|
return [my find_path $suffix {*}$args $match] |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# given a trie, which may have been modified by deletion, |
||||||
|
# optimize it by removing empty nodes and coalescing singleton nodes |
||||||
|
method optimize {args} { |
||||||
|
if {[llength $args]} { |
||||||
|
set t [dict get $trie {*}$args] |
||||||
|
} else { |
||||||
|
set t $trie |
||||||
|
} |
||||||
|
|
||||||
|
if {[catch {dict size $t} size]} { |
||||||
|
#Debug.trie {optimize leaf '$t' along '$args'} |
||||||
|
::punk::trie::log::debug {optimize leaf '$t' along '$args'} |
||||||
|
# leaf - leave it |
||||||
|
} else { |
||||||
|
switch -- $size { |
||||||
|
0 { |
||||||
|
#Debug.trie {optimize empty dict ($t) along '$args'} |
||||||
|
::punk::trie::log::debug {optimize empty dict ($t) along '$args'} |
||||||
|
if {[llength $args]} { |
||||||
|
dict unset trie {*}$args |
||||||
|
} |
||||||
|
} |
||||||
|
1 { |
||||||
|
#Debug.trie {optimize singleton dict ($t) along '$args'} |
||||||
|
::punk::trie::log::debug {optimize singleton dict ($t) along '$args'} |
||||||
|
lassign $t k v |
||||||
|
if {[llength $args]} { |
||||||
|
dict unset trie {*}$args |
||||||
|
} |
||||||
|
append args $k |
||||||
|
if {[llength $v]} { |
||||||
|
dict set trie {*}$args $v |
||||||
|
} |
||||||
|
my optimize {*}$args |
||||||
|
} |
||||||
|
default { |
||||||
|
#Debug.trie {optimize dict ($t) along '$args'} |
||||||
|
::punk::trie::log::debug {optimize dict ($t) along '$args'} |
||||||
|
dict for {k v} $t { |
||||||
|
my optimize {*}$args $k |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# delete element $what from trie |
||||||
|
method delete {what} { |
||||||
|
set path [my find_path $what] |
||||||
|
if {[join $path ""] eq $what} { |
||||||
|
#Debug.trie {del '$what' along ($path) was [dict get $trie {*}$path]} |
||||||
|
if {[catch {dict size [dict get $trie {*}$path]} size]} { |
||||||
|
# got to a matching leaf - delete it |
||||||
|
dict unset trie {*}$path |
||||||
|
set path [lrange $path 0 end-1] |
||||||
|
} else { |
||||||
|
dict unset trie {*}$path "" |
||||||
|
} |
||||||
|
|
||||||
|
my optimize ;# remove empty and singleton elements |
||||||
|
} else { |
||||||
|
# nothing to delete, guess we're done |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# find the value of element $what in trie, |
||||||
|
# error if not found |
||||||
|
method find_or_error {what} { |
||||||
|
set path [my find_path $what] |
||||||
|
if {[join $path ""] eq $what} { |
||||||
|
if {[catch {dict size [dict get $trie {*}$path]} size]} { |
||||||
|
# got to a matching leaf - done |
||||||
|
return [dict get $trie {*}$path] |
||||||
|
} else { |
||||||
|
#JMN - what could be an exact match for a path, but not be in the trie itself |
||||||
|
if {[dict exists $trie {*}$path ""]} { |
||||||
|
return [dict get $trie {*}$path ""] |
||||||
|
} else { |
||||||
|
::punk::trie::log::debug {'$what' matches a path but is not a leaf} |
||||||
|
error "'$what' not found" |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
error "'$what' not found" |
||||||
|
} |
||||||
|
} |
||||||
|
#JMN - renamed original find to find_or_error |
||||||
|
#prefer not to catch on result - but test for -1 |
||||||
|
method find {what} { |
||||||
|
set path [my find_path $what] |
||||||
|
if {[join $path ""] eq $what} { |
||||||
|
#presumably we use catch and dict size to avoid llength shimmering large inner dicts to list rep |
||||||
|
if {[catch {dict size [dict get $trie {*}$path]} size]} { |
||||||
|
# got to a matching leaf - done |
||||||
|
return [dict get $trie {*}$path] |
||||||
|
} else { |
||||||
|
#JMN - what could be an exact match for a path, but not be in the trie itself |
||||||
|
if {[dict exists $trie {*}$path ""]} { |
||||||
|
return [dict get $trie {*}$path ""] |
||||||
|
} else { |
||||||
|
::punk::trie::log::debug {'$what' matches a path but is not a leaf} |
||||||
|
return -1 |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
return -1 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# dump the trie as a string |
||||||
|
method dump {} { |
||||||
|
return $trie |
||||||
|
} |
||||||
|
|
||||||
|
# return a string rep of the trie sorted in dict order |
||||||
|
method order {{t {}}} { |
||||||
|
if {![llength $t]} { |
||||||
|
set t $trie |
||||||
|
} elseif {[llength $t] == 1} { |
||||||
|
return $t |
||||||
|
} |
||||||
|
set acc {} |
||||||
|
|
||||||
|
foreach key [lsort -dictionary [dict keys $t]] { |
||||||
|
lappend acc $key [my order [dict get $t $key]] |
||||||
|
} |
||||||
|
return $acc |
||||||
|
} |
||||||
|
|
||||||
|
# return the trie as a dict of names with values |
||||||
|
method flatten {{t {}} {prefix ""}} { |
||||||
|
if {![llength $t]} { |
||||||
|
set t $trie |
||||||
|
} elseif {[llength $t] == 1} { |
||||||
|
return [list $prefix $t] |
||||||
|
} |
||||||
|
|
||||||
|
set acc {} |
||||||
|
|
||||||
|
foreach key [dict keys $t] { |
||||||
|
lappend acc {*}[my flatten [dict get $t $key] $prefix$key] |
||||||
|
} |
||||||
|
return $acc |
||||||
|
} |
||||||
|
|
||||||
|
#shortest possible string to identify an element in the trie using the same principle as tcl::prefix::match |
||||||
|
#ie if a stored word is a prefix of any other words - it must be fully specified to identify itself. |
||||||
|
#JMN - REVIEW - better algorithms? |
||||||
|
#caller having retained all members can avoid flatten call |
||||||
|
#by selecting a single 'which' known not to be in the trie (or empty string) - all idents can be returned. |
||||||
|
#when all 'which' members are in the tree - scanning stops when they're all found |
||||||
|
# - and a dict containing result and scanned keys is returned |
||||||
|
# - result contains a dict with keys for each which member |
||||||
|
# - scanned contains a dict of all words longer than our shortest which - (and a subset of words the same length) |
||||||
|
method shortest_idents {which {allmembers {}}} { |
||||||
|
set t $trie |
||||||
|
if {![llength $allmembers]} { |
||||||
|
set members [dict keys [my flatten]] |
||||||
|
} else { |
||||||
|
set members $allmembers |
||||||
|
} |
||||||
|
set len_members [lmap m $members {list [string length $m] $m}] |
||||||
|
set longestfirst [lsort -index 0 -integer -decreasing $len_members] |
||||||
|
set longestfirst [lmap v $longestfirst {lindex $v 1}] |
||||||
|
set taken [dict create] |
||||||
|
set scanned [dict create] |
||||||
|
set result [dict create] ;#words in our which list - if found |
||||||
|
foreach w $longestfirst { |
||||||
|
set path [my find_path $w] |
||||||
|
if {[dict exists $taken $w]} { |
||||||
|
#whole word - no unique prefix |
||||||
|
dict set scanned $w $w |
||||||
|
if {$w in $which} { |
||||||
|
#puts stderr "$w -> $w" |
||||||
|
dict set result $w $w |
||||||
|
if {[dict size $result] == [llength $which]} { |
||||||
|
return [dict create result $result scanned $scanned] |
||||||
|
} |
||||||
|
} |
||||||
|
continue |
||||||
|
} |
||||||
|
set acc "" |
||||||
|
foreach p [lrange $path 0 end-1] { |
||||||
|
dict set taken [append acc $p] 1 ;#no need to test first - just set even though may already be present |
||||||
|
} |
||||||
|
append acc [string index [lindex $path end] 0] |
||||||
|
dict set scanned $w $acc ;#sorted by length - so no other can have this prefix - and no longer necessary |
||||||
|
if {$w in $which} { |
||||||
|
#puts stderr "$w -> $acc" |
||||||
|
dict set result $w $acc |
||||||
|
if {[dict size $result] == [llength $which]} { |
||||||
|
return [dict create result $result scanned $scanned] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
return [dict create result $result scanned $scanned] |
||||||
|
} |
||||||
|
|
||||||
|
# overwrite the trie |
||||||
|
method set {t} { |
||||||
|
set trie $t |
||||||
|
} |
||||||
|
|
||||||
|
constructor {args} { |
||||||
|
set trie {} |
||||||
|
set id 0 |
||||||
|
foreach a $args { |
||||||
|
my insert $a |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set testlist [list blah x black blacken] |
||||||
|
proc test1 {} { |
||||||
|
#JMN |
||||||
|
#test that find_or_error of a path that isn't stored as a value returns an appropriate error |
||||||
|
#(used to report couldn't find dict key "") |
||||||
|
set t [punk::trie::trieclass new blah x black blacken] |
||||||
|
if {[catch {$t find_or_error bla} errM]} { |
||||||
|
puts stderr "should be error indicating 'bla' not found" |
||||||
|
puts stderr "err during $t find bla\n$errM" |
||||||
|
} |
||||||
|
return $t |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
# 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 ---}] |
||||||
|
} |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::trie}] |
||||||
|
#[para] Core API functions for punk::trie |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::trie ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::trie::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::trie::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 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::trie::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::trie::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::trie::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::trie [tcl::namespace::eval punk::trie { |
||||||
|
variable pkg punk::trie |
||||||
|
variable version |
||||||
|
set version 0.1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,818 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||||
|
# |
||||||
|
# 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 JMN |
||||||
|
# (C) 2009 Path Thoyts <patthyts@users.sourceforge.net> |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::zip 0.1.1 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::zip 0 0.1.1] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::zip] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::zip |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::zip |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require punk::args |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
#[item] [package {punk::args}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::zip::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[tcl::info::commands [tcl::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 |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::zip { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip}] |
||||||
|
#[para] Core API functions for punk::zip |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc Path_a_atorbelow_b {path_a path_b} { |
||||||
|
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
||||||
|
} |
||||||
|
proc Path_a_at_b {path_a path_b} { |
||||||
|
return [expr {[StripPath $path_a $path_b] eq "." }] |
||||||
|
} |
||||||
|
|
||||||
|
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
||||||
|
if {$prefix eq ""} { |
||||||
|
return $path |
||||||
|
} |
||||||
|
set pathparts [file split $path] |
||||||
|
set prefixparts [file split $prefix] |
||||||
|
if {[llength $prefixparts] >= [llength $pathparts]} { |
||||||
|
return "" |
||||||
|
} |
||||||
|
return [file join \ |
||||||
|
{*}[lrange \ |
||||||
|
$pathparts \ |
||||||
|
[llength $prefixparts] \ |
||||||
|
end]] |
||||||
|
} |
||||||
|
|
||||||
|
#StripPath - borrowed from tcllib fileutil |
||||||
|
# ::fileutil::stripPath -- |
||||||
|
# |
||||||
|
# If the specified path references/is a path in prefix (or prefix itself) it |
||||||
|
# is made relative to prefix. Otherwise it is left unchanged. |
||||||
|
# In the case of it being prefix itself the result is the string '.'. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# prefix prefix to strip from the path. |
||||||
|
# path path to modify |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# path The (possibly) modified path. |
||||||
|
|
||||||
|
if {[string equal $::tcl_platform(platform) windows]} { |
||||||
|
# Windows. While paths are stored with letter-case preserved al |
||||||
|
# comparisons have to be done case-insensitive. For reference see |
||||||
|
# SF Tcllib Bug 2499641. |
||||||
|
|
||||||
|
proc StripPath {prefix path} { |
||||||
|
# [file split] is used to generate a canonical form for both |
||||||
|
# paths, for easy comparison, and also one which is easy to modify |
||||||
|
# using list commands. |
||||||
|
|
||||||
|
set prefix [file split $prefix] |
||||||
|
set npath [file split $path] |
||||||
|
|
||||||
|
if {[string equal -nocase $prefix $npath]} { |
||||||
|
return "." |
||||||
|
} |
||||||
|
|
||||||
|
if {[string match -nocase "${prefix} *" $npath]} { |
||||||
|
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||||
|
} |
||||||
|
return $path |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc StripPath {prefix path} { |
||||||
|
# [file split] is used to generate a canonical form for both |
||||||
|
# paths, for easy comparison, and also one which is easy to modify |
||||||
|
# using list commands. |
||||||
|
|
||||||
|
set prefix [file split $prefix] |
||||||
|
set npath [file split $path] |
||||||
|
|
||||||
|
if {[string equal $prefix $npath]} { |
||||||
|
return "." |
||||||
|
} |
||||||
|
|
||||||
|
if {[string match "${prefix} *" $npath]} { |
||||||
|
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||||
|
} |
||||||
|
return $path |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc Timet_to_dos {time_t} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun Timet_to_dos] [arg time_t]] |
||||||
|
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
||||||
|
#[example { |
||||||
|
# DOS timestamps are 32 bits split into bit regions as follows: |
||||||
|
# 24 16 8 0 |
||||||
|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||||
|
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
||||||
|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||||
|
#}] |
||||||
|
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
||||||
|
scan $s {%d %d %d %d %d %d} year month day hour min sec |
||||||
|
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
||||||
|
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
||||||
|
} |
||||||
|
|
||||||
|
proc walk {args} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun walk] [arg ?options?] [arg base]] |
||||||
|
#[para] Walk a directory tree rooted at base |
||||||
|
#[para] the -excludes list can be a set of glob expressions to match against files and avoid |
||||||
|
#[para] e.g |
||||||
|
#[example { |
||||||
|
# punk::zip::walk -exclude {CVS/* *~.#*} library |
||||||
|
#}] |
||||||
|
|
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::zip::walk |
||||||
|
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
||||||
|
-subpath -default "" |
||||||
|
*values -min 1 -max -1 |
||||||
|
base |
||||||
|
fileglobs -default {*} -multiple 1 |
||||||
|
} $args] |
||||||
|
set base [dict get $argd values base] |
||||||
|
set fileglobs [dict get $argd values fileglobs] |
||||||
|
set subpath [dict get $argd opts -subpath] |
||||||
|
set excludes [dict get $argd opts -excludes] |
||||||
|
|
||||||
|
|
||||||
|
set imatch [list] |
||||||
|
foreach fg $fileglobs { |
||||||
|
lappend imatch [file join $subpath $fg] |
||||||
|
} |
||||||
|
|
||||||
|
set result {} |
||||||
|
#set imatch [file join $subpath $match] |
||||||
|
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] |
||||||
|
foreach file $files { |
||||||
|
set excluded 0 |
||||||
|
foreach glob $excludes { |
||||||
|
if {[string match $glob $file]} { |
||||||
|
set excluded 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {!$excluded} {lappend result $file} |
||||||
|
} |
||||||
|
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { |
||||||
|
set subdir_entries [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] |
||||||
|
if {[llength $subdir_entries]>0} { |
||||||
|
#NOTE: trailing slash required for entries to be recognised as 'file type' = "directory" |
||||||
|
#This is true for 2024 Tcl9 mounted zipfs at least. zip utilities such as 7zip seem(icon correct) to recognize dirs with or without trailing slash |
||||||
|
#Although there are attributes on some systems to specify if entry is a directory - it appears trailing slash should always be used for folder names. |
||||||
|
set result [list {*}$result "$dir/" {*}$subdir_entries] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
#if there is an external preamble - extract that. (if there is also an internal preamble - ignore and consider part of the archive-data) |
||||||
|
#Otherwise extract an internal preamble. |
||||||
|
#if neither - |
||||||
|
#review - reconsider auto-determination of internal vs external preamble |
||||||
|
proc extract_preamble {infile outfile_preamble {outfile_zip ""}} { |
||||||
|
set inzip [open $infile r] |
||||||
|
fconfigure $inzip -encoding iso8859-1 -translation binary |
||||||
|
if {[file exists $outfile_preamble]} { |
||||||
|
error "outfile_preamble $outfile_preamble already exists - please remove first" |
||||||
|
} |
||||||
|
if {$outfile_zip ne ""} { |
||||||
|
if {[file exists $outfile_zip] && [file size $outfile_zip]} { |
||||||
|
error "outfile_zip $outfile_zip already exists - please remove first" |
||||||
|
} |
||||||
|
} |
||||||
|
chan seek $inzip 0 end |
||||||
|
set insize [tell $inzip] ;#faster (including seeks) than calling out to filesystem using file size - but should be equivalent |
||||||
|
chan seek $inzip 0 start |
||||||
|
#only scan last 64k - cover max signature size?? review |
||||||
|
if {$insize < 65559} { |
||||||
|
set tailsearch_start 0 |
||||||
|
} else { |
||||||
|
set tailsearch_start [expr {$insize - 65559}] |
||||||
|
} |
||||||
|
chan seek $inzip $tailsearch_start start |
||||||
|
set scan [read $inzip] |
||||||
|
#EOCD - End Of Central Directory record |
||||||
|
set start_of_end [string last "\x50\x4b\x05\x06" $scan] |
||||||
|
puts stdout "==>start_of_end: $start_of_end" |
||||||
|
|
||||||
|
if {$start_of_end == -1} { |
||||||
|
#no zip eocdr - consider entire file to be the zip preamble |
||||||
|
set baseoffset $insize |
||||||
|
} else { |
||||||
|
set filerelative_eocd_posn [expr {$start_of_end + $tailsearch_start}] |
||||||
|
chan seek $inzip $filerelative_eocd_posn |
||||||
|
set cdir_record_plus [read $inzip] ;#can have trailing data |
||||||
|
binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||||
|
eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||||
|
#rule out a false positive from within a nonzip (e.g plain exe) |
||||||
|
#There exists for example a PK\5\6 in a plain tclsh, but it doesn't appear to be zip related. |
||||||
|
#It doesn't seem to occur near the end - so perhaps not an issue - but we'll do some basic checks anyway |
||||||
|
#we only support single disk - so we'll validate a bit more by requiring disknbr and ctrldirdisk to be zeros |
||||||
|
#todo - just search for Pk\5\6\0\0\0\0 in the first place? //review |
||||||
|
if {$eocd(disknbr) + $eocd(ctrldirdisk) != 0} { |
||||||
|
#review - should keep searching? |
||||||
|
#for now we assume not a zip |
||||||
|
set baseoffset $insize |
||||||
|
} else { |
||||||
|
#use the central dir size to jump back tko start of central dir |
||||||
|
#determine if diroffset is file or archive relative |
||||||
|
|
||||||
|
set filerelative_cdir_start [expr {$filerelative_eocd_posn - $eocd(dirsize)}] |
||||||
|
puts stdout "---> [read $inzip 4]" |
||||||
|
if {$filerelative_cdir_start > $eocd(diroffset)} { |
||||||
|
#'external preamble' easy case |
||||||
|
# - ie 'archive' offset - (and one of the reasons I prefer archive-offset - it makes finding the 'prefix' easier |
||||||
|
#though we are assuming zip offsets are not corrupted |
||||||
|
set baseoffset [expr {$filerelative_cdir_start - $eocd(diroffset)}] |
||||||
|
} else { |
||||||
|
#'internal preamble' hard case |
||||||
|
# - either no preamble - or offsets have been adjusted to be file relative. |
||||||
|
#we could scan from top (ugly) - and with binary prefixes we could get false positives in the data that look like PK\3\4 headers |
||||||
|
#we could either work out the format for all possible executables that could be appended (across all platforms) and understand where they end? |
||||||
|
#or we just look for the topmost PK\3\4 header pointed to by a CDR record - and assume the CDR is complete |
||||||
|
|
||||||
|
#step one - read all the CD records and find the highest pointed to local file record (which isn't necessarily the first - but should get us above most if not all of the zip data) |
||||||
|
#we can't assume they're ordered in any particular way - so we in theory have to look at them all. |
||||||
|
set baseoffset "unknown" |
||||||
|
chan seek $inzip $filerelative_cdir_start start |
||||||
|
#binary scan $cdir_record_plus issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ |
||||||
|
# eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) |
||||||
|
#load the whole central dir into cdir |
||||||
|
|
||||||
|
#todo! loop through all cdr file headers - find highest offset? |
||||||
|
#tclZipfs.c just looks at first file header in Central Directory |
||||||
|
#looking at all entries would be more robust - but we won't work harder than tclZipfs.c for now //REVIEW |
||||||
|
|
||||||
|
set cdirdata [read $inzip $eocd(dirsize)] |
||||||
|
binary scan $cdirdata issssssiiisssssii cdir(signature) cdir(_vermadeby) cdir(_verneeded) cdir(gpbitflag) cdir(compmethod) cdir(lastmodifiedtime) cdir(lastmodifieddate)\ |
||||||
|
cdir(uncompressedcrc32) cdir(compressedsize) cdir(uncompressedsize) cdir(filenamelength) cdir(extrafieldlength) cdir(filecommentlength) cdir(disknbr)\ |
||||||
|
cdir(internalfileattributes) cdir(externalfileatributes) cdir(relativeoffset) |
||||||
|
|
||||||
|
#since we're in this branch - we assume cdir(relativeoffset) is from the start of the file |
||||||
|
chan seek $inzip $cdir(relativeoffset) |
||||||
|
#let's at least check that we landed on a local file header.. |
||||||
|
set local_file_header_beginning [read $inzip 28]; #local_file_header without the file name and extra field |
||||||
|
binary scan $local_file_header_beginning isssssiiiss lfh(signature) lfh(_verneeded) lfh(gpbitflag) lfh(compmethod) lfh(lastmodifiedtime) lfh(lastmodifieddate)\ |
||||||
|
lfh(uncompressedcrc32) lfh(compressedsize) lfh(uncompressedsize) lfh(filenamelength) lfh(extrafieldlength) |
||||||
|
#dec2hex 67324752 = 4034B50 = PK\3\4 |
||||||
|
puts stdout "1st local file header sig: $lfh(signature)" |
||||||
|
if {$lfh(signature) == 67324752} { |
||||||
|
#looks like a local file header |
||||||
|
#use our cdir(relativeoffset) as the start of the zip-data (//review - possible embedded password + end marker preceeding this) |
||||||
|
set baseoffset $cdir(relativeoffset) |
||||||
|
} |
||||||
|
} |
||||||
|
puts stdout "filerel_cdirstart: $filerelative_cdir_start recorded_offset: $eocd(diroffset)" |
||||||
|
} |
||||||
|
} |
||||||
|
puts stdout "baseoffset: $baseoffset" |
||||||
|
#expect CDFH PK\1\2 |
||||||
|
#above the CD - we expect a bunch of PK\3\4 records - (possibly not all of them pointed to by the CDR) |
||||||
|
#above that we expect: *possibly* a stored password with trailing marker - then the prefixed exe/script |
||||||
|
|
||||||
|
if {![string is integer -strict $baseoffset]} { |
||||||
|
error "unable to determine zip baseoffset of file $infile" |
||||||
|
} |
||||||
|
|
||||||
|
if {$baseoffset < $insize} { |
||||||
|
set pout [open $outfile_preamble w] |
||||||
|
fconfigure $pout -encoding iso8859-1 -translation binary |
||||||
|
chan seek $inzip 0 start |
||||||
|
chan copy $inzip $pout -size $baseoffset |
||||||
|
close $pout |
||||||
|
if {$outfile_zip ne ""} { |
||||||
|
#todo - if it was internal preamble - need to adjust offsets to fix the split off zipfile |
||||||
|
set zout [open $outfile_zip w] |
||||||
|
fconfigure $zout -encoding iso8859-1 -translation binary |
||||||
|
chan copy $inzip $zout |
||||||
|
close $zout |
||||||
|
} |
||||||
|
close $inzip |
||||||
|
} else { |
||||||
|
#no valid (from our perspective) eocdr found - baseoffset has been set to insize |
||||||
|
close $inzip |
||||||
|
file copy $infile $outfile_preamble |
||||||
|
if {$outfile_zip ne ""} { |
||||||
|
#touch equiv? |
||||||
|
set fd [open $outfile_zip w] |
||||||
|
close $fd |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# Addentry - was Mkzipfile -- |
||||||
|
# |
||||||
|
# FIX ME: should handle the current offset for non-seekable channels |
||||||
|
# |
||||||
|
proc Addentry {args} { |
||||||
|
#*** !doctools |
||||||
|
#[call [fun Addentry] [arg zipchan] [arg base] [arg path] [arg ?comment?]] |
||||||
|
#[para] Add a single file to a zip archive |
||||||
|
#[para] The zipchan channel should already be open and binary. |
||||||
|
#[para] You can provide a -comment for the file. |
||||||
|
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. |
||||||
|
|
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::zip::Addentry -help "Add a single file at 'path' to open channel 'zipchan' |
||||||
|
return a central directory file record" |
||||||
|
*opts |
||||||
|
-comment -default "" -help "An optional comment specific to the added file" |
||||||
|
*values -min 3 -max 4 |
||||||
|
zipchan -help "open file descriptor with cursor at position appropriate for writing a local file header" |
||||||
|
base -help "base path for entries" |
||||||
|
path -type file -help "path of file to add" |
||||||
|
zipdataoffset -default 0 -type integer -range {0 ""} -help "offset of start of zip-data - ie length of prefixing script/exe |
||||||
|
Can be specified as zero even if a prefix exists - which would make offsets 'file relative' as opposed to 'archive relative'" |
||||||
|
} $args] |
||||||
|
|
||||||
|
set zipchan [dict get $argd values zipchan] |
||||||
|
set base [dict get $argd values base] |
||||||
|
set path [dict get $argd values path] |
||||||
|
set zipdataoffset [dict get $argd values zipdataoffset] |
||||||
|
|
||||||
|
set comment [dict get $argd opts -comment] |
||||||
|
|
||||||
|
set fullpath [file join $base $path] |
||||||
|
set mtime [Timet_to_dos [file mtime $fullpath]] |
||||||
|
set utfpath [encoding convertto utf-8 $path] |
||||||
|
set utfcomment [encoding convertto utf-8 $comment] |
||||||
|
set flags [expr {(1<<11)}] ;# utf-8 comment and path |
||||||
|
set method 0 ;# store 0, deflate 8 |
||||||
|
set attr 0 ;# text or binary (default binary) |
||||||
|
set version 20 ;# minumum version req'd to extract |
||||||
|
set extra "" |
||||||
|
set crc 0 |
||||||
|
set size 0 |
||||||
|
set csize 0 |
||||||
|
set data "" |
||||||
|
set seekable [expr {[tell $zipchan] != -1}] |
||||||
|
if {[file isdirectory $fullpath]} { |
||||||
|
set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) |
||||||
|
#set attrex 0x40000010 |
||||||
|
} elseif {[file executable $fullpath]} { |
||||||
|
set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) |
||||||
|
} else { |
||||||
|
set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) |
||||||
|
if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { |
||||||
|
set attr 1 ;# text |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[file isfile $fullpath]} { |
||||||
|
set size [file size $fullpath] |
||||||
|
if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set channeloffset [tell $zipchan] ;#position in the channel - this may include prefixing exe/zip |
||||||
|
set local [binary format a4sssiiiiss PK\03\04 \ |
||||||
|
$version $flags $method $mtime $crc $csize $size \ |
||||||
|
[string length $utfpath] [string length $extra]] |
||||||
|
append local $utfpath $extra |
||||||
|
puts -nonewline $zipchan $local |
||||||
|
|
||||||
|
if {[file isfile $fullpath]} { |
||||||
|
# If the file is under 2MB then zip in one chunk, otherwize we use |
||||||
|
# streaming to avoid requiring excess memory. This helps to prevent |
||||||
|
# storing re-compressed data that may be larger than the source when |
||||||
|
# handling PNG or JPEG or nested ZIP files. |
||||||
|
if {$size < 0x00200000} { |
||||||
|
set fin [open $fullpath rb] |
||||||
|
set data [read $fin] |
||||||
|
set crc [zlib crc32 $data] |
||||||
|
set cdata [zlib deflate $data] |
||||||
|
if {[string length $cdata] < $size} { |
||||||
|
set method 8 |
||||||
|
set data $cdata |
||||||
|
} |
||||||
|
close $fin |
||||||
|
set csize [string length $data] |
||||||
|
puts -nonewline $zipchan $data |
||||||
|
} else { |
||||||
|
set method 8 |
||||||
|
set fin [open $fullpath rb] |
||||||
|
set zlib [zlib stream deflate] |
||||||
|
while {![eof $fin]} { |
||||||
|
set data [read $fin 4096] |
||||||
|
set crc [zlib crc32 $data $crc] |
||||||
|
$zlib put $data |
||||||
|
if {[string length [set zdata [$zlib get]]]} { |
||||||
|
incr csize [string length $zdata] |
||||||
|
puts -nonewline $zipchan $zdata |
||||||
|
} |
||||||
|
} |
||||||
|
close $fin |
||||||
|
$zlib finalize |
||||||
|
set zdata [$zlib get] |
||||||
|
incr csize [string length $zdata] |
||||||
|
puts -nonewline $zipchan $zdata |
||||||
|
$zlib close |
||||||
|
} |
||||||
|
|
||||||
|
if {$seekable} { |
||||||
|
# update the header if the output is seekable |
||||||
|
set local [binary format a4sssiiii PK\03\04 \ |
||||||
|
$version $flags $method $mtime $crc $csize $size] |
||||||
|
set current [tell $zipchan] |
||||||
|
seek $zipchan $channeloffset |
||||||
|
puts -nonewline $zipchan $local |
||||||
|
seek $zipchan $current |
||||||
|
} else { |
||||||
|
# Write a data descriptor record |
||||||
|
set ddesc [binary format a4iii PK\7\8 $crc $csize $size] |
||||||
|
puts -nonewline $zipchan $ddesc |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#PK\x01\x02 Cdentral directory file header |
||||||
|
#set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 |
||||||
|
set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) |
||||||
|
|
||||||
|
set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ |
||||||
|
$version $flags $method $mtime $crc $csize $size \ |
||||||
|
[string length $utfpath] [string length $extra]\ |
||||||
|
[string length $utfcomment] 0 $attr $attrex [expr {$channeloffset - $zipdataoffset}]] ;#zipdataoffset may be zero - either because it's a pure zip, or file-based offsets desired. |
||||||
|
append hdr $utfpath $extra $utfcomment |
||||||
|
return $hdr |
||||||
|
} |
||||||
|
|
||||||
|
#### REVIEW!!! |
||||||
|
#JMN - review - this looks to be offset relative to start of file - (same as 2024 Tcl 'mkzip mkimg') |
||||||
|
# we want to enable (optionally) offsets relative to start of archive for exe/script-prefixed zips.on windows (editability with 7z,peazip) |
||||||
|
#### |
||||||
|
|
||||||
|
# zip::mkzip -- |
||||||
|
# |
||||||
|
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt |
||||||
|
# |
||||||
|
proc mkzip {args} { |
||||||
|
#todo - doctools - [arg ?globs...?] syntax? |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[call [fun mkzip] [arg ?options?] [arg filename] ] |
||||||
|
#[para] Create a zip archive in 'filename' |
||||||
|
#[para] If a file already exists, an error will be raised. |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" |
||||||
|
*opts |
||||||
|
-offsettype -default "archive" -choices {archive file} -help "zip offsets stored relative to start of entire file or relative to start of zip-archive |
||||||
|
Only relevant if the created file has a script/runtime prefix. |
||||||
|
" |
||||||
|
-return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive |
||||||
|
the option -return pretty is the default and uses the punk::lib pdict/plist system |
||||||
|
to return a formatted list for the terminal |
||||||
|
" |
||||||
|
-zipkit -default 0 -type none -help "whether to add mounting script |
||||||
|
mutually exclusive with -runtime option |
||||||
|
currently vfs::zip based - todo - autodetect zipfs/vfs with pref for zipfs |
||||||
|
" |
||||||
|
-runtime -default "" -help "specify a prefix file |
||||||
|
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir -base subdir output.zip |
||||||
|
will create a self-extracting zip archive from the subdir/ folder. |
||||||
|
Expects runtime with no existing vfs attached (review) |
||||||
|
" |
||||||
|
-comment -default "" -help "An optional comment for the archive" |
||||||
|
-directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" |
||||||
|
-base -default "" -help "The new zip archive will be rooted in this directory if provided |
||||||
|
it must be a parent of -directory or the same path as -directory" |
||||||
|
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} |
||||||
|
*values -min 1 -max -1 |
||||||
|
filename -type file -default "" -help "name of zipfile to create" |
||||||
|
globs -default {*} -multiple 1 -help "list of glob patterns to match. |
||||||
|
Only directories with matching files will be included in the archive" |
||||||
|
} $args] |
||||||
|
|
||||||
|
set filename [dict get $argd values filename] |
||||||
|
if {$filename eq ""} { |
||||||
|
error "mkzip filename cannot be empty string" |
||||||
|
} |
||||||
|
if {[regexp {[?*]} $filename]} { |
||||||
|
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name |
||||||
|
error "mkzip filename should not contain glob characters ? *" |
||||||
|
} |
||||||
|
if {[file exists $filename]} { |
||||||
|
error "mkzip filename:$filename already exists" |
||||||
|
} |
||||||
|
dict for {k v} [dict get $argd opts] { |
||||||
|
switch -- $k { |
||||||
|
-comment { |
||||||
|
dict set argd opts $k [encoding convertto utf-8 $v] |
||||||
|
} |
||||||
|
-directory - -base { |
||||||
|
dict set argd opts $k [file normalize $v] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
array set opts [dict get $argd opts] |
||||||
|
|
||||||
|
|
||||||
|
if {$opts(-directory) ne ""} { |
||||||
|
if {$opts(-base) ne ""} { |
||||||
|
#-base and -directory have been normalized already |
||||||
|
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { |
||||||
|
error "punk::zip::mkzip -base $opts(-base) must be above or the same as -directory $opts(-directory)" |
||||||
|
} |
||||||
|
set base $opts(-base) |
||||||
|
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] |
||||||
|
} else { |
||||||
|
set base $opts(-directory) |
||||||
|
set relpath "" |
||||||
|
} |
||||||
|
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] |
||||||
|
|
||||||
|
set norm_filename [file normalize $filename] |
||||||
|
set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) |
||||||
|
if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { |
||||||
|
#check that we aren't adding the zipfile to itself |
||||||
|
#REVIEW - now that we open zipfile after scanning - this isn't really a concern! |
||||||
|
#keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) |
||||||
|
#In the case of -force - we may want to delay replacement of original until scan is done? |
||||||
|
|
||||||
|
#try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each |
||||||
|
#1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths |
||||||
|
set self_globs_match 0 |
||||||
|
foreach g [dict get $argd values globs] { |
||||||
|
if {[string match $g [file tail $filename]]} { |
||||||
|
set self_globs_match 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {$self_globs_match} { |
||||||
|
#still dangerous |
||||||
|
set self_excluded 0 |
||||||
|
foreach e $opts(-exclude) { |
||||||
|
if {[string match $e [file tail $filename]]} { |
||||||
|
set self_excluded 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {!$self_excluded} { |
||||||
|
#still dangerous - likely to be in resultset - check each path |
||||||
|
#puts stderr "zip file $filename is below directory $opts(-directory)" |
||||||
|
set self_is_matched 0 |
||||||
|
set i 0 |
||||||
|
foreach p $paths { |
||||||
|
set norm_p [file normalize [file join $opts(-directory) $p]] |
||||||
|
if {[Path_a_at_b $norm_filename $norm_p]} { |
||||||
|
set self_is_matched 1 |
||||||
|
break |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
if {$self_is_matched} { |
||||||
|
puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" |
||||||
|
set paths [lremove $paths $i] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
set paths [list] |
||||||
|
set dir [pwd] |
||||||
|
if {$opts(-base) ne ""} { |
||||||
|
if {![Path_a_atorbelow_b $dir $opts(-base)]} { |
||||||
|
error "punk::zip::mkzip -base $opts(-base) must be above current directory" |
||||||
|
} |
||||||
|
set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] |
||||||
|
} else { |
||||||
|
set relpath "" |
||||||
|
} |
||||||
|
set base $opts(-base) |
||||||
|
|
||||||
|
set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] |
||||||
|
foreach m $matches { |
||||||
|
if {$m eq $filename} { |
||||||
|
#puts stderr "--> excluding $filename" |
||||||
|
continue |
||||||
|
} |
||||||
|
set isok 1 |
||||||
|
foreach e [concat $opts(-exclude) $filename] { |
||||||
|
if {[string match $e $m]} { |
||||||
|
set isok 0 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {$isok} { |
||||||
|
lappend paths [file join $relpath $m] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {![llength $paths]} { |
||||||
|
return "" |
||||||
|
} |
||||||
|
|
||||||
|
set zf [open $filename wb] |
||||||
|
if {$opts(-runtime) ne ""} { |
||||||
|
#todo - strip any existing vfs - option to merge contents.. only if zip attached? |
||||||
|
set rt [open $opts(-runtime) rb] |
||||||
|
fcopy $rt $zf |
||||||
|
close $rt |
||||||
|
} elseif {$opts(-zipkit)} { |
||||||
|
#TODO - update to zipfs ? |
||||||
|
#see modpod |
||||||
|
set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" |
||||||
|
append zkd "package require vfs::zip\n" |
||||||
|
append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" |
||||||
|
append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" |
||||||
|
append zkd " source \[file join \[info script\] main.tcl\]\n" |
||||||
|
append zkd "}\n" |
||||||
|
append zkd \x1A |
||||||
|
puts -nonewline $zf $zkd |
||||||
|
} |
||||||
|
|
||||||
|
#todo - subtract this from the endrec offset |
||||||
|
if {$opts(-offsettype) eq "archive"} { |
||||||
|
set dataStartOffset [tell $zf] ;#the overall file offset of the start of archive-data //JMN 2024 |
||||||
|
} else { |
||||||
|
set dataStartOffset 0 ;#offsets relative to file - the zipfs mkzip way :/ |
||||||
|
} |
||||||
|
|
||||||
|
set count 0 |
||||||
|
set cd "" |
||||||
|
|
||||||
|
set members [list] |
||||||
|
foreach path $paths { |
||||||
|
#puts $path |
||||||
|
lappend members $path |
||||||
|
append cd [Addentry $zf $base $path $dataStartOffset] ;#path already includes relpath |
||||||
|
incr count |
||||||
|
} |
||||||
|
set cdoffset [tell $zf] |
||||||
|
set endrec [binary format a4ssssiis PK\05\06 0 0 \ |
||||||
|
$count $count [string length $cd] $cdoffset\ |
||||||
|
[string length $opts(-comment)]] |
||||||
|
append endrec $opts(-comment) |
||||||
|
puts -nonewline $zf $cd |
||||||
|
puts -nonewline $zf $endrec |
||||||
|
close $zf |
||||||
|
|
||||||
|
set result "" |
||||||
|
switch -exact -- $opts(-return) { |
||||||
|
list { |
||||||
|
set result $members |
||||||
|
} |
||||||
|
pretty { |
||||||
|
if {[info commands showlist] ne ""} { |
||||||
|
set result [plist -channel none members] |
||||||
|
} else { |
||||||
|
set result $members |
||||||
|
} |
||||||
|
} |
||||||
|
none { |
||||||
|
set result "" |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::zip ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::zip::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip::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 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::zip::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::zip [tcl::namespace::eval punk::zip { |
||||||
|
variable pkg punk::zip |
||||||
|
variable version |
||||||
|
set version 0.1.1 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
@ -1,120 +0,0 @@ |
|||||||
# ZIP file constructor |
|
||||||
|
|
||||||
package provide zipper 0.11 |
|
||||||
|
|
||||||
namespace eval zipper { |
|
||||||
namespace export initialize addentry finalize |
|
||||||
|
|
||||||
namespace eval v { |
|
||||||
variable fd |
|
||||||
variable base |
|
||||||
variable toc |
|
||||||
} |
|
||||||
|
|
||||||
proc initialize {fd} { |
|
||||||
set v::fd $fd |
|
||||||
set v::base [tell $fd] |
|
||||||
set v::toc {} |
|
||||||
fconfigure $fd -translation binary -encoding binary |
|
||||||
} |
|
||||||
|
|
||||||
proc emit {s} { |
|
||||||
puts -nonewline $v::fd $s |
|
||||||
} |
|
||||||
|
|
||||||
proc dostime {sec} { |
|
||||||
set f [clock format $sec -format {%Y %m %d %H %M %S} -gmt 1] |
|
||||||
regsub -all { 0(\d)} $f { \1} f |
|
||||||
foreach {Y M D h m s} $f break |
|
||||||
set date [expr {(($Y-1980)<<9) | ($M<<5) | $D}] |
|
||||||
set time [expr {($h<<11) | ($m<<5) | ($s>>1)}] |
|
||||||
return [list $date $time] |
|
||||||
} |
|
||||||
|
|
||||||
proc addentry {name contents {date ""} {force 0}} { |
|
||||||
if {$date == ""} { set date [clock seconds] } |
|
||||||
foreach {date time} [dostime $date] break |
|
||||||
set flag 0 |
|
||||||
set type 0 ;# stored |
|
||||||
set fsize [string length $contents] |
|
||||||
set csize $fsize |
|
||||||
set fnlen [string length $name] |
|
||||||
|
|
||||||
if {$force > 0 && $force != [string length $contents]} { |
|
||||||
set csize $fsize |
|
||||||
set fsize $force |
|
||||||
set type 8 ;# if we're passing in compressed data, it's deflated |
|
||||||
} |
|
||||||
|
|
||||||
if {[catch { zlib crc32 $contents } crc]} { |
|
||||||
set crc 0 |
|
||||||
} elseif {$type == 0} { |
|
||||||
set cdata [zlib deflate $contents] |
|
||||||
if {[string length $cdata] < [string length $contents]} { |
|
||||||
set contents $cdata |
|
||||||
set csize [string length $cdata] |
|
||||||
set type 8 ;# deflate |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ |
|
||||||
$flag $type $time $date $crc $csize $fsize $fnlen \ |
|
||||||
{0 0 0 0} 128 [tell $v::fd]]$name" |
|
||||||
|
|
||||||
emit [binary format a2c4ssssiiiss PK {3 4 20 0} \ |
|
||||||
$flag $type $time $date $crc $csize $fsize $fnlen 0] |
|
||||||
emit $name |
|
||||||
emit $contents |
|
||||||
} |
|
||||||
|
|
||||||
proc finalize {} { |
|
||||||
set pos [tell $v::fd] |
|
||||||
|
|
||||||
set ntoc [llength $v::toc] |
|
||||||
foreach x $v::toc { emit $x } |
|
||||||
set v::toc {} |
|
||||||
|
|
||||||
set len [expr {[tell $v::fd] - $pos}] |
|
||||||
incr pos -$v::base |
|
||||||
|
|
||||||
emit [binary format a2c2ssssiis PK {5 6} 0 0 $ntoc $ntoc $len $pos 0] |
|
||||||
|
|
||||||
return $v::fd |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
if {[info exists pkgtest] && $pkgtest} { |
|
||||||
puts "no test code" |
|
||||||
} |
|
||||||
|
|
||||||
# test code below runs when this is launched as the main script |
|
||||||
if {[info exists argv0] && [string match zipper-* [file tail $argv0]]} { |
|
||||||
|
|
||||||
catch { package require zlib } |
|
||||||
|
|
||||||
zipper::initialize [open try.zip w] |
|
||||||
|
|
||||||
set dirs [list .] |
|
||||||
while {[llength $dirs] > 0} { |
|
||||||
set d [lindex $dirs 0] |
|
||||||
set dirs [lrange $dirs 1 end] |
|
||||||
foreach f [lsort [glob -nocomplain [file join $d *]]] { |
|
||||||
if {[file isfile $f]} { |
|
||||||
regsub {^\./} $f {} f |
|
||||||
set fd [open $f] |
|
||||||
fconfigure $fd -translation binary -encoding binary |
|
||||||
zipper::addentry $f [read $fd] [file mtime $f] |
|
||||||
close $fd |
|
||||||
} elseif {[file isdir $f]} { |
|
||||||
lappend dirs $f |
|
||||||
} |
|
||||||
} |
|
||||||
} |
|
||||||
|
|
||||||
close [zipper::finalize] |
|
||||||
|
|
||||||
puts "size = [file size try.zip]" |
|
||||||
puts [exec unzip -v try.zip] |
|
||||||
|
|
||||||
file delete try.zip |
|
||||||
} |
|
||||||
@ -0,0 +1,196 @@ |
|||||||
|
# ZIP file constructor |
||||||
|
|
||||||
|
package provide zipper 999999.0a1.0 |
||||||
|
|
||||||
|
namespace eval zipper { |
||||||
|
namespace export initialize addentry adddir finalize |
||||||
|
|
||||||
|
namespace eval v { |
||||||
|
variable fd |
||||||
|
variable base |
||||||
|
variable toc |
||||||
|
} |
||||||
|
|
||||||
|
#if we initialize before writing anything to fd - our base is the file base |
||||||
|
# - ie we get an 'internal preamble' |
||||||
|
#if instead, we write data to fd before initialize, our base is the start of the archive-data. |
||||||
|
# - ie we get an 'external preamble' |
||||||
|
#Either way can work - but some zip utilities expect the base to always be the start of the file, |
||||||
|
#others are able to process the external preamble. |
||||||
|
#If the filename has the .zip extension - there should be no external preamble |
||||||
|
#(utils may follow a different codepath for files with different extensions) |
||||||
|
# |
||||||
|
#It seems to be ok either way for reading - but some tools cannot write to file based offset if there is prefix data |
||||||
|
#(e.g file.kit with offset adjusted with something like zip -A which makes the preamble internal to the zip) |
||||||
|
# and some cannot write to archive-based offset if there is prefix data ! |
||||||
|
#(e.g file.kit with preamble prepended and offsets not adjusted = external preamble) |
||||||
|
# |
||||||
|
#Some tools may auto-adjust to file-based offset when adding entries (e.g pkzip if extension is .zip) |
||||||
|
|
||||||
|
proc initialize {fd} { |
||||||
|
set v::fd $fd |
||||||
|
set v::base [tell $fd] |
||||||
|
set v::toc {} |
||||||
|
#fconfigure $fd -translation binary -encoding binary |
||||||
|
fconfigure $fd -translation binary -encoding iso8859-1 |
||||||
|
} |
||||||
|
|
||||||
|
proc emit {s} { |
||||||
|
puts -nonewline $v::fd $s |
||||||
|
} |
||||||
|
|
||||||
|
proc dostime {sec {gmt 0}} { |
||||||
|
set f [clock format $sec -format {%Y %m %d %H %M %S} -gmt $gmt] |
||||||
|
regsub -all { 0(\d)} $f { \1} f |
||||||
|
foreach {Y M D h m s} $f break |
||||||
|
set date [expr {(($Y-1980)<<9) | ($M<<5) | $D}] |
||||||
|
set time [expr {($h<<11) | ($m<<5) | ($s>>1)}] |
||||||
|
return [list $date $time] |
||||||
|
} |
||||||
|
|
||||||
|
proc addentry {name contents {unixmtime ""} {force 0}} { |
||||||
|
if {$unixmtime == ""} { set unixmtime [clock seconds] } |
||||||
|
#lassign [dostime $date 1] date time ;#UTC would probably be more sensible - but convention seems to be localtime :/ |
||||||
|
lassign [dostime $unixmtime 0] date time |
||||||
|
set flag 0 |
||||||
|
set type 0 ;# stored |
||||||
|
set fsize [string length $contents] |
||||||
|
set csize $fsize |
||||||
|
set fnlen [string length $name] |
||||||
|
|
||||||
|
if {$force > 0 && $force != [string length $contents]} { |
||||||
|
set csize $fsize |
||||||
|
set fsize $force |
||||||
|
set type 8 ;# if we're passing in compressed data, it's deflated |
||||||
|
} |
||||||
|
|
||||||
|
if {[catch { zlib crc32 $contents } crc]} { |
||||||
|
set crc 0 |
||||||
|
} elseif {$type == 0} { |
||||||
|
set cdata [zlib deflate $contents] |
||||||
|
if {[string length $cdata] < [string length $contents]} { |
||||||
|
set contents $cdata |
||||||
|
set csize [string length $cdata] |
||||||
|
set type 8 ;# deflate |
||||||
|
} |
||||||
|
} |
||||||
|
#we are at the position to write a *local* file header (record including file data, and often with some duplication of data in corresponding CDR 'file header' - prior to CDR records) |
||||||
|
#use the position to calculate the offset for the corresponding CDR file header |
||||||
|
# -- --- --- --- --- --- --- |
||||||
|
set local_file_relative_offset [expr {[tell $v::fd] -$v::base}] |
||||||
|
#toc / File header within Central directory structure |
||||||
|
#PK\1\2 - 0x02014b50 |
||||||
|
#lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ |
||||||
|
# $flag $type $time $date $crc $csize $fsize $fnlen \ |
||||||
|
# {0 0 0 0} 128 [tell $v::fd]]$name" |
||||||
|
#build the CDR file header - but we don't add it here |
||||||
|
set do_extended_timestamp 1 |
||||||
|
if {!$do_extended_timestamp} { |
||||||
|
lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ |
||||||
|
$flag $type $time $date $crc $csize $fsize $fnlen \ |
||||||
|
{0 0 0 0} 128 $local_file_relative_offset]$name" |
||||||
|
} else { |
||||||
|
set extra "" |
||||||
|
# --- |
||||||
|
# Value Size Description |
||||||
|
# ----- ---- ----------- |
||||||
|
#(time) 0x5455 Short tag for this extra block type ("UT") |
||||||
|
# TSize Short total data size for this block |
||||||
|
# Flags Byte info bits (refers to local header!) |
||||||
|
# (ModTime) Long time of last modification (UTC/GMT) |
||||||
|
# --- |
||||||
|
# - Tsize = 9 - 4 = 5 |
||||||
|
set extended_timestamp [binary format a2sci UT 5 0 $unixmtime] |
||||||
|
append extra $extended_timestamp |
||||||
|
# --- |
||||||
|
|
||||||
|
set extralen [string length $extra] |
||||||
|
lappend v::toc "[binary format a2c6ssssiiisss3ii PK {1 2 20 0 20 0} \ |
||||||
|
$flag $type $time $date $crc $csize $fsize $fnlen \ |
||||||
|
$extralen {0 0 0} 128 $local_file_relative_offset]$name$extra" |
||||||
|
} |
||||||
|
# -- --- --- --- --- --- --- |
||||||
|
|
||||||
|
#*Local* File Header PK\3\4 = 0x04034b50 (this is outside of and prior to CDR) |
||||||
|
emit [binary format a2c4ssssiiiss PK {3 4 20 0} \ |
||||||
|
$flag $type $time $date $crc $csize $fsize $fnlen 0] |
||||||
|
emit $name |
||||||
|
emit $contents |
||||||
|
} |
||||||
|
|
||||||
|
proc adddir {name {date ""} {force 0}} { |
||||||
|
set name "${name}/" |
||||||
|
if {$date == ""} { set date [clock seconds] } |
||||||
|
lassign [dostime $date 0] date time |
||||||
|
set flag 0 |
||||||
|
set type 0 ;# stored |
||||||
|
set fsize 0 |
||||||
|
set csize 0 |
||||||
|
set fnlen [string length $name] |
||||||
|
|
||||||
|
set crc 0 |
||||||
|
|
||||||
|
lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ |
||||||
|
$flag $type $time $date $crc $csize $fsize $fnlen \ |
||||||
|
{0 0 0 0} 128 [tell $v::fd]]$name" |
||||||
|
|
||||||
|
emit [binary format a2c4ssssiiiss PK {3 4 20 0} \ |
||||||
|
$flag $type $time $date $crc $csize $fsize $fnlen 0] |
||||||
|
emit $name |
||||||
|
} |
||||||
|
|
||||||
|
proc finalize {} { |
||||||
|
set cd_start_pos [tell $v::fd] |
||||||
|
|
||||||
|
set ntoc [llength $v::toc] |
||||||
|
foreach x $v::toc { emit $x } |
||||||
|
set v::toc {} |
||||||
|
|
||||||
|
set cd_end_pos [tell $v::fd] |
||||||
|
|
||||||
|
set len [expr {$cd_end_pos - $cd_start_pos}] |
||||||
|
#incr pos -$v::base |
||||||
|
set cdr_offset_pos [expr $cd_start_pos -$v::base] ;#review |
||||||
|
#EOCD signature PK\5\6 = 0x06054b50 |
||||||
|
emit [binary format a2c2ssssiis PK {5 6} 0 0 $ntoc $ntoc $len $cdr_offset_pos 0] |
||||||
|
|
||||||
|
return $v::fd |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[info exists pkgtest] && $pkgtest} { |
||||||
|
puts "no test code" |
||||||
|
} |
||||||
|
|
||||||
|
# test code below runs when this is launched as the main script |
||||||
|
if {[info exists argv0] && [string match zipper-* [file tail $argv0]]} { |
||||||
|
|
||||||
|
#2024 - zlib should generally be builtin.. |
||||||
|
catch { package require zlib } |
||||||
|
|
||||||
|
zipper::initialize [open try.zip w] |
||||||
|
|
||||||
|
set dirs [list .] |
||||||
|
while {[llength $dirs] > 0} { |
||||||
|
set d [lindex $dirs 0] |
||||||
|
set dirs [lrange $dirs 1 end] |
||||||
|
foreach f [lsort [glob -nocomplain [file join $d *]]] { |
||||||
|
if {[file isfile $f]} { |
||||||
|
regsub {^\./} $f {} f |
||||||
|
set fd [open $f] |
||||||
|
fconfigure $fd -translation binary -encoding binary |
||||||
|
zipper::addentry $f [read $fd] [file mtime $f] |
||||||
|
close $fd |
||||||
|
} elseif {[file isdir $f]} { |
||||||
|
lappend dirs $f |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
close [zipper::finalize] |
||||||
|
|
||||||
|
puts "size = [file size try.zip]" |
||||||
|
puts [exec unzip -v try.zip] |
||||||
|
|
||||||
|
file delete try.zip |
||||||
|
} |
||||||
@ -1,3 +1,3 @@ |
|||||||
0.1.0 |
0.1.0 |
||||||
#First line must be a semantic version number |
#First line must be a tm version number |
||||||
#all other lines are ignored. |
#all other lines are ignored. |
||||||
|
|||||||
@ -1,3 +1,3 @@ |
|||||||
0.1.0 |
0.1.0 |
||||||
#First line must be a semantic version number |
#First line must be a tm version number |
||||||
#all other lines are ignored. |
#all other lines are ignored. |
||||||
|
|||||||
@ -1,3 +1,3 @@ |
|||||||
%Major.Minor.Level% |
%Major.Minor.Level% |
||||||
#First line must be a semantic version number |
#First line must be a tcl package version number |
||||||
#all other lines are ignored. |
#all other lines are ignored. |
||||||
|
|||||||
@ -1,3 +1,3 @@ |
|||||||
0.1.0 |
0.1.1 |
||||||
#First line must be a semantic version number |
#First line must be a semantic version number |
||||||
#all other lines are ignored. |
#all other lines are ignored. |
||||||
|
|||||||
@ -1,3 +1,3 @@ |
|||||||
0.1.1 |
0.1.2 |
||||||
#First line must be a semantic version number |
#First line must be a semantic version number |
||||||
#all other lines are ignored. |
#all other lines are ignored. |
||||||
|
|||||||
@ -0,0 +1,3 @@ |
|||||||
|
0.12 |
||||||
|
#First line must be a tm version number |
||||||
|
#all other lines are ignored. |
||||||
@ -0,0 +1,567 @@ |
|||||||
|
# -*- 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 fauxlink 0.1.1 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license MIT |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin fauxlink_module_fauxlink 0 0.1.1] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {faux link application shortcuts}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {fauxlink .fxlnk}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require fauxlink] |
||||||
|
#[keywords symlink faux fake shortcut toml] |
||||||
|
#[description] |
||||||
|
#[para] A cross platform shortcut/symlink alternative. |
||||||
|
#[para] Unapologetically ugly - but practical in certain circumstances. |
||||||
|
#[para] A solution is required for application-driven filesystem links that survives cross platform moves as well as |
||||||
|
#[para] archiving and packaging systems. |
||||||
|
#[para] The target is specified in a minimally-encoded form in the filename itself - but still human readable. |
||||||
|
#[para] format of name <nominalname>#<encodedtarget>.fxlnk |
||||||
|
#[para] where <nominalname> can be empty - then the effective nominal name is the tail of the <encodedtarget> |
||||||
|
#[para] The + symbol substitutes for forward-slashes. |
||||||
|
#[para] Other chars can be encoded using url-like encoding - (but only up to %7E !) |
||||||
|
#[para] We deliberately treat higher % sequences literally. |
||||||
|
#[para] This means actual uri::urn encoded unicode sequences (e.g %E2%99%A5 [heart]) can remain literal for linking to urls. |
||||||
|
#[para] e.g if an actual + or # is required in a filename or path segment they can be encoded as %2B & %23 |
||||||
|
#[para] e.g a link to a file file#A.txt in parent dir could be: |
||||||
|
#[para] file%23A.txt#..+file%23A.txt.fxlnk |
||||||
|
#[para] or equivalently (but obviously affecting sorting) #..+file%23A.txt.fxlnk |
||||||
|
#[para] The <nominalname> can be unrelated to the actual target |
||||||
|
#[para] e.g datafile.dat#..+file%23A.txt.fxlnk |
||||||
|
#[para] This system has no filesystem support - and must be completely application driven. |
||||||
|
#[para] This can be useful for example in application test packages which may be tarred or zipped and moved cross platform. |
||||||
|
#[para] The target being fully specified in the name means the file doesn't have to be read for the target to be determined |
||||||
|
#[para] Extensions to behaviour should be added in the file as text data in Toml format, |
||||||
|
#[para] with custom data being under a single application-chosen table name |
||||||
|
#[para] The toplevel Toml table [fauxlink] is reserved for core extensions to this system. |
||||||
|
#[para] Aside from the 2 used for delimiting (+ #) |
||||||
|
#[para] certain characters which might normally be allowed in filesystems are required to be encoded |
||||||
|
#[para] e.g space and tab are required to be %20 %09 |
||||||
|
#[para] Others that require encoding are: * ? \ / | : ; " < > |
||||||
|
#[para] The nul character in raw form, when detected, is always mapped away to the empty string - as very few filesystems support it. |
||||||
|
#[para] Control characters and other punctuation is optional to encode. |
||||||
|
#[para] Generally utf-8 should be used where possible and unicode characters can often be left unencoded on modern systems. |
||||||
|
#[para] Where encoding of unicode is desired in the nominalname,encodedtarget,tag or comment portions it can be specified as %UXXXXXXXX |
||||||
|
#[para] There must be between 1 and 8 X digits following the %U. Interpretation of chars following %U stops at the first non-hex character. |
||||||
|
#[para] This means %Utest would not get any translation as there were no hex digits so it would come out as %Utest |
||||||
|
# |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#https://learn.microsoft.com/en-us/troubleshoot/windows-client/networking/url-encoding-unc-paths-not-url-decoded |
||||||
|
# ie "//server/c/Program files" works but "//server/c/Program%20Files" is now treated by windows as a literal path with %20 in it. |
||||||
|
#Using fauxlink - a link would be: |
||||||
|
# "my-program-files#++server+c+Program%20Files.fxlnk" |
||||||
|
#If we needed the old-style literal %20 it would become |
||||||
|
# "my-program-files#++server+c+Program%2520Files.fxlnk" |
||||||
|
# |
||||||
|
# The file:// scheme on windows supposedly *does* decode %xx (for use in a browser) |
||||||
|
# e.g |
||||||
|
# pfiles#file%3a++++localhost+c+Program%2520files |
||||||
|
# The browser will work with literal spaces too though - so it could just as well be: |
||||||
|
# pfiles#file%3a++++localhost+c+Program%20files |
||||||
|
#windows may default to using explorer.exe instead of a browser for file:// urls though |
||||||
|
#and explorer doesn't want the literal %20. It probably depends what API the file:// url is to be passed to? |
||||||
|
#in a .url shortcut either literal space or %20 will work ie %xx values are decoded |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of fauxlink |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by fauxlink |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6-}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::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 fauxlink { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
|
||||||
|
#todo - enforce utf-8 |
||||||
|
|
||||||
|
#literal unicode chars supported by modern filesystems - leave as is - REVIEW |
||||||
|
|
||||||
|
|
||||||
|
variable encode_map |
||||||
|
variable decode_map |
||||||
|
#most filesystems don't allow NULL - map to empty string |
||||||
|
|
||||||
|
#Make sure % is not in encode_map |
||||||
|
set encode_map [dict create\ |
||||||
|
\x00 ""\ |
||||||
|
{ } %20\ |
||||||
|
\t %09\ |
||||||
|
+ %2B\ |
||||||
|
# %23\ |
||||||
|
* %2A\ |
||||||
|
? %3F\ |
||||||
|
\\ %5C\ |
||||||
|
/ %2F\ |
||||||
|
| %7C\ |
||||||
|
: %3A\ |
||||||
|
{;} %3B\ |
||||||
|
{"} %22\ |
||||||
|
< %3C\ |
||||||
|
> %3E\ |
||||||
|
] |
||||||
|
#above have some overlap with ctrl codes below. |
||||||
|
#no big deal as it's a dict |
||||||
|
|
||||||
|
#must_encode |
||||||
|
# + # * ? \ / | : ; " < > <sp> \t |
||||||
|
# also NUL to empty string |
||||||
|
|
||||||
|
# also ctrl chars 01 to 1F (1..31) |
||||||
|
for {set i 1} {$i < 32} {incr i} { |
||||||
|
set ch [format %c $i] |
||||||
|
set enc "%[format %02X $i]" |
||||||
|
set enc_lower [string tolower $enc] |
||||||
|
dict set encode_map $ch $enc |
||||||
|
dict set decode_map $enc $ch |
||||||
|
dict set decode_map $enc_lower $ch |
||||||
|
} |
||||||
|
|
||||||
|
variable must_encode |
||||||
|
set must_encode [dict keys $encode_map] |
||||||
|
|
||||||
|
|
||||||
|
#if they are in |
||||||
|
|
||||||
|
#decode map doesn't include |
||||||
|
# %00 (nul) |
||||||
|
# %2F "/" |
||||||
|
# %2f "/" |
||||||
|
# %7f (del) |
||||||
|
#we exlude the forward slash because we already have + for that - and multiple ways to specify it obscure intention. |
||||||
|
# |
||||||
|
set decode_map [dict merge $decode_map [dict create\ |
||||||
|
%09 \t\ |
||||||
|
%20 { }\ |
||||||
|
%21 "!"\ |
||||||
|
%22 {"}\ |
||||||
|
%23 "#"\ |
||||||
|
%24 "$"\ |
||||||
|
%25 "%"\ |
||||||
|
%26 "&"\ |
||||||
|
%27 "'"\ |
||||||
|
%28 "("\ |
||||||
|
%29 ")"\ |
||||||
|
%2A "*"\ |
||||||
|
%2a "*"\ |
||||||
|
%2B "+"\ |
||||||
|
%2b "+"\ |
||||||
|
%2C ","\ |
||||||
|
%2c ","\ |
||||||
|
%2D "-"\ |
||||||
|
%2d "-"\ |
||||||
|
%2E "."\ |
||||||
|
%2e "."\ |
||||||
|
%3A ":"\ |
||||||
|
%3a ":"\ |
||||||
|
%3B {;}\ |
||||||
|
%3b {;}\ |
||||||
|
%3D "="\ |
||||||
|
%3C "<"\ |
||||||
|
%3c "<"\ |
||||||
|
%3d "="\ |
||||||
|
%3E ">"\ |
||||||
|
%3e ">"\ |
||||||
|
%3F "?"\ |
||||||
|
%3f "?"\ |
||||||
|
%40 "@"\ |
||||||
|
%5B "\["\ |
||||||
|
%5b "\["\ |
||||||
|
%5C "\\"\ |
||||||
|
%5c "\\"\ |
||||||
|
%5D "\]"\ |
||||||
|
%5d "\]"\ |
||||||
|
%5E "^"\ |
||||||
|
%5e "^"\ |
||||||
|
%60 "`"\ |
||||||
|
%7B "{"\ |
||||||
|
%7b "{"\ |
||||||
|
%7C "|"\ |
||||||
|
%7c "|"\ |
||||||
|
%7D "}"\ |
||||||
|
%7d "}"\ |
||||||
|
%7E "~"\ |
||||||
|
%7e "~"\ |
||||||
|
]] |
||||||
|
#Don't go above 7f |
||||||
|
#if we want to specify p |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink}] |
||||||
|
#[para] Core API functions for fauxlink |
||||||
|
#[list_begin definitions] |
||||||
|
proc Segment_mustencode_check {str} { |
||||||
|
variable decode_map |
||||||
|
variable encode_map ;#must_encode |
||||||
|
set idx 0 |
||||||
|
set err "" |
||||||
|
foreach ch [split $str ""] { |
||||||
|
if {[dict exists $encode_map $ch]} { |
||||||
|
set enc [dict get $encode_map $ch] |
||||||
|
if {[dict exists $decode_map $enc]} { |
||||||
|
append err " char $idx should be encoded as $enc" \n |
||||||
|
} else { |
||||||
|
append err " no %xx encoding available. Use %UXX if really required" \n |
||||||
|
} |
||||||
|
} |
||||||
|
incr idx |
||||||
|
} |
||||||
|
return $err ;#empty string if ok |
||||||
|
} |
||||||
|
|
||||||
|
proc resolve {link} { |
||||||
|
variable decode_map |
||||||
|
variable encode_map |
||||||
|
variable must_encode |
||||||
|
set ftail [file tail $link] |
||||||
|
set extension_name [string range [file extension $ftail] 1 end] |
||||||
|
if {$extension_name ni [list fxlnk fauxlink]} { |
||||||
|
set is_fauxlink 0 |
||||||
|
#we'll process anyway - but return the result wrapped |
||||||
|
#This should allow deliberate erroring for the calling dict user if the extension difference is inadvertent |
||||||
|
#(e.g blindly processing all files in a folder that is normally only .fxlnk files - but then something added that happens |
||||||
|
# to have # characters in it) |
||||||
|
#It also means if someone really wants to use the fauxlink semantics on a different file type |
||||||
|
# - they can - but just have to access the results differently and take that (minor) risk. |
||||||
|
#error "fauxlink::resolve refusing to process link $link - file extension must be .fxlnk or .fauxlink" |
||||||
|
set err_extra "\nnonstandard extension '$extension_name' for fauxlink. Check that the call to fauxlink::resolve was deliberate" |
||||||
|
} else { |
||||||
|
set is_fauxlink 1 |
||||||
|
set err_extra "" |
||||||
|
} |
||||||
|
set linkspec [file rootname $ftail] |
||||||
|
# - any # or + within the target path or name should have been uri encoded as %23 and %2b |
||||||
|
if {[tcl::string::first # $linkspec] < 0} { |
||||||
|
set err "fauxlink::resolve '$link'. Link must contain a # (usually at start if name matches target)" |
||||||
|
append err $err_extra |
||||||
|
error $err |
||||||
|
} |
||||||
|
#The 1st 2 parts of split on # are name and target file/dir |
||||||
|
#If there are only 3 parts the 3rd part is a comment and there are no 'tags' |
||||||
|
#if there are 4 parts - the 3rd part is a tagset where each tag begins with @ |
||||||
|
#and each subsequent part is a comment. Empty comments are stripped from the comments list |
||||||
|
#A tagset can be empty - but if it's not empty it must contain at least one @ and must start with @ |
||||||
|
#e.g name.txt#path#@tag1@tag2#test###.fxlnk |
||||||
|
#has a name, a target, 2 tags and one comment |
||||||
|
|
||||||
|
#check namespec already has required chars encoded |
||||||
|
set segments [split $linkspec #] |
||||||
|
lassign $segments namespec targetspec |
||||||
|
#puts stderr "-->namespec $namespec" |
||||||
|
set nametest [tcl::string::map $encode_map $namespec] |
||||||
|
#puts stderr "-->nametest $nametest" |
||||||
|
#nothing should be changed - if there are unencoded chars that must be encoded it is an error |
||||||
|
if {[tcl::string::length $nametest] ne [tcl::string::length $namespec]} { |
||||||
|
set err "fauxlink::resolve '$link' invalid chars in name part (section prior to first #)" |
||||||
|
append err [Segment_mustencode_check $namespec] |
||||||
|
append err $err_extra |
||||||
|
error $err |
||||||
|
} |
||||||
|
#see comments below regarding 2 rounds and ordering. |
||||||
|
set name [decode_unicode_escapes $namespec] |
||||||
|
set name [tcl::string::map $decode_map $name] |
||||||
|
#puts stderr "-->name: $name" |
||||||
|
|
||||||
|
set targetsegment [split $targetspec +] |
||||||
|
#check each + delimited part of targetspec already has required chars encoded |
||||||
|
set pp 0 ;#pathpart index |
||||||
|
set targetpath_parts [list] |
||||||
|
foreach pathpart $targetsegment { |
||||||
|
set targettest [tcl::string::map $encode_map $pathpart] |
||||||
|
if {[tcl::string::length $targettest] ne [tcl::string::length $pathpart]} { |
||||||
|
set err "fauxlink::resolve '$link' invalid chars in targetpath (section following first #)" |
||||||
|
append err [Segment_mustencode_check $pathpart] |
||||||
|
append err $err_extra |
||||||
|
error $err |
||||||
|
} |
||||||
|
#2 rounds of substitution is possibly asking for trouble.. |
||||||
|
#We allow anything in the resultant segments anyway (as %UXXXX... allows all) |
||||||
|
#so it's not so much about what can be encoded, |
||||||
|
# - but it makes it harder to reason about for users |
||||||
|
# In particular - if we map %XX first it makes %25 -> % substitution tricky |
||||||
|
# if the user requires a literal %UXXX - they can't do %25UXXX |
||||||
|
# the double sub would make it %UXXX -> somechar anyway. |
||||||
|
#we do unicode first - as a 2nd round of %XX substitutions is unlikely to interfere. |
||||||
|
#There is still the opportunity to use things like %U00000025 followed by hex-chars |
||||||
|
# and get some minor surprises, but using %U on ascii is unlikely to be done accidentally - REVIEW |
||||||
|
set pathpart [decode_unicode_escapes $pathpart] |
||||||
|
set pathpart [tcl::string::map $decode_map $pathpart] |
||||||
|
lappend targetpath_parts $pathpart |
||||||
|
|
||||||
|
incr pp |
||||||
|
} |
||||||
|
set targetpath [join $targetpath_parts /] |
||||||
|
if {$name eq ""} { |
||||||
|
set name [lindex $targetpath_parts end] |
||||||
|
} |
||||||
|
#we do the same encoding checks on tags and comments to increase chances of portability |
||||||
|
set tags [list] |
||||||
|
set comments [list] |
||||||
|
switch -- [llength $segments] { |
||||||
|
2 { |
||||||
|
#no tags or comments |
||||||
|
} |
||||||
|
3 { |
||||||
|
#only 3 sections - last is comment - even if looks like tags |
||||||
|
#to make the 3rd part a tagset, an extra # would be needed |
||||||
|
set comments [list [lindex $segments 2]] |
||||||
|
} |
||||||
|
default { |
||||||
|
set tagset [lindex $segments 2] |
||||||
|
if {$tagset eq ""} { |
||||||
|
#ok - no tags |
||||||
|
} else { |
||||||
|
if {[string first @ $tagset] != 0} { |
||||||
|
set err "fauxlink::resolve '$link' invalid tagset in 3rd #-delimited segment" |
||||||
|
append err \n " - must begin with @" |
||||||
|
append err $err_extra |
||||||
|
error $err |
||||||
|
} else { |
||||||
|
set tagset [string range $tagset 1 end] |
||||||
|
set rawtags [split $tagset @] |
||||||
|
set tags [list] |
||||||
|
foreach t $rawtags { |
||||||
|
if {$t eq ""} { |
||||||
|
lappend tags "" |
||||||
|
} else { |
||||||
|
set tagtest [tcl::string::map $encode_map $t] |
||||||
|
if {[tcl::string::length $tagtest] ne [tcl::string::length $t]} { |
||||||
|
set err "fauxlink::resolve '$link' invalid chars in tag [llength $tags]" |
||||||
|
append err [Segment_mustencode_check $t] |
||||||
|
append err $err_extra |
||||||
|
error $err |
||||||
|
} |
||||||
|
lappend tags [tcl::string::map $decode_map [decode_unicode_escapes $t]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
set rawcomments [lrange $segments 3 end] |
||||||
|
#set comments [lsearch -all -inline -not $comments ""] |
||||||
|
set comments [list] |
||||||
|
foreach c $rawcomments { |
||||||
|
if {$c eq ""} {continue} |
||||||
|
set commenttest [tcl::string::map $encode_map $c] |
||||||
|
if {[tcl::string::length $commenttest] ne [tcl::string::length $c]} { |
||||||
|
set err "fauxlink::resolve '$link' invalid chars in comment [llength $comments]" |
||||||
|
append err [Segment_mustencode_check $c] |
||||||
|
append err $err_extra |
||||||
|
error $err |
||||||
|
} |
||||||
|
lappend comments [tcl::string::map $decode_map [decode_unicode_escapes $c]] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
set data [dict create name $name targetpath $targetpath tags $tags comments $comments fauxlinkextension $extension_name] |
||||||
|
if {$is_fauxlink} { |
||||||
|
#standard .fxlnk or .fauxlink |
||||||
|
return $data |
||||||
|
} else { |
||||||
|
#custom extension - or called in error on wrong type of file but happened to parse. |
||||||
|
#see comments at top regarding is_fauxlink |
||||||
|
#make sure no keys in common at top level. |
||||||
|
return [dict create\ |
||||||
|
linktype $extension_name\ |
||||||
|
note "nonstandard extension returning nonstandard dict with result in data key"\ |
||||||
|
data $data\ |
||||||
|
] |
||||||
|
} |
||||||
|
} |
||||||
|
variable map |
||||||
|
|
||||||
|
#default exclusion of / (%U2f and equivs) |
||||||
|
#this would allow obfuscation of intention - when we have + for that anyway |
||||||
|
proc decode_unicode_escapes {str {exclusions {/ \n \r \x00}}} { |
||||||
|
variable map |
||||||
|
set ucstart [string first %U $str 0] |
||||||
|
if {$ucstart < 0} { |
||||||
|
return $str |
||||||
|
} |
||||||
|
set max 8 |
||||||
|
set map [list] |
||||||
|
set strend [expr {[string length $str]-1}] |
||||||
|
while {$ucstart >= 0} { |
||||||
|
set s $ucstart |
||||||
|
set i [expr {$s +2}] ;#skip the %U |
||||||
|
set hex "" |
||||||
|
while {[tcl::string::length $hex] < 8 && $i <= $strend} { |
||||||
|
set in [string index $str $i] |
||||||
|
if {[tcl::string::is xdigit -strict $in]} { |
||||||
|
append hex $in |
||||||
|
} else { |
||||||
|
break |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
if {$hex ne ""} { |
||||||
|
incr i -1 |
||||||
|
lappend map $s $i $hex |
||||||
|
} |
||||||
|
set ucstart [tcl::string::first %U $str $i] |
||||||
|
} |
||||||
|
set out "" |
||||||
|
set lastidx -1 |
||||||
|
set e 0 |
||||||
|
foreach {s e hex} $map { |
||||||
|
append out [string range $str $lastidx+1 $s-1] |
||||||
|
set sub [format %c 0x$hex] |
||||||
|
if {$sub in $exclusions} { |
||||||
|
append out %U$hex ;#put it back |
||||||
|
} else { |
||||||
|
append out $sub |
||||||
|
} |
||||||
|
set lastidx $e |
||||||
|
} |
||||||
|
if {$e < [tcl::string::length $str]-1} { |
||||||
|
append out [string range $str $e+1 end] |
||||||
|
} |
||||||
|
return $out |
||||||
|
} |
||||||
|
proc link_as {name target} { |
||||||
|
|
||||||
|
} |
||||||
|
|
||||||
|
#proc sample1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace fauxlink ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
namespace eval fauxlink::lib { |
||||||
|
namespace export {[a-z]*}; # Convention: export all lowercase |
||||||
|
namespace path [namespace parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::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 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace fauxlink::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
namespace eval fauxlink::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace fauxlink::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide fauxlink [namespace eval fauxlink { |
||||||
|
variable pkg fauxlink |
||||||
|
variable version |
||||||
|
set version 0.1.1 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,699 @@ |
|||||||
|
# -*- 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.2 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin modpod_module_modpod 0 0.1.2] |
||||||
|
#[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 { |
||||||
|
-type -default "" |
||||||
|
*values -min 1 -max 1 |
||||||
|
path -type string -minlen 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 { |
||||||
|
-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 -minlen 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
||||||
|
outfile -type path -minlen 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]} { |
||||||
|
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 "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 'zipfs mkimg' as at 2024-10 |
||||||
|
#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.2 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in new issue