3660 changed files with 1918264 additions and 4290 deletions
@ -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,697 @@
|
||||
# -*- 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.1 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin modpod_module_modpod 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 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 "file" -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 "file"}} { |
||||
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 "sfx 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) |
||||
#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.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] |
||||
|
||||
@ -1,3 +1,3 @@
|
||||
%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. |
||||
|
||||
@ -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.
@ -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,697 @@
|
||||
# -*- 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.1 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin modpod_module_modpod 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 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 "file" -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 "file"}} { |
||||
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 "sfx 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) |
||||
#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.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] |
||||
|
||||
@ -1,3 +1,3 @@
|
||||
%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. |
||||
|
||||
@ -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.
@ -0,0 +1,20 @@
|
||||
# -*- tcl -* |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Requisites |
||||
|
||||
package require Tcl 8.5- |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
|
||||
namespace eval ::bogus { |
||||
proc test {args} { |
||||
puts stderr "bogus-should-not-load-$args" |
||||
} |
||||
} |
||||
|
||||
# # ## ### ##### ######## ############# ##################### |
||||
## Ready |
||||
|
||||
package provide bogus 1.1.1 |
||||
return |
||||
@ -0,0 +1,2 @@
|
||||
if {![package vsatisfies [package require Tcl] 8.5-]} return |
||||
package ifneeded bogus 1.1.1 [list source [file join $dir bogus.tcl]] |
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue