You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
702 lines
30 KiB
702 lines
30 KiB
# -*- 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 { |
|
@id -id ::modpod::connect |
|
-type -default "" |
|
@values -min 1 -max 1 |
|
path -type string -minsize 1 -help "path to .tm file or toplevel .tcl script within #modpod-<pkg>-<ver> folder (unwrapped modpod)" |
|
} $args] |
|
catch { |
|
punk::lib::showdict $argd ;#heavy dependencies |
|
} |
|
set opt_path [dict get $argd values path] |
|
variable connected |
|
set original_connectpath $opt_path |
|
set modpodpath [modpod::system::normalize $opt_path] ;# |
|
|
|
if {$modpodpath in $connected(to)} { |
|
return [dict create ok ALREADY_CONNECTED] |
|
} |
|
lappend connected(to) $modpodpath |
|
|
|
set connected(connectpath,$opt_path) $original_connectpath |
|
set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info script]]}] |
|
|
|
set connected(location,$modpodpath) [file dirname $modpodpath] |
|
set connected(startdata,$modpodpath) -1 |
|
set connected(type,$modpodpath) [dict get $argd opts -type] |
|
set connected(fh,$modpodpath) "" |
|
|
|
if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { |
|
set connected(type,$modpodpath) "unwrapped" |
|
lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
|
set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] |
|
|
|
} else { |
|
#connect to .tm but may still be unwrapped version available |
|
lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) |
|
set this_pkg_tm_folder [file dirname $modpodpath] |
|
if {$connected(type,$modpodpath) ne "unwrapped"} { |
|
#Not directly connected to unwrapped version - but may still be redirected there |
|
set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] |
|
if {[file exists $unwrappedFolder]} { |
|
#folder with exact version-match must exist for redirect to 'unwrapped' |
|
set con(type,$modpodpath) "modpod-redirecting" |
|
} |
|
} |
|
|
|
} |
|
set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" |
|
set connected(tmfile,$modpodpath) |
|
set tail_segments [list] |
|
set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] |
|
set lcase_modulepaths [string tolower [tcl::tm::list]] |
|
foreach lc_mpath $lcase_modulepaths { |
|
set mpath_segments [file split $lc_mpath] |
|
if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { |
|
set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] |
|
break |
|
} |
|
} |
|
if {[llength $tail_segments]} { |
|
set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require |
|
} else { |
|
set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] |
|
} |
|
|
|
switch -exact -- $connected(type,$modpodpath) { |
|
"modpod-redirecting" { |
|
#redirect to the unwrapped version |
|
set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] |
|
|
|
} |
|
"unwrapped" { |
|
if {[info commands ::thread::id] ne ""} { |
|
set from [pid],[thread::id] |
|
} else { |
|
set from [pid] |
|
} |
|
#::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" |
|
return [list ok ""] |
|
} |
|
default { |
|
#autodetect .tm - zip/tar ? |
|
#todo - use vfs ? |
|
|
|
#connect to tarball - start at 1st header |
|
set connected(startdata,$modpodpath) 0 |
|
set fh [open $modpodpath r] |
|
set connected(fh,$modpodpath) $fh |
|
fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} |
|
|
|
if {$connected(startdata,$modpodpath) >= 0} { |
|
#verify we have a valid tar header |
|
if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { |
|
seek $fh $connected(startdata,$modpodpath) start |
|
return [list ok $fh] |
|
} else { |
|
#error "cannot verify tar header" |
|
} |
|
} |
|
lpop connected(to) end |
|
set connected(startdata,$modpodpath) -1 |
|
unset connected(fh,$modpodpath) |
|
catch {close $fh} |
|
return [dict create err {Does not appear to be a valid modpod}] |
|
} |
|
} |
|
} |
|
proc disconnect {{modpod ""}} { |
|
variable connected |
|
if {![llength $connected(to)]} { |
|
return 0 |
|
} |
|
if {$modpod eq ""} { |
|
puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" |
|
set modpod [lindex $connected(to) end] |
|
} |
|
|
|
if {[set posn [lsearch $connected(to) $modpod]] == -1} { |
|
puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" |
|
return 0 |
|
} |
|
if {[string length $connected(fh,$modpod)]} { |
|
close $connected(fh,$modpod) |
|
} |
|
array unset connected *,$modpod |
|
set connected(to) [lreplace $connected(to) $posn $posn] |
|
return 1 |
|
} |
|
proc get {args} { |
|
set argd [punk::args::get_dict { |
|
-from -default "" -help "path to pod" |
|
*values -min 1 -max 1 |
|
filename |
|
} $args] |
|
set frompod [dict get $argd opts -from] |
|
set filename [dict get $argd values filename] |
|
|
|
variable connected |
|
#//review |
|
set modpod [::modpod::system::connect_if_not $frompod] |
|
set fh $connected(fh,$modpod) |
|
if {$connected(type,$modpod) eq "unwrapped"} { |
|
#for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder |
|
if {[string range $filename 0 0 eq "/"]} { |
|
#absolute path (?) |
|
set path [file join $connected(location,$modpod) .. [string trim $filename /]] |
|
} else { |
|
#relative path - use #modpod-xxx as base |
|
set path [file join $connected(location,$modpod) $filename] |
|
} |
|
set fd [open $path r] |
|
#utf-8? |
|
#fconfigure $fd -encoding iso8859-1 -translation binary |
|
return [list ok [lindex [list [read $fd] [close $fd]] 0]] |
|
} else { |
|
#read from vfs |
|
puts stderr "get $filename from wrapped pod '$frompod' not implemented" |
|
} |
|
} |
|
|
|
|
|
#*** !doctools |
|
#[list_end] [comment {--- end definitions namespace modpod ---}] |
|
} |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
|
|
|
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
# Secondary API namespace |
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
|
namespace eval modpod::lib { |
|
namespace export {[a-z]*}; # Convention: export all lowercase |
|
namespace path [namespace parent] |
|
#*** !doctools |
|
#[subsection {Namespace modpod::lib}] |
|
#[para] Secondary functions that are part of the API |
|
#[list_begin definitions] |
|
|
|
#proc utility1 {p1 args} { |
|
# #*** !doctools |
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
|
# #[para]Description of utility1 |
|
# return 1 |
|
#} |
|
|
|
proc is_valid_tm_version {versionpart} { |
|
#Needs to be suitable for use with Tcl's 'package vcompare' |
|
if {![catch [list package vcompare $versionparts $versionparts]]} { |
|
return 1 |
|
} else { |
|
return 0 |
|
} |
|
} |
|
|
|
#zipfile is a pure zip at this point - ie no script/exe header |
|
proc make_zip_modpod {args} { |
|
set argd [punk::args::get_dict { |
|
@id -id ::modpod::lib::make_zip_modpod |
|
-offsettype -default "archive" -choices {archive file} -help\ |
|
"Whether zip offsets are relative to start of file or start of zip-data within the file. |
|
'archive' relative offsets are easier to work with (for writing/updating) in tools such as 7zip,peazip, |
|
but other tools may be easier with 'file' relative offsets. (e.g info-zip,pkzip) |
|
info-zip's 'zip -A' can sometimes convert archive-relative to file-relative. |
|
-offsettype archive is equivalent to plain 'cat prefixfile zipfile > modulefile'" |
|
@values -min 2 -max 2 |
|
zipfile -type path -minsize 1 -help "path to plain zip file with subfolder #modpod-packagename-version containing .tm, data files and/or binaries" |
|
outfile -type path -minsize 1 -help "path to output file. Name should be of the form packagename-version.tm" |
|
} $args] |
|
set zipfile [dict get $argd values zipfile] |
|
set outfile [dict get $argd values outfile] |
|
set opt_offsettype [dict get $argd opts -offsettype] |
|
|
|
|
|
set mount_stub [string map [list %offsettype% $opt_offsettype] { |
|
#zip file with Tcl loader prepended. Requires either builtin zipfs, or vfs::zip to mount while zipped. |
|
#Alternatively unzip so that extracted #modpod-package-version folder is in same folder as .tm file. |
|
#generated using: modpod::lib::make_zip_modpod -offsettype %offsettype% <zipfile> <tmfile> |
|
if {[catch {file normalize [info script]} modfile]} { |
|
error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" |
|
} |
|
if {$modfile eq "" || ![file exists $modfile]} { |
|
error "modpod zip stub error. Unable to determine module path" |
|
} |
|
set moddir [file dirname $modfile] |
|
set mod_and_ver [file rootname [file tail $modfile]] |
|
lassign [split $mod_and_ver -] moduletail version |
|
if {[file exists $moddir/#modpod-$mod_and_ver]} { |
|
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] |
|
|
|
|