108 changed files with 3200 additions and 155209 deletions
@ -1,349 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application dictn 0.1.1 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval dictn { |
||||
namespace export {[a-z]*} |
||||
namespace ensemble create |
||||
} |
||||
|
||||
|
||||
## ::dictn::append |
||||
#This can of course 'ruin' a nested dict if applied to the wrong element |
||||
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: |
||||
# %set list {a b {c d}} |
||||
# %append list x |
||||
# a b {c d}x |
||||
# IOW - don't do that unless you really know that's what you want. |
||||
# |
||||
proc ::dictn::append {dictvar path {value {}}} { |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict append $dictvar $path $value] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
|
||||
::set str [dict get $dvar {*}$path] |
||||
append str $val |
||||
dict set dvar {*}$path $str |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::create {args} { |
||||
::set data {} |
||||
foreach {path val} $args { |
||||
dict set data {*}$path $val |
||||
} |
||||
return $data |
||||
} |
||||
|
||||
proc ::dictn::exists {dictval path} { |
||||
return [dict exists $dictval {*}$path] |
||||
} |
||||
|
||||
proc ::dictn::filter {dictval path filterType args} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
dict filter $sub $filterType {*}$args |
||||
} |
||||
|
||||
proc ::dictn::for {keyvalvars dictval path body} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
dict for $keyvalvars $sub $body |
||||
} |
||||
|
||||
proc ::dictn::get {dictval {path {}}} { |
||||
return [dict get $dictval {*}$path] |
||||
} |
||||
|
||||
proc ::dictn::getdef {dictval path default} { |
||||
return [dict getdef $dictval {*}$path $default] |
||||
} |
||||
|
||||
proc ::dictn::getwithdefault {dictval path default} { |
||||
return [dict getdef $dictval {*}$path $default] |
||||
} |
||||
|
||||
if {[info commands ::tcl::dict::getdef] ne ""} { |
||||
proc ::dictn::incr {dictvar path {increment {}} } { |
||||
if {$increment eq ""} { |
||||
::set increment 1 |
||||
} |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict incr $dictvar $path $increment] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
if {![::info exists dvar]} { |
||||
dict set dvar {*}$path $increment |
||||
} else { |
||||
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] |
||||
dict set dvar {*}$path $newval |
||||
} |
||||
return $dvar |
||||
} |
||||
} |
||||
} else { |
||||
proc ::dictn::incr {dictvar path {increment {}} } { |
||||
if {$increment eq ""} { |
||||
::set increment 1 |
||||
} |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict incr $dictvar $path $increment] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
if {![::info exists dvar]} { |
||||
dict set dvar {*}$path $increment |
||||
} else { |
||||
if {![dict exists $dvar {*}$path]} { |
||||
::set val 0 |
||||
} else { |
||||
::set val [dict get $dvar {*}$path] |
||||
} |
||||
::set newval [expr {$val + $increment}] |
||||
dict set dvar {*}$path $newval |
||||
} |
||||
return $dvar |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::info {dictval {path {}}} { |
||||
if {![string length $path]} { |
||||
return [dict info $dictval] |
||||
} else { |
||||
::set sub [dict get $dictval {*}$path] |
||||
return [dict info $sub] |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::keys {dictval {path {}} {glob {}}} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
if {[string length $glob]} { |
||||
return [dict keys $sub $glob] |
||||
} else { |
||||
return [dict keys $sub] |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::lappend {dictvar path args} { |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict lappend $dictvar $path {*}$args] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
|
||||
::set list [dict get $dvar {*}$path] |
||||
::lappend list {*}$args |
||||
dict set dvar {*}$path $list |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::merge {args} { |
||||
error "nested merge not yet supported" |
||||
} |
||||
|
||||
#dictn remove dictionaryValue ?path ...? |
||||
proc ::dictn::remove {dictval args} { |
||||
::set basic [list] ;#buffer basic (1element path) removals to do in a single call. |
||||
|
||||
foreach path $args { |
||||
if {[llength $path] == 1} { |
||||
::lappend basic $path |
||||
} else { |
||||
#extract,modify,replace |
||||
::set subpath [lrange $path 0 end-1] |
||||
|
||||
::set sub [dict get $dictval {*}$subpath] |
||||
::set sub [dict remove $sub [lindex $path end]] |
||||
|
||||
dict set dictval {*}$subpath $sub |
||||
} |
||||
} |
||||
|
||||
if {[llength $basic]} { |
||||
return [dict remove $dictval {*}$basic] |
||||
} else { |
||||
return $dictval |
||||
} |
||||
} |
||||
|
||||
|
||||
proc ::dictn::replace {dictval args} { |
||||
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. |
||||
|
||||
foreach {path val} $args { |
||||
if {[llength $path] == 1} { |
||||
::lappend basic $path $val |
||||
} else { |
||||
#extract,modify,replace |
||||
::set subpath [lrange $path 0 end-1] |
||||
|
||||
::set sub [dict get $dictval {*}$subpath] |
||||
::set sub [dict replace $sub [lindex $path end] $val] |
||||
|
||||
dict set dictval {*}$subpath $sub |
||||
} |
||||
} |
||||
|
||||
|
||||
if {[llength $basic]} { |
||||
return [dict replace $dictval {*}$basic] |
||||
} else { |
||||
return $dictval |
||||
} |
||||
} |
||||
|
||||
|
||||
proc ::dictn::set {dictvar path newval} { |
||||
upvar 1 $dictvar dvar |
||||
return [dict set dvar {*}$path $newval] |
||||
} |
||||
|
||||
proc ::dictn::size {dictval {path {}}} { |
||||
return [dict size [dict get $dictval {*}$path]] |
||||
} |
||||
|
||||
proc ::dictn::unset {dictvar path} { |
||||
upvar 1 $dictvar dvar |
||||
return [dict unset dvar {*}$path |
||||
} |
||||
|
||||
proc ::dictn::update {dictvar args} { |
||||
::set body [lindex $args end] |
||||
::set maplist [lrange $args 0 end-1] |
||||
|
||||
upvar 1 $dictvar dvar |
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path]} { |
||||
uplevel 1 [list set $var [dict get $dvar $path]] |
||||
} |
||||
} |
||||
|
||||
catch {uplevel 1 $body} result |
||||
|
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path]} { |
||||
upvar 1 $var $var |
||||
if {![::info exists $var]} { |
||||
uplevel 1 [list dict unset $dictvar {*}$path] |
||||
} else { |
||||
uplevel 1 [list dict set $dictvar {*}$path [::set $var]] |
||||
} |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
#an experiment. |
||||
proc ::dictn::Applyupdate {dictvar args} { |
||||
::set body [lindex $args end] |
||||
::set maplist [lrange $args 0 end-1] |
||||
|
||||
upvar 1 $dictvar dvar |
||||
|
||||
::set headscript "" |
||||
::set i 0 |
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path]} { |
||||
#uplevel 1 [list set $var [dict get $dvar $path]] |
||||
::lappend arglist $var |
||||
::lappend vallist [dict get $dvar {*}$path] |
||||
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] |
||||
::append headscript \n |
||||
::incr i |
||||
} |
||||
} |
||||
|
||||
::set body $headscript\r\n$body |
||||
|
||||
puts stderr "BODY: $body" |
||||
|
||||
#set result [apply [list args $body] {*}$vallist] |
||||
catch {apply [list args $body] {*}$vallist} result |
||||
|
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path] && [::info exists $var]} { |
||||
dict set dvar {*}$path [::set $var] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc ::dictn::values {dictval {path {}} {glob {}}} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
if {[string length $glob]} { |
||||
return [dict values $sub $glob] |
||||
} else { |
||||
return [dict values $sub] |
||||
} |
||||
} |
||||
|
||||
# Standard form: |
||||
#'dictn with dictVariable path body' |
||||
# |
||||
# Extended form: |
||||
#'dictn with dictVariable path arrayVariable body' |
||||
# |
||||
proc ::dictn::with {dictvar path args} { |
||||
if {[llength $args] == 1} { |
||||
::set body [lindex $args 0] |
||||
return [uplevel 1 [list dict with $dictvar {*}$path $body]] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
::lassign $args arrayname body |
||||
|
||||
upvar 1 $arrayname arr |
||||
array set arr [dict get $dvar {*}$path] |
||||
::set prevkeys [array names arr] |
||||
|
||||
catch {uplevel 1 $body} result |
||||
|
||||
|
||||
foreach k $prevkeys { |
||||
if {![::info exists arr($k)]} { |
||||
dict unset $dvar {*}$path $k |
||||
} |
||||
} |
||||
foreach k [array names arr] { |
||||
dict set $dvar {*}$path $k $arr($k) |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide dictn [namespace eval dictn { |
||||
variable version |
||||
::set version 0.1.1 |
||||
}] |
||||
return |
||||
@ -1,702 +0,0 @@
|
||||
# -*- 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] |
||||
|
||||
@ -1,195 +0,0 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key > 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
method alias {newAlias existingKeyOrAlias} { |
||||
if {[string is integer -strict $newAlias]} { |
||||
error "[self object] collection key alias cannot be integer" |
||||
} |
||||
if {[string length $existingKeyOrAlias]} { |
||||
set o_alias($newAlias) $existingKeyOrAlias |
||||
} else { |
||||
unset o_alias($newAlias) |
||||
} |
||||
} |
||||
method aliases {{key ""}} { |
||||
if {[string length $key]} { |
||||
set result [list] |
||||
foreach {n v} [array get o_alias] { |
||||
if {$v eq $key} { |
||||
lappend result $n $v |
||||
} |
||||
} |
||||
return $result |
||||
} else { |
||||
return [array get o_alias] |
||||
} |
||||
} |
||||
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
method realKey {idx} { |
||||
if {[catch {set o_alias($idx)} key]} { |
||||
return $idx |
||||
} else { |
||||
return $key |
||||
} |
||||
} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse {} { |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,245 +0,0 @@
|
||||
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# UUIDs are 128 bit values that attempt to be unique in time and space. |
||||
# |
||||
# Reference: |
||||
# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt |
||||
# |
||||
# uuid: scheme: |
||||
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html |
||||
# |
||||
# Usage: uuid::uuid generate |
||||
# uuid::uuid equal $idA $idB |
||||
|
||||
package require Tcl 8.5 |
||||
|
||||
namespace eval uuid { |
||||
variable accel |
||||
array set accel {critcl 0} |
||||
|
||||
namespace export uuid |
||||
|
||||
variable uid |
||||
if {![info exists uid]} { |
||||
set uid 1 |
||||
} |
||||
|
||||
proc K {a b} {set a} |
||||
} |
||||
|
||||
### |
||||
# Optimization |
||||
# Caches machine info after the first pass |
||||
### |
||||
|
||||
proc ::uuid::generate_tcl_machinfo {} { |
||||
variable machinfo |
||||
if {[info exists machinfo]} { |
||||
return $machinfo |
||||
} |
||||
lappend machinfo [clock seconds]; # timestamp |
||||
lappend machinfo [clock clicks]; # system incrementing counter |
||||
lappend machinfo [info hostname]; # spatial unique id (poor) |
||||
lappend machinfo [pid]; # additional entropy |
||||
lappend machinfo [array get ::tcl_platform] |
||||
|
||||
### |
||||
# If we have /dev/urandom just stream 128 bits from that |
||||
### |
||||
if {[file exists /dev/urandom]} { |
||||
set fin [open /dev/urandom r] |
||||
binary scan [read $fin 128] H* machinfo |
||||
close $fin |
||||
} elseif {[catch {package require nettool}]} { |
||||
# More spatial information -- better than hostname. |
||||
# bug 1150714: opening a server socket may raise a warning messagebox |
||||
# with WinXP firewall, using ipconfig will return all IP addresses |
||||
# including ipv6 ones if available. ipconfig is OK on win98+ |
||||
if {[string equal $::tcl_platform(platform) "windows"]} { |
||||
catch {exec ipconfig} config |
||||
lappend machinfo $config |
||||
} else { |
||||
catch { |
||||
set s [socket -server void -myaddr [info hostname] 0] |
||||
K [fconfigure $s -sockname] [close $s] |
||||
} r |
||||
lappend machinfo $r |
||||
} |
||||
|
||||
if {[package provide Tk] != {}} { |
||||
lappend machinfo [winfo pointerxy .] |
||||
lappend machinfo [winfo id .] |
||||
} |
||||
} else { |
||||
### |
||||
# If the nettool package works on this platform |
||||
# use the stream of hardware ids from it |
||||
### |
||||
lappend machinfo {*}[::nettool::hwid_list] |
||||
} |
||||
return $machinfo |
||||
} |
||||
|
||||
# Generates a binary UUID as per the draft spec. We generate a pseudo-random |
||||
# type uuid (type 4). See section 3.4 |
||||
# |
||||
proc ::uuid::generate_tcl {} { |
||||
package require md5 2 |
||||
variable uid |
||||
|
||||
set tok [md5::MD5Init] |
||||
md5::MD5Update $tok [incr uid]; # package incrementing counter |
||||
foreach string [generate_tcl_machinfo] { |
||||
md5::MD5Update $tok $string |
||||
} |
||||
set r [md5::MD5Final $tok] |
||||
binary scan $r c* r |
||||
|
||||
# 3.4: set uuid versioning fields |
||||
lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] |
||||
lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] |
||||
|
||||
return [binary format c* $r] |
||||
} |
||||
|
||||
if {[string equal $tcl_platform(platform) "windows"] |
||||
&& [package provide critcl] != {}} { |
||||
namespace eval uuid { |
||||
critcl::ccode { |
||||
#define WIN32_LEAN_AND_MEAN |
||||
#define STRICT |
||||
#include <windows.h> |
||||
#include <ole2.h> |
||||
typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); |
||||
typedef const unsigned char cu_char; |
||||
} |
||||
critcl::cproc generate_c {Tcl_Interp* interp} ok { |
||||
HRESULT hr = S_OK; |
||||
int r = TCL_OK; |
||||
UUID uuid = {0}; |
||||
HMODULE hLib; |
||||
LPFNUUIDCREATE lpfnUuidCreate = NULL; |
||||
hLib = LoadLibraryA(("rpcrt4.dll")); |
||||
if (hLib) |
||||
lpfnUuidCreate = (LPFNUUIDCREATE) |
||||
GetProcAddress(hLib, "UuidCreate"); |
||||
if (lpfnUuidCreate) { |
||||
Tcl_Obj *obj; |
||||
lpfnUuidCreate(&uuid); |
||||
obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); |
||||
Tcl_SetObjResult(interp, obj); |
||||
} else { |
||||
Tcl_SetResult(interp, "error: failed to create a guid", |
||||
TCL_STATIC); |
||||
r = TCL_ERROR; |
||||
} |
||||
return r; |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Convert a binary uuid into its string representation. |
||||
# |
||||
proc ::uuid::tostring {uuid} { |
||||
binary scan $uuid H* s |
||||
foreach {a b} {0 7 8 11 12 15 16 19 20 end} { |
||||
append r [string range $s $a $b] - |
||||
} |
||||
return [string tolower [string trimright $r -]] |
||||
} |
||||
|
||||
# Convert a string representation of a uuid into its binary format. |
||||
# |
||||
proc ::uuid::fromstring {uuid} { |
||||
return [binary format H* [string map {- {}} $uuid]] |
||||
} |
||||
|
||||
# Compare two uuids for equality. |
||||
# |
||||
proc ::uuid::equal {left right} { |
||||
set l [fromstring $left] |
||||
set r [fromstring $right] |
||||
return [string equal $l $r] |
||||
} |
||||
|
||||
# Call our generate uuid implementation |
||||
proc ::uuid::generate {} { |
||||
variable accel |
||||
if {$accel(critcl)} { |
||||
return [generate_c] |
||||
} else { |
||||
return [generate_tcl] |
||||
} |
||||
} |
||||
|
||||
# uuid generate -> string rep of a new uuid |
||||
# uuid equal uuid1 uuid2 |
||||
# |
||||
proc uuid::uuid {cmd args} { |
||||
switch -exact -- $cmd { |
||||
generate { |
||||
if {[llength $args] != 0} { |
||||
return -code error "wrong # args:\ |
||||
should be \"uuid generate\"" |
||||
} |
||||
return [tostring [generate]] |
||||
} |
||||
equal { |
||||
if {[llength $args] != 2} { |
||||
return -code error "wrong \# args:\ |
||||
should be \"uuid equal uuid1 uuid2\"" |
||||
} |
||||
return [eval [linsert $args 0 equal]] |
||||
} |
||||
default { |
||||
return -code error "bad option \"$cmd\":\ |
||||
must be generate or equal" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# LoadAccelerator -- |
||||
# |
||||
# This package can make use of a number of compiled extensions to |
||||
# accelerate the digest computation. This procedure manages the |
||||
# use of these extensions within the package. During normal usage |
||||
# this should not be called, but the test package manipulates the |
||||
# list of enabled accelerators. |
||||
# |
||||
proc ::uuid::LoadAccelerator {name} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $name { |
||||
critcl { |
||||
if {![catch {package require tcllibc}]} { |
||||
set r [expr {[info commands ::uuid::generate_c] != {}}] |
||||
} |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator package:\ |
||||
must be one of [join [array names accel] {, }]" |
||||
} |
||||
} |
||||
set accel($name) $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Try and load a compiled extension to help. |
||||
namespace eval ::uuid { |
||||
variable e {} |
||||
foreach e {critcl} { |
||||
if {[LoadAccelerator $e]} break |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
package provide uuid 1.0.7 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
@ -1,246 +0,0 @@
|
||||
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# UUIDs are 128 bit values that attempt to be unique in time and space. |
||||
# |
||||
# Reference: |
||||
# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt |
||||
# |
||||
# uuid: scheme: |
||||
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html |
||||
# |
||||
# Usage: uuid::uuid generate |
||||
# uuid::uuid equal $idA $idB |
||||
|
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval uuid { |
||||
variable accel |
||||
array set accel {critcl 0} |
||||
|
||||
namespace export uuid |
||||
|
||||
variable uid |
||||
if {![info exists uid]} { |
||||
set uid 1 |
||||
} |
||||
|
||||
proc K {a b} {set a} |
||||
} |
||||
|
||||
### |
||||
# Optimization |
||||
# Caches machine info after the first pass |
||||
### |
||||
|
||||
proc ::uuid::generate_tcl_machinfo {} { |
||||
variable machinfo |
||||
if {[info exists machinfo]} { |
||||
return $machinfo |
||||
} |
||||
lappend machinfo [clock seconds]; # timestamp |
||||
lappend machinfo [clock clicks]; # system incrementing counter |
||||
lappend machinfo [info hostname]; # spatial unique id (poor) |
||||
lappend machinfo [pid]; # additional entropy |
||||
lappend machinfo [array get ::tcl_platform] |
||||
|
||||
### |
||||
# If we have /dev/urandom just stream 128 bits from that |
||||
### |
||||
if {[file exists /dev/urandom]} { |
||||
set fin [open /dev/urandom r] |
||||
fconfigure $fin -encoding binary |
||||
binary scan [read $fin 128] H* machinfo |
||||
close $fin |
||||
} elseif {[catch {package require nettool}]} { |
||||
# More spatial information -- better than hostname. |
||||
# bug 1150714: opening a server socket may raise a warning messagebox |
||||
# with WinXP firewall, using ipconfig will return all IP addresses |
||||
# including ipv6 ones if available. ipconfig is OK on win98+ |
||||
if {[string equal $::tcl_platform(platform) "windows"]} { |
||||
catch {exec ipconfig} config |
||||
lappend machinfo $config |
||||
} else { |
||||
catch { |
||||
set s [socket -server void -myaddr [info hostname] 0] |
||||
K [fconfigure $s -sockname] [close $s] |
||||
} r |
||||
lappend machinfo $r |
||||
} |
||||
|
||||
if {[package provide Tk] != {}} { |
||||
lappend machinfo [winfo pointerxy .] |
||||
lappend machinfo [winfo id .] |
||||
} |
||||
} else { |
||||
### |
||||
# If the nettool package works on this platform |
||||
# use the stream of hardware ids from it |
||||
### |
||||
lappend machinfo {*}[::nettool::hwid_list] |
||||
} |
||||
return $machinfo |
||||
} |
||||
|
||||
# Generates a binary UUID as per the draft spec. We generate a pseudo-random |
||||
# type uuid (type 4). See section 3.4 |
||||
# |
||||
proc ::uuid::generate_tcl {} { |
||||
package require md5 2 |
||||
variable uid |
||||
|
||||
set tok [md5::MD5Init] |
||||
md5::MD5Update $tok [incr uid]; # package incrementing counter |
||||
foreach string [generate_tcl_machinfo] { |
||||
md5::MD5Update $tok $string |
||||
} |
||||
set r [md5::MD5Final $tok] |
||||
binary scan $r c* r |
||||
|
||||
# 3.4: set uuid versioning fields |
||||
lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] |
||||
lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] |
||||
|
||||
return [binary format c* $r] |
||||
} |
||||
|
||||
if {[string equal $tcl_platform(platform) "windows"] |
||||
&& [package provide critcl] != {}} { |
||||
namespace eval uuid { |
||||
critcl::ccode { |
||||
#define WIN32_LEAN_AND_MEAN |
||||
#define STRICT |
||||
#include <windows.h> |
||||
#include <ole2.h> |
||||
typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); |
||||
typedef const unsigned char cu_char; |
||||
} |
||||
critcl::cproc generate_c {Tcl_Interp* interp} ok { |
||||
HRESULT hr = S_OK; |
||||
int r = TCL_OK; |
||||
UUID uuid = {0}; |
||||
HMODULE hLib; |
||||
LPFNUUIDCREATE lpfnUuidCreate = NULL; |
||||
hLib = LoadLibraryA(("rpcrt4.dll")); |
||||
if (hLib) |
||||
lpfnUuidCreate = (LPFNUUIDCREATE) |
||||
GetProcAddress(hLib, "UuidCreate"); |
||||
if (lpfnUuidCreate) { |
||||
Tcl_Obj *obj; |
||||
lpfnUuidCreate(&uuid); |
||||
obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); |
||||
Tcl_SetObjResult(interp, obj); |
||||
} else { |
||||
Tcl_SetResult(interp, "error: failed to create a guid", |
||||
TCL_STATIC); |
||||
r = TCL_ERROR; |
||||
} |
||||
return r; |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Convert a binary uuid into its string representation. |
||||
# |
||||
proc ::uuid::tostring {uuid} { |
||||
binary scan $uuid H* s |
||||
foreach {a b} {0 7 8 11 12 15 16 19 20 end} { |
||||
append r [string range $s $a $b] - |
||||
} |
||||
return [string tolower [string trimright $r -]] |
||||
} |
||||
|
||||
# Convert a string representation of a uuid into its binary format. |
||||
# |
||||
proc ::uuid::fromstring {uuid} { |
||||
return [binary format H* [string map {- {}} $uuid]] |
||||
} |
||||
|
||||
# Compare two uuids for equality. |
||||
# |
||||
proc ::uuid::equal {left right} { |
||||
set l [fromstring $left] |
||||
set r [fromstring $right] |
||||
return [string equal $l $r] |
||||
} |
||||
|
||||
# Call our generate uuid implementation |
||||
proc ::uuid::generate {} { |
||||
variable accel |
||||
if {$accel(critcl)} { |
||||
return [generate_c] |
||||
} else { |
||||
return [generate_tcl] |
||||
} |
||||
} |
||||
|
||||
# uuid generate -> string rep of a new uuid |
||||
# uuid equal uuid1 uuid2 |
||||
# |
||||
proc uuid::uuid {cmd args} { |
||||
switch -exact -- $cmd { |
||||
generate { |
||||
if {[llength $args] != 0} { |
||||
return -code error "wrong # args:\ |
||||
should be \"uuid generate\"" |
||||
} |
||||
return [tostring [generate]] |
||||
} |
||||
equal { |
||||
if {[llength $args] != 2} { |
||||
return -code error "wrong \# args:\ |
||||
should be \"uuid equal uuid1 uuid2\"" |
||||
} |
||||
return [eval [linsert $args 0 equal]] |
||||
} |
||||
default { |
||||
return -code error "bad option \"$cmd\":\ |
||||
must be generate or equal" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# LoadAccelerator -- |
||||
# |
||||
# This package can make use of a number of compiled extensions to |
||||
# accelerate the digest computation. This procedure manages the |
||||
# use of these extensions within the package. During normal usage |
||||
# this should not be called, but the test package manipulates the |
||||
# list of enabled accelerators. |
||||
# |
||||
proc ::uuid::LoadAccelerator {name} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $name { |
||||
critcl { |
||||
if {![catch {package require tcllibc}]} { |
||||
set r [expr {[info commands ::uuid::generate_c] != {}}] |
||||
} |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator package:\ |
||||
must be one of [join [array names accel] {, }]" |
||||
} |
||||
} |
||||
set accel($name) $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Try and load a compiled extension to help. |
||||
namespace eval ::uuid { |
||||
variable e {} |
||||
foreach e {critcl} { |
||||
if {[LoadAccelerator $e]} break |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
package provide uuid 1.0.8 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
@ -1,349 +0,0 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application dictn 0.1.1 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval dictn { |
||||
namespace export {[a-z]*} |
||||
namespace ensemble create |
||||
} |
||||
|
||||
|
||||
## ::dictn::append |
||||
#This can of course 'ruin' a nested dict if applied to the wrong element |
||||
# - i.e using the string op 'append' on an element that is itself a nested dict is analogous to the standard Tcl: |
||||
# %set list {a b {c d}} |
||||
# %append list x |
||||
# a b {c d}x |
||||
# IOW - don't do that unless you really know that's what you want. |
||||
# |
||||
proc ::dictn::append {dictvar path {value {}}} { |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict append $dictvar $path $value] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
|
||||
::set str [dict get $dvar {*}$path] |
||||
append str $val |
||||
dict set dvar {*}$path $str |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::create {args} { |
||||
::set data {} |
||||
foreach {path val} $args { |
||||
dict set data {*}$path $val |
||||
} |
||||
return $data |
||||
} |
||||
|
||||
proc ::dictn::exists {dictval path} { |
||||
return [dict exists $dictval {*}$path] |
||||
} |
||||
|
||||
proc ::dictn::filter {dictval path filterType args} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
dict filter $sub $filterType {*}$args |
||||
} |
||||
|
||||
proc ::dictn::for {keyvalvars dictval path body} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
dict for $keyvalvars $sub $body |
||||
} |
||||
|
||||
proc ::dictn::get {dictval {path {}}} { |
||||
return [dict get $dictval {*}$path] |
||||
} |
||||
|
||||
proc ::dictn::getdef {dictval path default} { |
||||
return [dict getdef $dictval {*}$path $default] |
||||
} |
||||
|
||||
proc ::dictn::getwithdefault {dictval path default} { |
||||
return [dict getdef $dictval {*}$path $default] |
||||
} |
||||
|
||||
if {[info commands ::tcl::dict::getdef] ne ""} { |
||||
proc ::dictn::incr {dictvar path {increment {}} } { |
||||
if {$increment eq ""} { |
||||
::set increment 1 |
||||
} |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict incr $dictvar $path $increment] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
if {![::info exists dvar]} { |
||||
dict set dvar {*}$path $increment |
||||
} else { |
||||
::set newval [expr {[dict getdef $dvar {*}$path 0] + $increment}] |
||||
dict set dvar {*}$path $newval |
||||
} |
||||
return $dvar |
||||
} |
||||
} |
||||
} else { |
||||
proc ::dictn::incr {dictvar path {increment {}} } { |
||||
if {$increment eq ""} { |
||||
::set increment 1 |
||||
} |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict incr $dictvar $path $increment] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
if {![::info exists dvar]} { |
||||
dict set dvar {*}$path $increment |
||||
} else { |
||||
if {![dict exists $dvar {*}$path]} { |
||||
::set val 0 |
||||
} else { |
||||
::set val [dict get $dvar {*}$path] |
||||
} |
||||
::set newval [expr {$val + $increment}] |
||||
dict set dvar {*}$path $newval |
||||
} |
||||
return $dvar |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::info {dictval {path {}}} { |
||||
if {![string length $path]} { |
||||
return [dict info $dictval] |
||||
} else { |
||||
::set sub [dict get $dictval {*}$path] |
||||
return [dict info $sub] |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::keys {dictval {path {}} {glob {}}} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
if {[string length $glob]} { |
||||
return [dict keys $sub $glob] |
||||
} else { |
||||
return [dict keys $sub] |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::lappend {dictvar path args} { |
||||
if {[llength $path] == 1} { |
||||
uplevel 1 [list dict lappend $dictvar $path {*}$args] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
|
||||
::set list [dict get $dvar {*}$path] |
||||
::lappend list {*}$args |
||||
dict set dvar {*}$path $list |
||||
} |
||||
} |
||||
|
||||
proc ::dictn::merge {args} { |
||||
error "nested merge not yet supported" |
||||
} |
||||
|
||||
#dictn remove dictionaryValue ?path ...? |
||||
proc ::dictn::remove {dictval args} { |
||||
::set basic [list] ;#buffer basic (1element path) removals to do in a single call. |
||||
|
||||
foreach path $args { |
||||
if {[llength $path] == 1} { |
||||
::lappend basic $path |
||||
} else { |
||||
#extract,modify,replace |
||||
::set subpath [lrange $path 0 end-1] |
||||
|
||||
::set sub [dict get $dictval {*}$subpath] |
||||
::set sub [dict remove $sub [lindex $path end]] |
||||
|
||||
dict set dictval {*}$subpath $sub |
||||
} |
||||
} |
||||
|
||||
if {[llength $basic]} { |
||||
return [dict remove $dictval {*}$basic] |
||||
} else { |
||||
return $dictval |
||||
} |
||||
} |
||||
|
||||
|
||||
proc ::dictn::replace {dictval args} { |
||||
::set basic [list] ;#buffer basic (1element path) replacements to do in a single call. |
||||
|
||||
foreach {path val} $args { |
||||
if {[llength $path] == 1} { |
||||
::lappend basic $path $val |
||||
} else { |
||||
#extract,modify,replace |
||||
::set subpath [lrange $path 0 end-1] |
||||
|
||||
::set sub [dict get $dictval {*}$subpath] |
||||
::set sub [dict replace $sub [lindex $path end] $val] |
||||
|
||||
dict set dictval {*}$subpath $sub |
||||
} |
||||
} |
||||
|
||||
|
||||
if {[llength $basic]} { |
||||
return [dict replace $dictval {*}$basic] |
||||
} else { |
||||
return $dictval |
||||
} |
||||
} |
||||
|
||||
|
||||
proc ::dictn::set {dictvar path newval} { |
||||
upvar 1 $dictvar dvar |
||||
return [dict set dvar {*}$path $newval] |
||||
} |
||||
|
||||
proc ::dictn::size {dictval {path {}}} { |
||||
return [dict size [dict get $dictval {*}$path]] |
||||
} |
||||
|
||||
proc ::dictn::unset {dictvar path} { |
||||
upvar 1 $dictvar dvar |
||||
return [dict unset dvar {*}$path |
||||
} |
||||
|
||||
proc ::dictn::update {dictvar args} { |
||||
::set body [lindex $args end] |
||||
::set maplist [lrange $args 0 end-1] |
||||
|
||||
upvar 1 $dictvar dvar |
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path]} { |
||||
uplevel 1 [list set $var [dict get $dvar $path]] |
||||
} |
||||
} |
||||
|
||||
catch {uplevel 1 $body} result |
||||
|
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path]} { |
||||
upvar 1 $var $var |
||||
if {![::info exists $var]} { |
||||
uplevel 1 [list dict unset $dictvar {*}$path] |
||||
} else { |
||||
uplevel 1 [list dict set $dictvar {*}$path [::set $var]] |
||||
} |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
#an experiment. |
||||
proc ::dictn::Applyupdate {dictvar args} { |
||||
::set body [lindex $args end] |
||||
::set maplist [lrange $args 0 end-1] |
||||
|
||||
upvar 1 $dictvar dvar |
||||
|
||||
::set headscript "" |
||||
::set i 0 |
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path]} { |
||||
#uplevel 1 [list set $var [dict get $dvar $path]] |
||||
::lappend arglist $var |
||||
::lappend vallist [dict get $dvar {*}$path] |
||||
::append headscript [string map [list %i% $i %v% $var] {upvar 1 %v% %v%; set %v% [lindex $args %i%]} ] |
||||
::append headscript \n |
||||
::incr i |
||||
} |
||||
} |
||||
|
||||
::set body $headscript\r\n$body |
||||
|
||||
puts stderr "BODY: $body" |
||||
|
||||
#set result [apply [list args $body] {*}$vallist] |
||||
catch {apply [list args $body] {*}$vallist} result |
||||
|
||||
foreach {path var} $maplist { |
||||
if {[dict exists $dvar {*}$path] && [::info exists $var]} { |
||||
dict set dvar {*}$path [::set $var] |
||||
} |
||||
} |
||||
return $result |
||||
} |
||||
|
||||
proc ::dictn::values {dictval {path {}} {glob {}}} { |
||||
::set sub [dict get $dictval {*}$path] |
||||
if {[string length $glob]} { |
||||
return [dict values $sub $glob] |
||||
} else { |
||||
return [dict values $sub] |
||||
} |
||||
} |
||||
|
||||
# Standard form: |
||||
#'dictn with dictVariable path body' |
||||
# |
||||
# Extended form: |
||||
#'dictn with dictVariable path arrayVariable body' |
||||
# |
||||
proc ::dictn::with {dictvar path args} { |
||||
if {[llength $args] == 1} { |
||||
::set body [lindex $args 0] |
||||
return [uplevel 1 [list dict with $dictvar {*}$path $body]] |
||||
} else { |
||||
upvar 1 $dictvar dvar |
||||
::lassign $args arrayname body |
||||
|
||||
upvar 1 $arrayname arr |
||||
array set arr [dict get $dvar {*}$path] |
||||
::set prevkeys [array names arr] |
||||
|
||||
catch {uplevel 1 $body} result |
||||
|
||||
|
||||
foreach k $prevkeys { |
||||
if {![::info exists arr($k)]} { |
||||
dict unset $dvar {*}$path $k |
||||
} |
||||
} |
||||
foreach k [array names arr] { |
||||
dict set $dvar {*}$path $k $arr($k) |
||||
} |
||||
|
||||
return $result |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide dictn [namespace eval dictn { |
||||
variable version |
||||
::set version 0.1.1 |
||||
}] |
||||
return |
||||
@ -1,567 +0,0 @@
|
||||
# -*- 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.0 |
||||
# Meta platform tcl |
||||
# Meta license MIT |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin fauxlink_module_fauxlink 0 0.1.0] |
||||
#[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 [lb]heart[rb]) 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.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -1,705 +0,0 @@
|
||||
# -*- 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.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# doctools header |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#*** !doctools |
||||
#[manpage_begin modpod_module_modpod 0 0.1.0] |
||||
#[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" |
||||
#} |
||||
|
||||
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 |
||||
set modpod [::tarjar::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 |
||||
} |
||||
} |
||||
proc make_zip_modpod {zipfile outfile} { |
||||
set mount_stub { |
||||
#zip file with Tcl loader prepended. |
||||
#generated using modpod::make_zip_modpod |
||||
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 propertly 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" |
||||
append msg \n "If vfs::zip is unavailable - 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 zipfile has #modpod-loadcript.tcl before even creating |
||||
append mount_stub \x1A |
||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub |
||||
|
||||
} |
||||
proc make_zip_modpod1 {zipfile outfile} { |
||||
set mount_stub { |
||||
#zip file with Tcl loader prepended. |
||||
#generated using modpod::make_zip_modpod |
||||
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 { |
||||
if {![file exists $moddir/#mounted-modpod-$mod_and_ver]} { |
||||
if {[catch {package require vfs::zip} errM]} { |
||||
set msg "Unable to load vfs::zip package to mount module $mod_and_ver" |
||||
append msg \n "If vfs::zip is unavailable - 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 $ |
||||
} |
||||
set fd [vfs::zip::Mount $modfile $moddir/#mounted-modpod-$mod_and_ver] |
||||
if {![file exists $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||
vfs::zip::Unmount $fd $moddir/#mounted-modpod-$mod_and_ver |
||||
error "Unable to find #modpod-$mod_and_ver/$mod_and_ver.tm in $modfile" |
||||
} |
||||
} |
||||
source $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm |
||||
} |
||||
#zipped data follows |
||||
} |
||||
#todo - test if zipfile has #modpod-loadcript.tcl before even creating |
||||
append mount_stub \x1A |
||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub |
||||
|
||||
} |
||||
proc make_zip_source_mountable {zipfile outfile} { |
||||
set mount_stub { |
||||
package require vfs::zip |
||||
vfs::zip::Mount [info script] [info script] |
||||
} |
||||
append mount_stub \x1A |
||||
modpod::system::make_mountable_zip $zipfile $outfile $mount_stub |
||||
} |
||||
|
||||
#*** !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 |
||||
proc make_mountable_zip {zipfile outfile mount_stub} { |
||||
set in [open $zipfile r] |
||||
fconfigure $in -encoding iso8859-1 -translation binary |
||||
set out [open $outfile w+] |
||||
fconfigure $out -encoding iso8859-1 -translation binary |
||||
puts -nonewline $out $mount_stub |
||||
set offset [tell $out] |
||||
lappend report "sfx stub size: $offset" |
||||
fcopy $in $out |
||||
|
||||
close $in |
||||
set size [tell $out] |
||||
#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 seek 0 |
||||
} else { |
||||
set seek [expr {$size - 65559}] |
||||
} |
||||
seek $out $seek |
||||
set data [read $out] |
||||
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 |
||||
|
||||
lappend report "START-OF-END: $start_of_end ([expr {$start_of_end - $size}]) [string length $data]" |
||||
|
||||
seek $out $start_of_end |
||||
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 {$start_of_end+16}] |
||||
|
||||
#adjust offset of start of central directory by the length of our sfx stub |
||||
puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $offset}]] |
||||
flush $out |
||||
|
||||
seek $out $start_of_end |
||||
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)" |
||||
|
||||
#33639248 dec = 0x02014b50 - central 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)+$offset}]] |
||||
|
||||
#verify: |
||||
flush $out |
||||
seek $out $current_file |
||||
set fileheader [read $out 46] |
||||
lappend report "old $x(offset) + $offset" |
||||
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.0 |
||||
}] |
||||
return |
||||
|
||||
#*** !doctools |
||||
#[manpage_end] |
||||
|
||||
@ -1,697 +0,0 @@
|
||||
# -*- 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] |
||||
|
||||
@ -1,702 +0,0 @@
|
||||
# -*- 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] |
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -1,200 +0,0 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1.1 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
set idx $globOrIdx |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key >= 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex $o_data $key] |
||||
#return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
method alias {newAlias existingKeyOrAlias} { |
||||
if {[string is integer -strict $newAlias]} { |
||||
error "[self object] collection key alias cannot be integer" |
||||
} |
||||
if {[string length $existingKeyOrAlias]} { |
||||
set o_alias($newAlias) $existingKeyOrAlias |
||||
} else { |
||||
unset o_alias($newAlias) |
||||
} |
||||
} |
||||
method aliases {{key ""}} { |
||||
if {[string length $key]} { |
||||
set result [list] |
||||
foreach {n v} [array get o_alias] { |
||||
if {$v eq $key} { |
||||
lappend result $n $v |
||||
} |
||||
} |
||||
return $result |
||||
} else { |
||||
return [array get o_alias] |
||||
} |
||||
} |
||||
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
method realKey {idx} { |
||||
if {[catch {set o_alias($idx)} key]} { |
||||
return $idx |
||||
} else { |
||||
return $key |
||||
} |
||||
} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse_the_collection {} { |
||||
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
||||
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
||||
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
@ -1,195 +0,0 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key > 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
method alias {newAlias existingKeyOrAlias} { |
||||
if {[string is integer -strict $newAlias]} { |
||||
error "[self object] collection key alias cannot be integer" |
||||
} |
||||
if {[string length $existingKeyOrAlias]} { |
||||
set o_alias($newAlias) $existingKeyOrAlias |
||||
} else { |
||||
unset o_alias($newAlias) |
||||
} |
||||
} |
||||
method aliases {{key ""}} { |
||||
if {[string length $key]} { |
||||
set result [list] |
||||
foreach {n v} [array get o_alias] { |
||||
if {$v eq $key} { |
||||
lappend result $n $v |
||||
} |
||||
} |
||||
return $result |
||||
} else { |
||||
return [array get o_alias] |
||||
} |
||||
} |
||||
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
method realKey {idx} { |
||||
if {[catch {set o_alias($idx)} key]} { |
||||
return $idx |
||||
} else { |
||||
return $key |
||||
} |
||||
} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse {} { |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -1,245 +0,0 @@
|
||||
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# UUIDs are 128 bit values that attempt to be unique in time and space. |
||||
# |
||||
# Reference: |
||||
# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt |
||||
# |
||||
# uuid: scheme: |
||||
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html |
||||
# |
||||
# Usage: uuid::uuid generate |
||||
# uuid::uuid equal $idA $idB |
||||
|
||||
package require Tcl 8.5 |
||||
|
||||
namespace eval uuid { |
||||
variable accel |
||||
array set accel {critcl 0} |
||||
|
||||
namespace export uuid |
||||
|
||||
variable uid |
||||
if {![info exists uid]} { |
||||
set uid 1 |
||||
} |
||||
|
||||
proc K {a b} {set a} |
||||
} |
||||
|
||||
### |
||||
# Optimization |
||||
# Caches machine info after the first pass |
||||
### |
||||
|
||||
proc ::uuid::generate_tcl_machinfo {} { |
||||
variable machinfo |
||||
if {[info exists machinfo]} { |
||||
return $machinfo |
||||
} |
||||
lappend machinfo [clock seconds]; # timestamp |
||||
lappend machinfo [clock clicks]; # system incrementing counter |
||||
lappend machinfo [info hostname]; # spatial unique id (poor) |
||||
lappend machinfo [pid]; # additional entropy |
||||
lappend machinfo [array get ::tcl_platform] |
||||
|
||||
### |
||||
# If we have /dev/urandom just stream 128 bits from that |
||||
### |
||||
if {[file exists /dev/urandom]} { |
||||
set fin [open /dev/urandom r] |
||||
binary scan [read $fin 128] H* machinfo |
||||
close $fin |
||||
} elseif {[catch {package require nettool}]} { |
||||
# More spatial information -- better than hostname. |
||||
# bug 1150714: opening a server socket may raise a warning messagebox |
||||
# with WinXP firewall, using ipconfig will return all IP addresses |
||||
# including ipv6 ones if available. ipconfig is OK on win98+ |
||||
if {[string equal $::tcl_platform(platform) "windows"]} { |
||||
catch {exec ipconfig} config |
||||
lappend machinfo $config |
||||
} else { |
||||
catch { |
||||
set s [socket -server void -myaddr [info hostname] 0] |
||||
K [fconfigure $s -sockname] [close $s] |
||||
} r |
||||
lappend machinfo $r |
||||
} |
||||
|
||||
if {[package provide Tk] != {}} { |
||||
lappend machinfo [winfo pointerxy .] |
||||
lappend machinfo [winfo id .] |
||||
} |
||||
} else { |
||||
### |
||||
# If the nettool package works on this platform |
||||
# use the stream of hardware ids from it |
||||
### |
||||
lappend machinfo {*}[::nettool::hwid_list] |
||||
} |
||||
return $machinfo |
||||
} |
||||
|
||||
# Generates a binary UUID as per the draft spec. We generate a pseudo-random |
||||
# type uuid (type 4). See section 3.4 |
||||
# |
||||
proc ::uuid::generate_tcl {} { |
||||
package require md5 2 |
||||
variable uid |
||||
|
||||
set tok [md5::MD5Init] |
||||
md5::MD5Update $tok [incr uid]; # package incrementing counter |
||||
foreach string [generate_tcl_machinfo] { |
||||
md5::MD5Update $tok $string |
||||
} |
||||
set r [md5::MD5Final $tok] |
||||
binary scan $r c* r |
||||
|
||||
# 3.4: set uuid versioning fields |
||||
lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] |
||||
lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] |
||||
|
||||
return [binary format c* $r] |
||||
} |
||||
|
||||
if {[string equal $tcl_platform(platform) "windows"] |
||||
&& [package provide critcl] != {}} { |
||||
namespace eval uuid { |
||||
critcl::ccode { |
||||
#define WIN32_LEAN_AND_MEAN |
||||
#define STRICT |
||||
#include <windows.h> |
||||
#include <ole2.h> |
||||
typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); |
||||
typedef const unsigned char cu_char; |
||||
} |
||||
critcl::cproc generate_c {Tcl_Interp* interp} ok { |
||||
HRESULT hr = S_OK; |
||||
int r = TCL_OK; |
||||
UUID uuid = {0}; |
||||
HMODULE hLib; |
||||
LPFNUUIDCREATE lpfnUuidCreate = NULL; |
||||
hLib = LoadLibraryA(("rpcrt4.dll")); |
||||
if (hLib) |
||||
lpfnUuidCreate = (LPFNUUIDCREATE) |
||||
GetProcAddress(hLib, "UuidCreate"); |
||||
if (lpfnUuidCreate) { |
||||
Tcl_Obj *obj; |
||||
lpfnUuidCreate(&uuid); |
||||
obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); |
||||
Tcl_SetObjResult(interp, obj); |
||||
} else { |
||||
Tcl_SetResult(interp, "error: failed to create a guid", |
||||
TCL_STATIC); |
||||
r = TCL_ERROR; |
||||
} |
||||
return r; |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Convert a binary uuid into its string representation. |
||||
# |
||||
proc ::uuid::tostring {uuid} { |
||||
binary scan $uuid H* s |
||||
foreach {a b} {0 7 8 11 12 15 16 19 20 end} { |
||||
append r [string range $s $a $b] - |
||||
} |
||||
return [string tolower [string trimright $r -]] |
||||
} |
||||
|
||||
# Convert a string representation of a uuid into its binary format. |
||||
# |
||||
proc ::uuid::fromstring {uuid} { |
||||
return [binary format H* [string map {- {}} $uuid]] |
||||
} |
||||
|
||||
# Compare two uuids for equality. |
||||
# |
||||
proc ::uuid::equal {left right} { |
||||
set l [fromstring $left] |
||||
set r [fromstring $right] |
||||
return [string equal $l $r] |
||||
} |
||||
|
||||
# Call our generate uuid implementation |
||||
proc ::uuid::generate {} { |
||||
variable accel |
||||
if {$accel(critcl)} { |
||||
return [generate_c] |
||||
} else { |
||||
return [generate_tcl] |
||||
} |
||||
} |
||||
|
||||
# uuid generate -> string rep of a new uuid |
||||
# uuid equal uuid1 uuid2 |
||||
# |
||||
proc uuid::uuid {cmd args} { |
||||
switch -exact -- $cmd { |
||||
generate { |
||||
if {[llength $args] != 0} { |
||||
return -code error "wrong # args:\ |
||||
should be \"uuid generate\"" |
||||
} |
||||
return [tostring [generate]] |
||||
} |
||||
equal { |
||||
if {[llength $args] != 2} { |
||||
return -code error "wrong \# args:\ |
||||
should be \"uuid equal uuid1 uuid2\"" |
||||
} |
||||
return [eval [linsert $args 0 equal]] |
||||
} |
||||
default { |
||||
return -code error "bad option \"$cmd\":\ |
||||
must be generate or equal" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# LoadAccelerator -- |
||||
# |
||||
# This package can make use of a number of compiled extensions to |
||||
# accelerate the digest computation. This procedure manages the |
||||
# use of these extensions within the package. During normal usage |
||||
# this should not be called, but the test package manipulates the |
||||
# list of enabled accelerators. |
||||
# |
||||
proc ::uuid::LoadAccelerator {name} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $name { |
||||
critcl { |
||||
if {![catch {package require tcllibc}]} { |
||||
set r [expr {[info commands ::uuid::generate_c] != {}}] |
||||
} |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator package:\ |
||||
must be one of [join [array names accel] {, }]" |
||||
} |
||||
} |
||||
set accel($name) $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Try and load a compiled extension to help. |
||||
namespace eval ::uuid { |
||||
variable e {} |
||||
foreach e {critcl} { |
||||
if {[LoadAccelerator $e]} break |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
package provide uuid 1.0.7 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
@ -1,246 +0,0 @@
|
||||
# uuid.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> |
||||
# |
||||
# UUIDs are 128 bit values that attempt to be unique in time and space. |
||||
# |
||||
# Reference: |
||||
# http://www.opengroup.org/dce/info/draft-leach-uuids-guids-01.txt |
||||
# |
||||
# uuid: scheme: |
||||
# http://www.globecom.net/ietf/draft/draft-kindel-uuid-uri-00.html |
||||
# |
||||
# Usage: uuid::uuid generate |
||||
# uuid::uuid equal $idA $idB |
||||
|
||||
package require Tcl 8.5 9 |
||||
|
||||
namespace eval uuid { |
||||
variable accel |
||||
array set accel {critcl 0} |
||||
|
||||
namespace export uuid |
||||
|
||||
variable uid |
||||
if {![info exists uid]} { |
||||
set uid 1 |
||||
} |
||||
|
||||
proc K {a b} {set a} |
||||
} |
||||
|
||||
### |
||||
# Optimization |
||||
# Caches machine info after the first pass |
||||
### |
||||
|
||||
proc ::uuid::generate_tcl_machinfo {} { |
||||
variable machinfo |
||||
if {[info exists machinfo]} { |
||||
return $machinfo |
||||
} |
||||
lappend machinfo [clock seconds]; # timestamp |
||||
lappend machinfo [clock clicks]; # system incrementing counter |
||||
lappend machinfo [info hostname]; # spatial unique id (poor) |
||||
lappend machinfo [pid]; # additional entropy |
||||
lappend machinfo [array get ::tcl_platform] |
||||
|
||||
### |
||||
# If we have /dev/urandom just stream 128 bits from that |
||||
### |
||||
if {[file exists /dev/urandom]} { |
||||
set fin [open /dev/urandom r] |
||||
fconfigure $fin -encoding binary |
||||
binary scan [read $fin 128] H* machinfo |
||||
close $fin |
||||
} elseif {[catch {package require nettool}]} { |
||||
# More spatial information -- better than hostname. |
||||
# bug 1150714: opening a server socket may raise a warning messagebox |
||||
# with WinXP firewall, using ipconfig will return all IP addresses |
||||
# including ipv6 ones if available. ipconfig is OK on win98+ |
||||
if {[string equal $::tcl_platform(platform) "windows"]} { |
||||
catch {exec ipconfig} config |
||||
lappend machinfo $config |
||||
} else { |
||||
catch { |
||||
set s [socket -server void -myaddr [info hostname] 0] |
||||
K [fconfigure $s -sockname] [close $s] |
||||
} r |
||||
lappend machinfo $r |
||||
} |
||||
|
||||
if {[package provide Tk] != {}} { |
||||
lappend machinfo [winfo pointerxy .] |
||||
lappend machinfo [winfo id .] |
||||
} |
||||
} else { |
||||
### |
||||
# If the nettool package works on this platform |
||||
# use the stream of hardware ids from it |
||||
### |
||||
lappend machinfo {*}[::nettool::hwid_list] |
||||
} |
||||
return $machinfo |
||||
} |
||||
|
||||
# Generates a binary UUID as per the draft spec. We generate a pseudo-random |
||||
# type uuid (type 4). See section 3.4 |
||||
# |
||||
proc ::uuid::generate_tcl {} { |
||||
package require md5 2 |
||||
variable uid |
||||
|
||||
set tok [md5::MD5Init] |
||||
md5::MD5Update $tok [incr uid]; # package incrementing counter |
||||
foreach string [generate_tcl_machinfo] { |
||||
md5::MD5Update $tok $string |
||||
} |
||||
set r [md5::MD5Final $tok] |
||||
binary scan $r c* r |
||||
|
||||
# 3.4: set uuid versioning fields |
||||
lset r 8 [expr {([lindex $r 8] & 0x3F) | 0x80}] |
||||
lset r 6 [expr {([lindex $r 6] & 0x0F) | 0x40}] |
||||
|
||||
return [binary format c* $r] |
||||
} |
||||
|
||||
if {[string equal $tcl_platform(platform) "windows"] |
||||
&& [package provide critcl] != {}} { |
||||
namespace eval uuid { |
||||
critcl::ccode { |
||||
#define WIN32_LEAN_AND_MEAN |
||||
#define STRICT |
||||
#include <windows.h> |
||||
#include <ole2.h> |
||||
typedef long (__stdcall *LPFNUUIDCREATE)(UUID *); |
||||
typedef const unsigned char cu_char; |
||||
} |
||||
critcl::cproc generate_c {Tcl_Interp* interp} ok { |
||||
HRESULT hr = S_OK; |
||||
int r = TCL_OK; |
||||
UUID uuid = {0}; |
||||
HMODULE hLib; |
||||
LPFNUUIDCREATE lpfnUuidCreate = NULL; |
||||
hLib = LoadLibraryA(("rpcrt4.dll")); |
||||
if (hLib) |
||||
lpfnUuidCreate = (LPFNUUIDCREATE) |
||||
GetProcAddress(hLib, "UuidCreate"); |
||||
if (lpfnUuidCreate) { |
||||
Tcl_Obj *obj; |
||||
lpfnUuidCreate(&uuid); |
||||
obj = Tcl_NewByteArrayObj((cu_char *)&uuid, sizeof(uuid)); |
||||
Tcl_SetObjResult(interp, obj); |
||||
} else { |
||||
Tcl_SetResult(interp, "error: failed to create a guid", |
||||
TCL_STATIC); |
||||
r = TCL_ERROR; |
||||
} |
||||
return r; |
||||
} |
||||
} |
||||
} |
||||
|
||||
# Convert a binary uuid into its string representation. |
||||
# |
||||
proc ::uuid::tostring {uuid} { |
||||
binary scan $uuid H* s |
||||
foreach {a b} {0 7 8 11 12 15 16 19 20 end} { |
||||
append r [string range $s $a $b] - |
||||
} |
||||
return [string tolower [string trimright $r -]] |
||||
} |
||||
|
||||
# Convert a string representation of a uuid into its binary format. |
||||
# |
||||
proc ::uuid::fromstring {uuid} { |
||||
return [binary format H* [string map {- {}} $uuid]] |
||||
} |
||||
|
||||
# Compare two uuids for equality. |
||||
# |
||||
proc ::uuid::equal {left right} { |
||||
set l [fromstring $left] |
||||
set r [fromstring $right] |
||||
return [string equal $l $r] |
||||
} |
||||
|
||||
# Call our generate uuid implementation |
||||
proc ::uuid::generate {} { |
||||
variable accel |
||||
if {$accel(critcl)} { |
||||
return [generate_c] |
||||
} else { |
||||
return [generate_tcl] |
||||
} |
||||
} |
||||
|
||||
# uuid generate -> string rep of a new uuid |
||||
# uuid equal uuid1 uuid2 |
||||
# |
||||
proc uuid::uuid {cmd args} { |
||||
switch -exact -- $cmd { |
||||
generate { |
||||
if {[llength $args] != 0} { |
||||
return -code error "wrong # args:\ |
||||
should be \"uuid generate\"" |
||||
} |
||||
return [tostring [generate]] |
||||
} |
||||
equal { |
||||
if {[llength $args] != 2} { |
||||
return -code error "wrong \# args:\ |
||||
should be \"uuid equal uuid1 uuid2\"" |
||||
} |
||||
return [eval [linsert $args 0 equal]] |
||||
} |
||||
default { |
||||
return -code error "bad option \"$cmd\":\ |
||||
must be generate or equal" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# LoadAccelerator -- |
||||
# |
||||
# This package can make use of a number of compiled extensions to |
||||
# accelerate the digest computation. This procedure manages the |
||||
# use of these extensions within the package. During normal usage |
||||
# this should not be called, but the test package manipulates the |
||||
# list of enabled accelerators. |
||||
# |
||||
proc ::uuid::LoadAccelerator {name} { |
||||
variable accel |
||||
set r 0 |
||||
switch -exact -- $name { |
||||
critcl { |
||||
if {![catch {package require tcllibc}]} { |
||||
set r [expr {[info commands ::uuid::generate_c] != {}}] |
||||
} |
||||
} |
||||
default { |
||||
return -code error "invalid accelerator package:\ |
||||
must be one of [join [array names accel] {, }]" |
||||
} |
||||
} |
||||
set accel($name) $r |
||||
} |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
|
||||
# Try and load a compiled extension to help. |
||||
namespace eval ::uuid { |
||||
variable e {} |
||||
foreach e {critcl} { |
||||
if {[LoadAccelerator $e]} break |
||||
} |
||||
unset e |
||||
} |
||||
|
||||
package provide uuid 1.0.8 |
||||
|
||||
# ------------------------------------------------------------------------- |
||||
# Local variables: |
||||
# mode: tcl |
||||
# indent-tabs-mode: nil |
||||
# End: |
||||
Binary file not shown.
@ -0,0 +1,6 @@
|
||||
package provide app_project 0.1 |
||||
|
||||
puts stderr "app_project package loaded. Todo: customize" |
||||
# add behaviour based on $::argc $::argv here |
||||
# or alternatively - just package require a lib/module which examines the arguments |
||||
# package require projectcore 1.0 |
||||
@ -0,0 +1 @@
|
||||
package ifneeded app-project 0.1 [list source [file join $dir app_project.tcl]] |
||||
@ -0,0 +1,881 @@
|
||||
|
||||
|
||||
#main.tcl - we expect to be in the context of a zipkit or tclkit vfs attached to a tcl executable. |
||||
# or cookfs ? |
||||
#review - what happens if multiple are somehow attached and for example both vfs and zipfs are available? |
||||
# - if that's even possible - we have no control here over which main.tcl was selected as we're already here |
||||
# a metakit data portion seems to need to be add the end of the file (from looking at sdx.kit code) |
||||
# - todo - investigate if zipfs can be inserted between starkit head executable and metakit tail data |
||||
#The logic below will add appropriate package paths from starkit and zipfs vfs paths |
||||
# - and restrict package paths to those coming from a vfs (if not launched with 'dev' or 'os' first arg which allows external paths to remain) |
||||
|
||||
|
||||
|
||||
apply { args { |
||||
set tclmajorv [lindex [split [info tclversion] .] 0] |
||||
namespace eval ::punkboot { |
||||
#This is somewhat ugly - but we don't want to do any 'package require' operations at this stage |
||||
# even for something that is available in tcl_library. |
||||
#review |
||||
proc platform_generic {} { |
||||
#platform::generic - snipped straight from platform package |
||||
global tcl_platform |
||||
|
||||
set plat [string tolower [lindex $tcl_platform(os) 0]] |
||||
set cpu $tcl_platform(machine) |
||||
|
||||
switch -glob -- $cpu { |
||||
sun4* { |
||||
set cpu sparc |
||||
} |
||||
intel - |
||||
ia32* - |
||||
i*86* { |
||||
set cpu ix86 |
||||
} |
||||
x86_64 { |
||||
if {$tcl_platform(wordSize) == 4} { |
||||
# See Example <1> at the top of this file. |
||||
set cpu ix86 |
||||
} |
||||
} |
||||
ppc - |
||||
"Power*" { |
||||
set cpu powerpc |
||||
} |
||||
"arm*" { |
||||
set cpu arm |
||||
} |
||||
ia64 { |
||||
if {$tcl_platform(wordSize) == 4} { |
||||
append cpu _32 |
||||
} |
||||
} |
||||
} |
||||
|
||||
switch -glob -- $plat { |
||||
windows { |
||||
if {$tcl_platform(platform) == "unix"} { |
||||
set plat cygwin |
||||
} else { |
||||
set plat win32 |
||||
} |
||||
if {$cpu eq "amd64"} { |
||||
# Do not check wordSize, win32-x64 is an IL32P64 platform. |
||||
set cpu x86_64 |
||||
} |
||||
} |
||||
sunos { |
||||
set plat solaris |
||||
if {[string match "ix86" $cpu]} { |
||||
if {$tcl_platform(wordSize) == 8} { |
||||
set cpu x86_64 |
||||
} |
||||
} elseif {![string match "ia64*" $cpu]} { |
||||
# sparc |
||||
if {$tcl_platform(wordSize) == 8} { |
||||
append cpu 64 |
||||
} |
||||
} |
||||
} |
||||
darwin { |
||||
set plat macosx |
||||
# Correctly identify the cpu when running as a 64bit |
||||
# process on a machine with a 32bit kernel |
||||
if {$cpu eq "ix86"} { |
||||
if {$tcl_platform(wordSize) == 8} { |
||||
set cpu x86_64 |
||||
} |
||||
} |
||||
} |
||||
aix { |
||||
set cpu powerpc |
||||
if {$tcl_platform(wordSize) == 8} { |
||||
append cpu 64 |
||||
} |
||||
} |
||||
hp-ux { |
||||
set plat hpux |
||||
if {![string match "ia64*" $cpu]} { |
||||
set cpu parisc |
||||
if {$tcl_platform(wordSize) == 8} { |
||||
append cpu 64 |
||||
} |
||||
} |
||||
} |
||||
osf1 { |
||||
set plat tru64 |
||||
} |
||||
default { |
||||
set plat [lindex [split $plat _-] 0] |
||||
} |
||||
} |
||||
|
||||
return "${plat}-${cpu}" |
||||
} |
||||
} |
||||
|
||||
set has_zipfs [expr {[info commands tcl::zipfs::root] ne ""}] |
||||
if {$has_zipfs} { |
||||
set has_zipfs_attached [expr {[llength [tcl::zipfs::mount]]}] |
||||
} else { |
||||
set has_zipfs_attached 0 |
||||
} |
||||
|
||||
#REVIEW - cookit/cookfs can be compiled with a different name for it's mount-point |
||||
# - we could examine the -handle from 'file attr' for each //something:/ volume (excluding //zipfs:/) |
||||
# - but there are situations where handle is empty (? punk repl issue?) |
||||
# - for now we only support the known name - REVIEW |
||||
set has_cookfs [expr {"//cookit:/" in [file volumes]}] |
||||
set cookbase //cookit:/ ;#always define it so we can test on it later.. |
||||
if {$has_cookfs} { |
||||
set has_cookfs_attached [file exists //cookit:/lib] ;# //cookit:/manifest.txt ? REVIEW |
||||
} else { |
||||
set has_cookfs_attached 0 |
||||
} |
||||
|
||||
|
||||
#here we make an attempt to avoid premature (costly) auto_path/tcl::tm::list scanning caused by our initial 'package require starkit'. |
||||
#we will first look for a starkit.tcl in an expected location and try to load that, then fallback to package require. |
||||
|
||||
#standard way to avoid symlinking issues - review! |
||||
set normscript [file dirname [file normalize [file join [info script] __dummy__]]] |
||||
|
||||
#The normalize is important as capitalisation must be retained (on all platforms) |
||||
set normexe [file dirname [file normalize [file join [info nameofexecutable] __dummy__]]] |
||||
|
||||
|
||||
#puts stderr "STARKIT: [package provide starkit]" |
||||
|
||||
set topdir [file dirname $normscript] |
||||
set found_starkit_tcl 0 |
||||
set possible_lib_vfs_folders [glob -nocomplain -dir [file join $topdir lib] -type d vfs*] |
||||
if {$has_zipfs_attached} { |
||||
if {[file exists [zipfs root]/app/tcl_library]} { |
||||
lappend possible_lib_vfs_folders {*}[glob -nocomplain -dir [zipfs root]/app/tcl_library -type d vfs*] |
||||
} |
||||
} |
||||
foreach test_folder $possible_lib_vfs_folders { |
||||
#e.g <name_of_exe>/lib/vfs1.4.1 |
||||
#we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders. |
||||
#order of folder processing shouldn't matter (rely on order returned by 'package versions' - review) |
||||
if {[file exists $test_folder/starkit.tcl] && [file exists $test_folder/pkgIndex.tcl]} { |
||||
set dir $test_folder |
||||
source $test_folder/pkgIndex.tcl |
||||
} |
||||
} |
||||
#package versions does not always return versions in increasing order! |
||||
if {[set starkitv [lindex [lsort -command {package vcompare} [package versions starkit]] end]] ne ""} { |
||||
#run the ifneeded script for the latest found (assuming package versions ordering is correct) |
||||
#puts "111 autopath: $::auto_path" |
||||
eval [package ifneeded starkit $starkitv] |
||||
set found_starkit_tcl 1 |
||||
#puts "222 autopath: $::auto_path" |
||||
} |
||||
if {!$found_starkit_tcl} { |
||||
#our internal 'quick' search for starkit failed. |
||||
#either we are in a pure zipfs system, or cookfs - or the starkit package is somewhere more devious |
||||
#for pure zipfs or cookfs - it's a little wasteful to perform exhaustive search for starkit |
||||
#review - only keep searching if not 'dev' first arg? |
||||
|
||||
#Initially we've done no scans of auto_path/tcl::tm::list - but there will already be a core set of packages known by the kit |
||||
#retain it so we can 'forget' the difference after our first 'package require' forces a full scan which includes some paths we may not wish to include or at least include with different preferences |
||||
#puts "main.tcl 1)--> package name count: [llength [package names]]" |
||||
#puts stderr [join [package names] \n] |
||||
set original_packages [package names] |
||||
|
||||
#This is what we were trying to avoid - a package require causing a scan of ::auto_path and tcl::tm::list |
||||
if {![catch {package require starkit}]} { |
||||
#known side-effects of starkit::startup |
||||
#sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced} |
||||
#set the ::starkit::topdir variable |
||||
#if mode not starpack, then: |
||||
# - adds $::starkit::topdir/lib to the auto_path if not already present |
||||
# |
||||
#In the context of a metakit vfs attached to tcl kit executable - we expect the launch mode to be 'starkit' |
||||
set starkit_startmode [starkit::startup] |
||||
#However - we may also get here for a zipfs enabled tcl with a zifps vfs attached - but which has vlerq, starkit and vfs libraries available, |
||||
#in which case the mode seems to be reported as 'unwrapped' |
||||
#puts stderr "STARKIT MODE: $starkit_startmode" |
||||
} |
||||
#puts "main.tcl 2)--> package name count: [llength [package names]]" |
||||
foreach pkg [package names] { |
||||
if {$pkg ni $original_packages} { |
||||
package forget $pkg |
||||
} |
||||
} |
||||
#puts "main.tcl 3)--> package name count: [llength [package names]]" |
||||
} |
||||
|
||||
|
||||
|
||||
# -- --- --- |
||||
#when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it. review - for what versions of Tcl does this apply? |
||||
#known to occur in old 8.6.8 kits as well as 8.7 |
||||
#review - do we want $normexe or [info nameofexecutable] for $thisexe here? Presumably [info nameofexecutable] (possible symlink) ok |
||||
#we want to be able to launch a process from the interactive shell using the same name this one was launched with. |
||||
set thisexe [file tail [info nameofexecutable]] ;#e.g punk86.exe |
||||
set thisexeroot [file rootname $thisexe] ;#e.g punk86 |
||||
set ::auto_execs($thisexeroot) [info nameofexecutable] |
||||
if {$thisexe ne $thisexeroot} { |
||||
#on windows make the .exe point there too |
||||
set ::auto_execs($thisexe) [info nameofexecutable] |
||||
} |
||||
# -- --- --- |
||||
|
||||
set tm_additions_internal [list] |
||||
set tm_additions_dev [list] |
||||
set auto_path_additions_internal [list] |
||||
set auto_path_additions_dev [list] |
||||
|
||||
set lc_auto_path [string tolower $::auto_path] |
||||
|
||||
#inital auto_path setup by init.tcl |
||||
#firstly it includes env(TCLLIBPATH) |
||||
#then it adds the tcl_library folder and its parent |
||||
#e.g //zipfs:/app/tcl_library and //zipfs:/app |
||||
#when 'dev' or 'os' is not supplied - any non internal paths (usually those from env(TCLLIBPATH) will be stripped |
||||
#so that everything is self-contained in the kit/zipkit |
||||
|
||||
#puts "\x1b\[1\;33m main.tcl original auto_path: $::auto_path" |
||||
|
||||
if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} { |
||||
set kp $::tcl::kitpath |
||||
set kp [file normalize $kp] ;#tcl::kitpath needs to be capitalised as per the actual path |
||||
|
||||
#set existing_module_paths [string tolower [tcl::tm::list]] |
||||
foreach p [list modules modules_tcl$tclmajorv] { |
||||
#if {[string tolower [file join $kp $p]] ni $existing_module_paths} { |
||||
# tcl::tm::add [file join $kp $p] |
||||
#} |
||||
lappend tm_additions_internal [file join $kp $p] |
||||
} |
||||
foreach p [list lib lib_tcl$tclmajorv] { |
||||
lappend auto_path_additions_internal [file join $kp $p] |
||||
} |
||||
} |
||||
if {$has_zipfs_attached} { |
||||
#review build option may be different - tclZipFs.c ZIPFS_APP_MOUNT defaults to ZIPFS_VOLUME/app - but it could be something else. (why?) |
||||
#default 'zipfs root' has trailing slash (//zipfs:/) - but file join does the right thing |
||||
set zipbase [file join [tcl::zipfs::root] app] |
||||
if {"$zipbase" in [tcl::zipfs::mount]} { |
||||
#set existing_module_paths [string tolower [tcl::tm::list]] |
||||
foreach p [list modules modules_tcl$tclmajorv] { |
||||
#if {[string tolower [file join $zipbase $p]] ni $existing_module_paths} { |
||||
# tcl::tm::add [file join $zipbase $p] |
||||
#} |
||||
lappend tm_additions_internal [file join $zipbase $p] |
||||
} |
||||
foreach p [list lib lib_tcl$tclmajorv] { |
||||
lappend auto_path_additions_internal [file join $zipbase $p] |
||||
} |
||||
} |
||||
} |
||||
if {$has_cookfs_attached} { |
||||
#set existing_module_paths [string tolower [tcl::tm::list]] |
||||
foreach p [list modules modules_tcl$tclmajorv] { |
||||
#if {[string tolower [file join $cookbase $p]] ni $existing_module_paths} { |
||||
# tcl::tm::add [file join $cookbase $p] |
||||
#} |
||||
lappend tm_additions_internal [file join $cookbase $p] |
||||
} |
||||
foreach p [list lib lib_tcl$tclmajorv] { |
||||
lappend auto_path_additions_internal [file join $cookbase $p] |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
set internal_paths [list] |
||||
if {$has_zipfs} { |
||||
set ziproot [tcl::zipfs::root] ;#root is enough to determine internal zipkit path |
||||
lappend internal_paths $ziproot |
||||
} |
||||
if {[info exists ::tcl::kitpath] && $::tcl::kitpath ne ""} { |
||||
lappend internal_paths $::tcl::kitpath |
||||
} |
||||
if {$has_cookfs} { |
||||
lappend internal_paths $cookbase |
||||
} |
||||
|
||||
#REVIEW |
||||
if {[info exists ::punkboot::internal_paths] && [llength $::punkboot::internal_paths]} { |
||||
#somewhat ugly cooperation with external sourcing scripts |
||||
lappend internal_paths {*}$::punkboot::internal_paths |
||||
} |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------------------------------------- |
||||
# dev - refers to module and library paths relative to the project (executable path) |
||||
# os - refers to modules and library paths gleaned from ::env (TCLLIBPATH and TCL<MAJOR>_<MINOR>_TM_PATH) |
||||
# internal - refers to modules and libraries supplied from the mounted filesystem of a kit or zipfs based executable |
||||
# ----------------------------------------------------------------------------------------------------------- |
||||
# Note that unlike standard 'package unknown' punk::libunknown does not stop searching for packages when a .tm file is found that matches requirements, |
||||
# The auto_path is still examined. (avoids quirks where higher versioned pkgIndex based package not always found) |
||||
# ----------------------------------------------------------------------------------------------------------- |
||||
set all_package_modes [list dev os internal] |
||||
#package_mode is specified as a dash-delimited ordered value e.g dev-os |
||||
#"internal" is the default and if not present is always added to the list |
||||
#i.e "dev-os" is equivalent to "dev-os-internal" |
||||
#"os" is equivalent to "os-internal" |
||||
#"internal-os" and "internal" are left as is. |
||||
#The effective package_mode has 1 2 or 3 members. |
||||
# The only case where it has 1 member is if just "internal" is specified. |
||||
#This gives the number of permutations as how many ways to choose 3 items plus how many ways to choose 2 of the 3 items (one must be 'internal') plus the sole allowable way to choose 1 |
||||
#for a total of 11 possible final orderings. |
||||
#(16 possible values for package_mode argument when you include the short-forms "",os,dev,os-dev,dev-os which always have 'internal' appended) |
||||
set test_package_mode [lindex $args 0] |
||||
|
||||
switch -exact -- $test_package_mode { |
||||
internal - |
||||
os-internal - dev-internal - internal-os - internal-dev - |
||||
os-dev-internal - os-internal-dev - dev-os-internal - dev-internal-os - internal-os-dev - internal-dev-os { |
||||
#fully specified ('internal' is present) |
||||
set package_modes [split $test_package_mode -] |
||||
set arglist [lrange $args 1 end] |
||||
} |
||||
os - dev - os-dev - dev-os { |
||||
#partially specified - 'internal' ommitted but implied at tail |
||||
set package_modes [list {*}[split $test_package_mode -] internal] |
||||
set arglist [lrange $args 1 end] |
||||
} |
||||
default { |
||||
#empty first arg - or some unrelated arg |
||||
set package_modes internal |
||||
if {$test_package_mode eq ""} { |
||||
#consume the empty first arg as an equivalent of 'internal' |
||||
#don't consume any first arg that isn't recognised as a package_mode |
||||
set arglist [lrange $args 1 end] |
||||
} else { |
||||
set arglist $args |
||||
} |
||||
} |
||||
} |
||||
#assert: arglist has had any first arg that is a package_mode (including empty string) stripped. |
||||
set ::argv $arglist |
||||
set ::argc [llength $arglist] |
||||
#assert: package_modes is now a list of at least length 1 (in which case the only possible value is: internal) |
||||
#Note regarding the use of package forget and binary packages |
||||
#If the package has loaded a binary component - then a package forget and a subsequent package require can result in both binaries being present, as seen in 'info loaded' result - potentially resulting in anomalous behaviour |
||||
#In general package forget after a package has already been required may need special handling and should be avoided where possible. |
||||
#Only a limited set of packages support unloading a binary component anyway. |
||||
#We limit the use of 'package forget' here to packages that have not been loaded (whether pure-tcl or not) |
||||
#ie in this context it is used only for manipulating preferences of which packages are loaded in the first place |
||||
|
||||
#Unintuitive preferencing can occur if the same package version is for example present in a tclkit and in a module or lib folder external to the kit. |
||||
#It may be desired for performance or testing reasons to preference the library outside of the kit - and raising the version number may not always be possible/practical. |
||||
|
||||
#If the executable is a kit - we don't know what packages it contains or whether it allows loading from env based external paths. |
||||
#For app-punk projects - the lib/module paths based on the project being run should take preference if 'dev' is earlier in the list, even if the version number is the same. |
||||
#(these are the 'info nameofexecutable' or 'info script' or 'pwd' relative paths that are added here) |
||||
#Some kits will remove lib/module paths (from auto_path & tcl::tm::list) that have been added via TCLLIBPATH / TCLX_Y_TM_PATH environment variables |
||||
#Some kits will remove those env-provided lib paths but fail to remove the env-provided module paths |
||||
#(differences in boot.tcl in the kits) |
||||
|
||||
if {[llength $package_modes] > 1} { |
||||
#puts stderr "main.tcl PACKAGE MODE is preferencing libraries and modules in the order: $package_modes" |
||||
#puts stderr "main.tcl original auto_path: $::auto_path" |
||||
|
||||
|
||||
#------------------------------------------------------------------------------ |
||||
#Module loading |
||||
#------------------------------------------------------------------------------ |
||||
#If the current directory contains .tm files when the punk repl starts - then it will attempt to preference them |
||||
# - but first add our other known relative modules paths - as it won't make sense to use current directory as a modulepath if it's an ancestor of one of these.. |
||||
|
||||
#original tm list at this point consists of whatever the kit decided + some prepended internal kit paths that punk decided on. |
||||
#we want to bring the existing external paths to the position specified by package_mode (probably from the kit looking at various env TCL* values) |
||||
#we want to maintain the order of the internal paths. |
||||
#we want to add our external dev paths to the position specified by package_mode |
||||
|
||||
#assert [llength [package names]] should be small at this point ~ <10 ? |
||||
|
||||
set original_tm_list [tcl::tm::list] |
||||
tcl::tm::remove {*}$original_tm_list |
||||
|
||||
# -- --- --- --- --- --- --- --- |
||||
#split existing paths into internal & external |
||||
set internal_tm_dirs [list] ;# |
||||
set external_tm_dirs [list] |
||||
set lcase_internal_paths [string tolower $internal_paths] |
||||
foreach tm $original_tm_list { |
||||
#review - do we know original tm list was properly normalised? (need capitalisation consistent for path keys) |
||||
set tmlower [string tolower $tm] |
||||
set is_internal 0 |
||||
foreach okprefix $lcase_internal_paths { |
||||
if {[string match "$okprefix*" $tmlower]} { |
||||
lappend internal_tm_dirs $tm |
||||
set is_internal 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$is_internal} { |
||||
lappend external_tm_dirs $tm |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- |
||||
set original_external_tm_dirs $external_tm_dirs ;#we check some of our additions and bring to front - so we refer to external list as provided by kit |
||||
#assert internal_tm_dirs and external_tm_dirs have their case preserved.. |
||||
|
||||
set module_folders [list] |
||||
|
||||
#review - the below statement doesn't seem to be true. |
||||
#tm list first added end up later in the list - and then override earlier ones if version the same - so add pwd-relative 1st to give higher priority |
||||
#(only if Tcl has scanned all paths - see below bogus package load) |
||||
#1 |
||||
|
||||
#2) |
||||
# .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) |
||||
#using normexe under assumption [info name] might be symlink - and more likely to be where the modules are located. |
||||
#we will try both relative to symlink and relative to underlying exe - with those at symlink location earlier in the list |
||||
#review - a user may have other expectations. |
||||
|
||||
#case differences could represent different paths on unix-like platforms. |
||||
#It's perhaps a little unwise to configure matching paths with only case differences for a cross-platform tool .. but we should support it for those who use it and have no interest in windows - todo! review |
||||
if {"dev" in $package_modes} { |
||||
set normexe_dir [file dirname $normexe] |
||||
if {[file tail $normexe_dir] eq "bin"} { |
||||
#underlying exe in a bin dir - backtrack 1 |
||||
lappend exe_module_folders [file dirname $normexe_dir]/modules |
||||
lappend exe_module_folders [file dirname $normexe_dir]/modules_tcl$tclmajorv |
||||
} else { |
||||
lappend exe_module_folders $normexe_dir/modules |
||||
lappend exe_module_folders $normexe_dir/modules_tcl$tclmajorv |
||||
} |
||||
set nameexe_dir [file dirname [file normalize [info nameofexecutable]]] ;#must be normalized for capitalisation consistency |
||||
|
||||
#possible symlink (may resolve to same path as above - we check below to not add in twice) |
||||
if {[file tail $nameexe_dir] eq "bin"} { |
||||
lappend exe_module_folders [file dirname $nameexe_dir]/modules |
||||
lappend exe_module_folders [file dirname $nameexe_dir]/modules_tcl$tclmajorv |
||||
} else { |
||||
lappend exe_module_folders $nameexe_dir/modules |
||||
lappend exe_module_folders $nameexe_dir/modules_tcl$tclmajorv |
||||
} |
||||
|
||||
#foreach modulefolder $exe_module_folders { |
||||
# set lc_external_tm_dirs [string tolower $external_tm_dirs] |
||||
# set lc_modulefolder [string tolower $modulefolder] |
||||
# if {$lc_modulefolder in [string tolower $original_external_tm_dirs]} { |
||||
# #perhaps we have an env var set pointing to one of our dev foldersl. We don't want to rely on how the kit ordered it. |
||||
# #bring to front if not already there. |
||||
# #assert it must be present in $lc_external_tm_dirs if it's in $original_external_tm_dirs |
||||
# set posn [lsearch $lc_external_tm_dirs $lc_modulefolder] |
||||
# if {$posn > 0} { |
||||
# #don't rely on lremove here. Not all runtimes have it and we don't want to load our forward-compatibility packages yet. |
||||
# #(still need to support tcl 8.6 - and this script used in multiple kits) |
||||
# set external_tm_dirs [lreplace $external_tm_dirs $posn $posn] |
||||
# #don't even add it back in if it doesn't exist in filesystem |
||||
# if {[file isdirectory $modulefolder]} { |
||||
# set external_tm_dirs [linsert $external_tm_dirs 0 $modulefolder] |
||||
# } |
||||
# } |
||||
# } else { |
||||
# if {$lc_modulefolder ni $lc_external_tm_dirs && [file isdirectory $modulefolder]} { |
||||
# set external_tm_dirs [linsert $external_tm_dirs 0 $modulefolder] ;#linsert seems faster than 'concat [list $modulefolder] $external_tm_dirs' - review |
||||
# } |
||||
# } |
||||
#} |
||||
if {![llength $exe_module_folders]} { |
||||
puts stderr "Warning - no 'modules' or 'modules_tcl$tclmajorv' folders found relative to executable (or it's symlink if any)" |
||||
} else { |
||||
set tm_additions_dev $exe_module_folders |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
if {"os" in $package_modes} { |
||||
#2) support developer running from a folder containing *.tm files they want to make available |
||||
# could cause problems if user happens to be in a subdirectory of a tm folder structure as namespaced modules won't work if not at a tm path root. |
||||
#The current dir could also be a subdirectory of an existing tm_dir which would fail during tcl::tm::add - we will need to wrap all additions in catch |
||||
set currentdir_modules [glob -nocomplain -dir [pwd] -type f -tail *.tm] |
||||
#we assume [pwd] will always return an external (not kit) path at this point - REVIEW |
||||
if {[llength $currentdir_modules]} { |
||||
#now add current dir (if no conflict with above) |
||||
set external_tm_dirs [linsert $external_tm_dirs 0 $currentdir_modules] |
||||
if {[file exists [pwd]/modules] || [file exists [pwd]/modules_tcl$tclmajorv]} { |
||||
puts stderr "WARNING: modules or modules_tcl$tclmajorv folders not added to tcl::tm::path due to modules found in current workding dir [pwd]" |
||||
} |
||||
} else { |
||||
#modules or modules_tclX subdir relative to cwd cannot be added if [pwd] has been added |
||||
set cwd_modules_folder [file join [pwd] modules] ;#pwd is already normalized to appropriate capitalisation |
||||
if {[file isdirectory $cwd_modules_folder]} { |
||||
if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} { |
||||
#prepend |
||||
set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder] |
||||
} |
||||
} |
||||
set cwd_modules_folder [file join [pwd] modules_tcl$tclmajorv] |
||||
if {[file isdirectory $cwd_modules_folder]} { |
||||
if {[string tolower $cwd_modules_folder] ni [string tolower $external_tm_dirs]} { |
||||
#prepend |
||||
set external_tm_dirs [linsert $external_tm_dirs 0 $cwd_modules_folder] |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
#assert tcl::tm::list still empty here |
||||
#restore module paths |
||||
# -- --- --- --- --- --- --- --- |
||||
set new_tm_path [list] |
||||
foreach mode $package_modes { |
||||
switch -exact -- $mode { |
||||
internal { |
||||
#review |
||||
#even though the internal_tm_dirs came from either ::env or the executable's init - we don't treat them as 'os' paths |
||||
#Add them before our own internal additions |
||||
foreach n $internal_tm_dirs { |
||||
if {$n ni $new_tm_path} { |
||||
lappend new_tm_path $n |
||||
} |
||||
} |
||||
foreach n $tm_additions_internal { |
||||
if {$n ni $new_tm_path} { |
||||
lappend new_tm_path $n |
||||
} |
||||
} |
||||
} |
||||
dev { |
||||
foreach n $tm_additions_dev { |
||||
if {$n ni $new_tm_path} { |
||||
lappend new_tm_path $n |
||||
} |
||||
} |
||||
} |
||||
os { |
||||
foreach n $external_tm_dirs { |
||||
if {$n ni $new_tm_path} { |
||||
lappend new_tm_path $n |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
foreach p [lreverse $new_tm_path] { |
||||
if {[catch {tcl::tm::add $p} errM]} { |
||||
puts stderr "Failed to add tm module dir '$p' to tcl::tm::list\n$errM" |
||||
} |
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
##tcl::tm::add internals first (so they end up at the end of the tmlist) as in 'dev' mode (dev as first argument on launch) we preference external modules |
||||
##note use of lreverse to maintain same order |
||||
#foreach p [lreverse $internal_tm_dirs] { |
||||
# if {$p ni [tcl::tm::list]} { |
||||
# #Items that end up at the beginning of the tm list are processed first.. but an item of same version later in the tm list will not override the ifneeded script of an already encountered .tm. |
||||
# #addition can fail if one path is a prefix of another |
||||
# if {[catch {tcl::tm::add $p} errM]} { |
||||
# puts stderr "Failed to add internal module dir '$p' to tcl::tm::list\n$errM" |
||||
# } |
||||
# } |
||||
#} |
||||
##push externals to *head* of tcl::tm::list - as they have priority |
||||
#foreach p [lreverse $external_tm_dirs] { |
||||
# if {$p ni [tcl::tm::list]} { |
||||
# if {[catch {tcl::tm::add $p} errM]} { |
||||
# puts stderr "Failed to add external module dir '$p' to tcl::tm::list\n$errM" |
||||
# } |
||||
# } |
||||
#} |
||||
|
||||
#AUTO_PATH |
||||
|
||||
|
||||
#auto_path - add *external* exe-relative after exe-relative path |
||||
#add lib and lib_tcl8 lib_tcl9 etc based on tclmajorv |
||||
#libs appended to end of ::auto_path are processed first (reverse order processing in 'package unknown'), but ifneeded scripts are overridden by earlier ones |
||||
#(ie for both tcl::tm::list and auto_path it is priority by 'order of appearance' in the resultant lists - not the order in which they are added to the lists) |
||||
# |
||||
|
||||
#we can't rely on builtin ledit (tcl9+) or loadable version such as punk::lib::compat::ledit at this point |
||||
#so we prepend to auto_path using a slightly inefficient method. Should be fine on relatively small list like this |
||||
#eventually it should just be something like 'ledit ::auto_path -1 -1 $libfolder' |
||||
if {"dev" in $package_modes} { |
||||
set platform [::punkboot::platform_generic] |
||||
#on windows - case differences dont matter - but can stop us finding path in auto_path |
||||
#on other platforms, case differences could represent different paths |
||||
#review |
||||
set process_folders [list] |
||||
foreach libsub [list lib_tcl$tclmajorv lib] { |
||||
if {[file tail $nameexe_dir] eq "bin"} { |
||||
set libfolder [file dirname $nameexe_dir]/$libsub |
||||
} else { |
||||
set libfolder $nameexe_dir/$libsub |
||||
} |
||||
if {[file isdirectory $libfolder]} { |
||||
#lappend auto_path_additions_dev $libfolder |
||||
lappend process_folders $libfolder |
||||
} |
||||
|
||||
# ------------- |
||||
if {[file tail $normexe_dir] eq "bin"} { |
||||
set libfolder [file dirname $normexe_dir]/$libsub |
||||
} else { |
||||
set libfolder $normexe_dir/$libsub |
||||
} |
||||
if {[file isdirectory $libfolder]} { |
||||
#lappend auto_path_additions_dev $libfolder |
||||
if {$libfolder ni $process_folders} { |
||||
lappend process_folders $libfolder |
||||
} |
||||
} |
||||
# ------------- |
||||
set libfolder [pwd]/$libsub |
||||
if {[file isdirectory $libfolder]} { |
||||
#lappend auto_path_additions_dev $libfolder |
||||
if {$libfolder ni $process_folders} { |
||||
lappend process_folders $libfolder |
||||
} |
||||
} |
||||
} |
||||
foreach f $process_folders { |
||||
if {[string match lib_tcl* [file tail $f]]} { |
||||
if {[file exists $f/allplatforms]} { |
||||
lappend auto_path_additions_dev $f/allplatforms |
||||
} |
||||
if {[file exists $f/$platform]} { |
||||
lappend auto_path_additions_dev $f/$platform |
||||
} |
||||
} else { |
||||
lappend auto_path_additions_dev $f |
||||
} |
||||
} |
||||
|
||||
} |
||||
# -- --- --- --- --- --- --- --- |
||||
#split existing ::auto_path entries into internal & external |
||||
set internal_ap_dirs [list] ;# |
||||
set external_ap_dirs [list] |
||||
set lcase_internal_paths [string tolower $internal_paths] |
||||
foreach pkgpath $::auto_path { |
||||
set pkgpathlower [string tolower $pkgpath] |
||||
set is_internal 0 |
||||
foreach okprefix $lcase_internal_paths { |
||||
if {[string match "$okprefix*" $pkgpathlower]} { |
||||
lappend internal_ap_dirs $pkgpath |
||||
set is_internal 1 |
||||
break |
||||
} |
||||
} |
||||
if {!$is_internal} { |
||||
lappend external_ap_dirs $pkgpath |
||||
} |
||||
} |
||||
# -- --- --- --- --- --- --- --- |
||||
set new_auto_path [list] |
||||
foreach mode $package_modes { |
||||
switch -exact -- $mode { |
||||
internal { |
||||
#review |
||||
#even though the internal_ap_dirs came from either ::env or the executable's init - we don't treat them as 'os' paths |
||||
#Add them before our own internal additions |
||||
foreach n $internal_ap_dirs { |
||||
if {$n ni $new_auto_path} { |
||||
lappend new_auto_path $n |
||||
} |
||||
} |
||||
foreach n $auto_path_additions_internal { |
||||
if {$n ni $new_auto_path} { |
||||
lappend new_auto_path $n |
||||
} |
||||
} |
||||
} |
||||
dev { |
||||
foreach n $auto_path_additions_dev { |
||||
if {$n ni $new_auto_path} { |
||||
lappend new_auto_path $n |
||||
} |
||||
} |
||||
} |
||||
os { |
||||
foreach n $external_ap_dirs { |
||||
if {$n ni $new_auto_path} { |
||||
lappend new_auto_path $n |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
set ::auto_path $new_auto_path |
||||
|
||||
} else { |
||||
#package_mode 'internal' only |
||||
#Tcl_Init will most likely have set up some external paths |
||||
#As our app has been started without first arg (package_mode) indicating anything other than 'internal' - we will prune paths that are not zipfs or tclkit |
||||
#(or set via punkboot::internal_paths) |
||||
set filtered_auto_path [list] |
||||
#review - case insensitive ok for windows - but could cause issues on other platforms? |
||||
foreach ap $::auto_path { |
||||
set aplower [string tolower $ap] |
||||
foreach okprefix $internal_paths { |
||||
if {[string match "[string tolower $okprefix]*" $aplower]} { |
||||
lappend filtered_auto_path $ap |
||||
break |
||||
} |
||||
} |
||||
} |
||||
#puts stderr "main.tcl internal_paths: $internal_paths" |
||||
#puts stderr "main.tcl filtered_auto_path: $filtered_auto_path" |
||||
|
||||
set filtered_tm_list [list] |
||||
foreach tm [tcl::tm::list] { |
||||
set tmlower [string tolower $tm] |
||||
foreach okprefix $internal_paths { |
||||
if {[string match "[string tolower $okprefix]*" $tmlower]} { |
||||
lappend filtered_tm_list $tm |
||||
break |
||||
} |
||||
} |
||||
} |
||||
set new_tm_list [list] |
||||
foreach p $filtered_tm_list { |
||||
if {$p ni $new_tm_list && [file exists $p]} { |
||||
lappend new_tm_list $p |
||||
} |
||||
} |
||||
foreach p $tm_additions_internal { |
||||
if {$p ni $new_tm_list && [file exists $p]} { |
||||
lappend new_tm_list $p |
||||
} |
||||
} |
||||
tcl::tm::remove {*}[tcl::tm::list] |
||||
tcl::tm::add {*}[lreverse $new_tm_list] |
||||
|
||||
|
||||
#If it looks like we are running the vfs/_build/exename.vfs/main.tcl from an external tclsh - try to use vfs folders to simulate kit state |
||||
#set script_relative_lib [file normalize [file join [file dirname [info script]] lib]] |
||||
#set scriptdir [file dirname [info script]] |
||||
set scriptdir [file dirname $normscript] |
||||
if {![string match //zipfs:/* $scriptdir] && ![string match "${cookbase}*" $scriptdir] && ![info exists ::tcl::kitpath]} { |
||||
#presumably running the vfs/xxx.vfs/main.tcl script using a non-kit tclsh that doesn't have starkit lib or mounted zipfs/cookfs available.. lets see if we can move forward anyway |
||||
set vfscontainer [file normalize [file dirname $scriptdir]] |
||||
#set vfscommon [file join $vfscontainer _vfscommon] |
||||
#we shouldn't be targetting the src/vfs folders - use src/_build/exename.vfs instead |
||||
set vfsdir [file normalize $scriptdir] |
||||
set projectroot [file dirname [file dirname $vfscontainer]] ;#back below src/_build/exename.vfs/main.tcl |
||||
puts stdout "no starkit. projectroot?: $projectroot executable:[info nameofexecutable]" |
||||
puts stdout "info lib: [info library]" |
||||
|
||||
#add back the info lib reported by the executable.. as we can't access the one built into a kit |
||||
if {[file exists [info library]]} { |
||||
if {[string tolower [info library]] ni [string tolower [list {*}$filtered_auto_path {*}$auto_path_additions_internal]]} { |
||||
lappend auto_path_additions_internal [info library] |
||||
} |
||||
} |
||||
|
||||
set lib_types [list lib lib_tcl$tclmajorv] |
||||
foreach l $lib_types { |
||||
set lib [file join $vfsdir $l] |
||||
if {[file exists $lib] && [string tolower $lib] ni [string tolower [list {*}$filtered_auto_path {*}$auto_path_additions_internal]]} { |
||||
lappend auto_path_additions_internal $lib |
||||
} |
||||
} |
||||
#foreach l $lib_types { |
||||
# set lib [file join $vfscommon $l] |
||||
# if {[file exists $lib] && [string tolower $lib] ni [string tolower $::auto_path]} { |
||||
# lappend ::auto_path $lib |
||||
# } |
||||
#} |
||||
set ::auto_path [list {*}$filtered_auto_path {*}$auto_path_additions_internal] |
||||
puts stderr "main.tcl final auto_path: $::auto_path" |
||||
|
||||
|
||||
|
||||
set mod_types [list modules modules_tcl$tclmajorv] |
||||
foreach m $mod_types { |
||||
set modpath [file join $vfsdir $m] |
||||
if {[file exists $modpath] && [string tolower $modpath] ni [string tolower [tcl::tm::list]]} { |
||||
tcl::tm::add $modpath |
||||
} |
||||
} |
||||
#foreach m $mod_types { |
||||
# set modpath [file join $vfscommon $m] |
||||
# if {[file exists $modpath] && [string tolower $modpath] ni [string tolower [tcl::tm::list]]} { |
||||
# tcl::tm::add $modpath |
||||
# } |
||||
#} |
||||
} else { |
||||
#normal case main.tcl from vfs |
||||
set ::auto_path [list {*}$filtered_auto_path {*}$auto_path_additions_internal] |
||||
} |
||||
#force rescan |
||||
#catch {package require flobrudder666_nonexistant} |
||||
#puts stderr "main.tcl auto_path :$::auto_path" |
||||
#puts stderr "main.tcl tcl::tm::list:[tcl::tm::list]" |
||||
} |
||||
|
||||
|
||||
|
||||
#-------------------------------------------------------- |
||||
#load libunknown without triggering the existing package unknown |
||||
#maint: also in punk::repl package |
||||
#-------------------------------------------------------- |
||||
set libunks [list] |
||||
foreach tm_path [tcl::tm::list] { |
||||
set punkdir [file join $tm_path punk] |
||||
if {![file exists $punkdir]} {continue} |
||||
lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm] |
||||
} |
||||
set libunknown "" |
||||
set libunknown_version_sofar "" |
||||
foreach lib $libunks { |
||||
#expecting to be of form libunknown-<tclversion>.tm |
||||
set vtail [lindex [split [file tail $lib] -] 1] |
||||
set thisver [file rootname $vtail] ;#file rootname x.y.z.tm |
||||
if {$libunknown_version_sofar eq ""} { |
||||
set libunknown_version_sofar $thisver |
||||
set libunknown $lib |
||||
} else { |
||||
if {[package vcompare $thisver $libunknown_version_sofar] == 1} { |
||||
set libunknown_version_sofar $thisver |
||||
set libunknown $lib |
||||
} |
||||
} |
||||
} |
||||
if {$libunknown ne ""} { |
||||
source $libunknown |
||||
if {[catch {punk::libunknown::init -caller main.tcl} errM]} { |
||||
puts "error initialising punk::libunknown\n$errM" |
||||
} |
||||
} |
||||
#-------------------------------------------------------- |
||||
#Now that new 'package unknown' mechanism is in place - we can use package require |
||||
|
||||
|
||||
#assert arglist has had 'dev|os|os-dev etc' first arg removed if it was present. |
||||
if {[llength $arglist] == 1 && [lindex $arglist 0] eq "tclsh"} { |
||||
#called as <executable> dev tclsh or <executable> tclsh |
||||
#we would like to drop through to standard tclsh repl without launching another process |
||||
#tclMain.c doesn't allow it unless patched. |
||||
if {![info exists ::env(TCLSH_PIPEREPL)]} { |
||||
set is_tclsh_piperepl_env_true 0 |
||||
} else { |
||||
if {[string is boolean -strict $::env(TCLSH_PIPEREPL)]} { |
||||
set is_tclsh_piperepl_env_true $::env(TCLSH_PIPEREPL) |
||||
} else { |
||||
set is_tclsh_piperepl_env_true 0 |
||||
} |
||||
} |
||||
if {!$is_tclsh_piperepl_env_true} { |
||||
puts stderr "tcl_interactive: $::tcl_interactive" |
||||
puts stderr "stdin: [chan configure stdin]" |
||||
puts stderr "Environment variable TCLSH_PIPEREPL is not set or is false or is not a boolean" |
||||
} else { |
||||
#according to env TCLSH_PIPEREPL and our commandline argument - tclsh repl is desired |
||||
#check if tclsh/punk has had the piperepl patch applied - in which case tclsh(istty) should exist |
||||
if {![info exists ::tclsh(istty)]} { |
||||
puts stderr "error: the runtime doesn't appear to have been compiled with the piperepl patch" |
||||
} |
||||
} |
||||
set ::tcl_interactive 1 |
||||
set ::tclsh(dorepl) 1 |
||||
} else { |
||||
package require app-project |
||||
} |
||||
}} {*}$::argv |
||||
Binary file not shown.
Binary file not shown.
@ -0,0 +1,22 @@
|
||||
%PDF-1.7 |
||||
%µ¶ |
||||
|
||||
1 0 obj |
||||
<</Type/Catalog/Pages 2 0 R>> |
||||
endobj |
||||
|
||||
2 0 obj |
||||
<</Type/Pages/Count 0/Kids[]>> |
||||
endobj |
||||
|
||||
xref |
||||
0 3 |
||||
0000000000 00001 f |
||||
0000000016 00000 n |
||||
0000000062 00000 n |
||||
|
||||
trailer |
||||
<</Size 3/Root 1 0 R>> |
||||
startxref |
||||
109 |
||||
%%EOF |
||||
@ -0,0 +1,606 @@
|
||||
# class_Doc.tcl |
||||
# |
||||
# Class mupdf::Doc extends class mupdf::Doc_C (implemented in C) |
||||
|
||||
# - Constructor |
||||
# The following commands create a new Doc object |
||||
# mupdf::Doc new _filename_ |
||||
# mupdf::Doc create id _filename_ |
||||
# mupdf::open _filename_ ?-password _pswd_?" |
||||
# The recommanded way is to call "mupdf::open" |
||||
# |
||||
# - Destructor |
||||
# $docObj destroy |
||||
# $doc quit ;# alias for "$docObj destroy" |
||||
# $doc close ;# save all changes and then quit. |
||||
# When a document is destroyed, all its related objects (Page, TextSearch, ..) |
||||
# are automatically destroyed. |
||||
# |
||||
# - Methods |
||||
# $docObj warnings (* inherithed from Doc_C *) |
||||
# $docObj resetwarnings (* inherithed from Doc_C *) |
||||
# $docObj wasrepaired (* inherithed from Doc_C *) |
||||
# |
||||
# $docObj version (* inherithed from Doc_C *) |
||||
# $docObj fullname (* inherithed from Doc_C *) |
||||
# $docObj authentication (* inherithed from Doc_C *) |
||||
# |
||||
# $docObj opwd _password_ | "" (* inherithed from Doc_C *) |
||||
# $docObj upwd _password_ | "" (* inherithed from Doc_C *) |
||||
# $docObj removepassword |
||||
# |
||||
# $docObj npages (* inherithed from Doc_C *) |
||||
# $docObj getpage _n_ |
||||
# $docObj ispageopened _n_ |
||||
# $docObj openedpages |
||||
# $docObj closepage _n_ |
||||
# $docObj closallpages |
||||
# |
||||
# $docObj haschanges (* inherithed from Doc_C *) |
||||
# $docObj export _filename_ .... |
||||
# |
||||
# $docObj fields (* inherithed from Doc_C *) |
||||
# $docObj signatures (* inherithed from Doc_C *) |
||||
# $docObj addsigfield _fieldname_ .... |
||||
# $docObj field _fieldname_ ?_new_value_? |
||||
# $docObj flatten _fieldname_ ?_fieldname_ ...? (* inherithed from Doc_C *) |
||||
# $docObj fieldattrib _fieldname_ .... (* inherithed from Doc_C *) |
||||
# |
||||
# $docObj portfolio ... (* inherithed from Doc_C *) |
||||
# $docObj anchor _name_ (* inherithed from Doc_C *) |
||||
# |
||||
# $docObj grafts (* inherithed from Doc_C *) |
||||
# $docObj graft $pageObj |
||||
# $docObj embed .... |
||||
# |
||||
# $docObj newsearch ... |
||||
# |
||||
# $docObj addpage ... |
||||
# $docObj deletepage ... |
||||
# $docObj deletepages ... |
||||
# $docObj movepage ... |
||||
|
||||
|
||||
|
||||
oo::class create mupdf::Doc { |
||||
superclass mupdf::Doc_C |
||||
# hide internal C methods |
||||
unexport _RemoveGraftMap |
||||
|
||||
# has-component publisher .. see constructor |
||||
|
||||
# OpenedPages is a dictionary listing all the opened pages (pagenumber) |
||||
# with their pageObj. |
||||
# NOTE that there's a 1:1 relationship between page-numbers and page-objs, |
||||
# so this dictionary could have been inverted (i.e exchanged keys with values) |
||||
|
||||
variable -append OpenedPages |
||||
variable -append RelatedDocs |
||||
|
||||
constructor {args} { |
||||
set OpenedPages [dict create] |
||||
set RelatedDocs [dict create] |
||||
|
||||
# create a publisher component and delegate some methods |
||||
publisher create [self]::publisher |
||||
oo::objdefine [self] forward events [self]::publisher events |
||||
oo::objdefine [self] forward register [self]::publisher register |
||||
oo::objdefine [self] forward unregister [self]::publisher unregister |
||||
|
||||
next {*}$args |
||||
} |
||||
|
||||
destructor { |
||||
# unregister itself from all RelatedDocs notifications .. |
||||
foreach relatedDoc [dict keys $RelatedDocs] { |
||||
$relatedDoc unregister * [self] |
||||
} |
||||
|
||||
if { [info object isa object [self]::publisher] } { |
||||
[self]::publisher destroy |
||||
} |
||||
next |
||||
} |
||||
|
||||
method quit {} { |
||||
my destroy |
||||
} |
||||
|
||||
# save file before destroyng |
||||
method close {} { |
||||
if { [my haschanges] } { |
||||
set origFilename [my fullname] |
||||
# NOTE: you cannot overwrite an opened file, |
||||
# therefore save it with a different name (tmpName) |
||||
# then close it (quit) and finally rename tmpName |
||||
set tmpFilename "${origFilename}.TMP" |
||||
my export $tmpFilename |
||||
|
||||
# since $origFilename is still used by [self], |
||||
# a cmd like 'file rename ...' will ALWAYS fail. |
||||
# Use 'file copy ..' and this will work unless $origFilename |
||||
# is locked by an external app. (e.g. Acrobat) |
||||
# ... this kind of error is exactly what we need to solve .. |
||||
set res [catch {file copy -force -- $tmpFilename $origFilename} errmsg] |
||||
file delete $tmpFilename |
||||
if { $res } { |
||||
# in case of error, don't quit, propagate the error .. |
||||
error $errmsg |
||||
} |
||||
} |
||||
my quit |
||||
} |
||||
|
||||
|
||||
method _removeOpenedPageCb {pageObj} { |
||||
# do a reverse search, we have the value,, then look for its pagenumber |
||||
# note: thisis weird, becuse the page-number of an opened page may change |
||||
# due to addpage/deletepage |
||||
set pageNum -1 |
||||
dict for {k v} $OpenedPages { if {$v eq $pageObj} { set pageNum $k; break } } |
||||
if { $k != -1 } { |
||||
dict unset OpenedPages $pageNum |
||||
} |
||||
} |
||||
|
||||
method getpage {n} { |
||||
if { [dict exists $OpenedPages $n] } { |
||||
return [dict get $OpenedPages $n] |
||||
} |
||||
set page [mupdf::Page new [self] $n] |
||||
# when this page id destroyed, call _removeOpenedpageCb |
||||
$page register !destroyed [self] [oocallback _removeOpenedPageCb $page] |
||||
dict set OpenedPages $n $page |
||||
return $page |
||||
} |
||||
|
||||
#NEW |
||||
# when adding/deleting a page, the OpenedPage dictionary should be updated. |
||||
# On addpage: |
||||
# *before* adding the new page J, all the keys (pagenumeber) for the opened-pages |
||||
# greater-equal than J should be incremented by +1 |
||||
# On deletepage: |
||||
# *after* deleting the page J, all the keys (pagenumber) for the opened-pages |
||||
# greater-equal than J should be incremented by -1 |
||||
# NOTE: in this case the key=J (if present) was previosly removed. |
||||
# |
||||
method _renumberOpenedPagesFrom {J incr} { |
||||
dict map {k v} $OpenedPages { |
||||
if {$k >= $J} {incr k $incr} |
||||
set v $v |
||||
} |
||||
} |
||||
|
||||
# |
||||
# $pdf addpage _i_ ?-size dx dy? |
||||
# if i == "end" --> add after the last page |
||||
# |
||||
# default size: A4 size (595.0x842.0) |
||||
method addpage {args} { |
||||
set idx [next {*}$args] ;# .. may raise error |
||||
# if it didn't fail, update OpenedPages |
||||
set OpenedPages [my _renumberOpenedPagesFrom $idx +1] |
||||
return [my getpage $idx] |
||||
} |
||||
|
||||
# $pdf deletepage _i_" |
||||
method deletepage {args} { |
||||
lassign $args idx |
||||
if { [llength $args] != 1 } { |
||||
# this is expected to fail, but doing so we get the error message |
||||
next {*}$args |
||||
# the following command will be never reached because |
||||
# we expect the above command will raise an error |
||||
error "unexpected behavior in deletepage method" |
||||
} |
||||
# don't care if it's a good idx or a nonsense string (even an empty string) |
||||
if { [my ispageopened $idx] } { |
||||
[my getpage $idx] close ;# this will remove $idx from OpenedPages, too. |
||||
} |
||||
next {*}$args |
||||
set OpenedPages [my _renumberOpenedPagesFrom $idx -1] |
||||
return |
||||
} |
||||
|
||||
# $pdf deletepages i0 i1" |
||||
method deletepages {i0 i1} { |
||||
set N [my npages] |
||||
incr N -1 |
||||
if { ! [string is digit $i0] || $i0 < 0 || $i0 > $N } { error "page number i0 must be between 0 and $N" } |
||||
|
||||
if { ! [string is digit $i1] || $i1 < 0 || $i1 > $N } { error "page number i1 must be between 0 and $N" } |
||||
|
||||
for {set i $i0} {$i<=$i1} {incr i} { |
||||
my deletepage $i0 ;# always delete page i0, following pages will shift ... |
||||
} |
||||
} |
||||
|
||||
# $pdf movepage _from_ _to_ |
||||
method movepage {args} { |
||||
lassign $args from to |
||||
next {*}$args |
||||
# trivial case: if from == to, do nothing. |
||||
if { $from == $to } return |
||||
# save and remove fromPage (if present) |
||||
set savedPageObj "" |
||||
if { [dict exists $OpenedPages $from] } { |
||||
set savedPageObj [dict get $OpenedPages $from] |
||||
set OpenedPages [dict remove $OpenedPages $from] |
||||
} |
||||
set OpenedPages [my _renumberOpenedPagesFrom $from -1] |
||||
set OpenedPages [my _renumberOpenedPagesFrom $to +1] |
||||
if {$savedPageObj ne ""} { |
||||
$savedPageObj close |
||||
# we must recreate the opened page with the same name ! |
||||
mupdf::Page create $savedPageObj [self] $to |
||||
# when this page id destroyed, call _removeOpenedpageCb |
||||
$savedPageObj register !destroyed [self] [oocallback _removeOpenedPageCb $savedPageObj] |
||||
dict set OpenedPages $to $savedPageObj |
||||
} |
||||
return |
||||
} |
||||
|
||||
method ispageopened {n} { |
||||
dict exists $OpenedPages $n |
||||
} |
||||
|
||||
method openedpages {} { |
||||
return [dict keys $OpenedPages] |
||||
} |
||||
|
||||
method closepage {n} { |
||||
if { [dict exists $OpenedPages $n] } { |
||||
set page [dict get $OpenedPages $n] |
||||
$page destroy ;# this will invoke the _removeOpenedPageCb callbak |
||||
} |
||||
} |
||||
|
||||
method closeallpages {} { |
||||
foreach page [dict values $OpenedPages] { |
||||
$page destroy ;# this will invoke the _removeOpenedPageCb callbak |
||||
} |
||||
} |
||||
|
||||
method removepassword {} { |
||||
my opwd "" |
||||
my upwd "" |
||||
} |
||||
|
||||
method export {filename} { |
||||
# allow to (try to) export in itself. (this works only in incremental mode) |
||||
set filename [file normalize $filename] |
||||
if { $filename ne [my fullname] } { |
||||
if { $filename in [mupdf::documentnames] } { |
||||
error "cannot overwrite an opened PDF-file" |
||||
} |
||||
} |
||||
next $filename |
||||
} |
||||
|
||||
# $pdf field _fieldname_ |
||||
# or |
||||
# $pdf field _fieldname_ _value_ |
||||
method field {fieldname args} { |
||||
set value [next $fieldname {*}$args] |
||||
# if OK and args != {} i.e. if we updated some fields, then update all the opened pages |
||||
if { $args != {} } { |
||||
foreach page [dict values $OpenedPages] { |
||||
$page _update |
||||
} |
||||
return |
||||
} else { |
||||
return $value |
||||
} |
||||
} |
||||
|
||||
method flatten {args} { |
||||
next {*}$args |
||||
foreach page [dict values $OpenedPages] { |
||||
$page _update |
||||
} |
||||
} |
||||
|
||||
method addsigfield {fieldname pageNum x0 y0 x1 y1} { |
||||
next $fieldname $pageNum $x0 $y0 $x1 $y1 |
||||
if { [dict exists $OpenedPages $pageNum] } { |
||||
set page [dict get $OpenedPages $pageNum] |
||||
$page _update |
||||
} |
||||
} |
||||
|
||||
method _OnDestroyedRelatedDoc {relatedDoc mapID} { |
||||
my _RemoveGraftMap $mapID |
||||
dict unset RelatedDocs $relatedDoc |
||||
} |
||||
|
||||
method graft {pageObj} { |
||||
try { |
||||
set relatedDoc [$pageObj docref] |
||||
} on error {} { |
||||
error "\"$pageObj\" must be a mupdf::Page" |
||||
} |
||||
|
||||
set relatedDoc [$pageObj docref] |
||||
set mapID "GMAP_$relatedDoc" |
||||
set graftID [next $pageObj $mapID] |
||||
# if everything is OK .. |
||||
|
||||
# when the relatedDoc will be closed, this mapID can be destroyed. |
||||
if { ! [dict exists $RelatedDocs $relatedDoc] } { |
||||
dict set RelatedDocs $relatedDoc 1 |
||||
$relatedDoc register !destroyed [self] [oocallback _OnDestroyedRelatedDoc $relatedDoc $mapID] |
||||
} |
||||
return $graftID |
||||
} |
||||
|
||||
method embed {graftKey pageNum args} { |
||||
next $graftKey $pageNum {*}$args ;# may raise an error message |
||||
if { [dict exists $OpenedPages $pageNum] } { |
||||
set page [dict get $OpenedPages $pageNum] |
||||
$page _update |
||||
} |
||||
} |
||||
|
||||
method newsearch {args} { |
||||
mupdf::TextSearch new [self] {*}$args |
||||
} |
||||
|
||||
} |
||||
|
||||
# add common methods to mupdf::Doc |
||||
oo::objdefine mupdf::Doc { mixin mupdf::COMMON_TYPEMETHODS } |
||||
|
||||
|
||||
# --------------------------------------------------------------------------- |
||||
# Utilities |
||||
# --------------------------------------------------------------------------- |
||||
|
||||
## |
||||
## mupdf::printwarnings |
||||
## |
||||
namespace eval mupdf { |
||||
variable _PRINT_WARNINGS false |
||||
|
||||
proc printwarnings {args} { |
||||
variable _PRINT_WARNINGS |
||||
# safe restore in case someone hacked this variable |
||||
if { ![info exists _PRINT_WARNINGS] || ! [string is boolean ${_PRINT_WARNINGS}] } { |
||||
puts "Warning: missing or bad value for mupdf::_PRINT_WARNINGS. restored to \"true\"" |
||||
set _PRINT_WARNINGS true |
||||
} |
||||
switch -- [llength $args] { |
||||
0 { return ${_PRINT_WARNINGS} } |
||||
1 { |
||||
set val [lindex $args 0] |
||||
if { $val eq "" || ![string is boolean $val] } { |
||||
error "expected boolean value but got \"$val\"" |
||||
} |
||||
set _PRINT_WARNINGS $val |
||||
} |
||||
default { |
||||
set myName [lindex [info level 0] 0] |
||||
error "wrong # args: must be: $myName ?boolean?" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
|
||||
proc mupdf::open {filename args} { |
||||
set usage "mupdf::open filename ?-password pswd?" |
||||
while { $args != {} } { |
||||
set args [lassign $args arg] |
||||
switch -- $arg { |
||||
"-password" { |
||||
if { $args == {} } { |
||||
error "wrong # args: should be \"$usage\"" |
||||
} |
||||
set args [lassign $args password] |
||||
} |
||||
default { |
||||
error "bad option \"$arg\": should be \"$usage\"" |
||||
} |
||||
} |
||||
} |
||||
|
||||
set pdf [Doc new $filename] |
||||
if { [info exists password] } { |
||||
set status [$pdf _insertpassword $password] |
||||
} else { |
||||
if { [$pdf authentication] == "failed" } { |
||||
if { [catch {package present Tk}] } { |
||||
set askMethod [cli_passwordhelper] |
||||
} else { |
||||
set askMethod [tk_passwordhelper] |
||||
} |
||||
try { |
||||
set pswd [uplevel #0 $askMethod $filename] |
||||
} on error e { |
||||
$pdf destroy |
||||
error $e |
||||
} |
||||
set status [$pdf _insertpassword $pswd] |
||||
} else { |
||||
set status true |
||||
} |
||||
} |
||||
if { ! $status } { |
||||
$pdf destroy |
||||
return -code error -errorcode "MUPDF WRONGPASSWORD" "wrong password" |
||||
} |
||||
return $pdf |
||||
} |
||||
|
||||
# create a new empty PDF (0 pages) |
||||
# return a pdfObj to be used in subsequent operations (addpage ....) |
||||
# NOTE: |
||||
# if filename is locked by another process, this command raise an error like the follwing: |
||||
# "error copying "..../Tpt_NoPage.pdf" to "..filename..": permission denied |
||||
# |
||||
proc mupdf::new {filename} { |
||||
if { [mupdf::isopen $filename] } { |
||||
error "\"$filename\" is currently used by this process" |
||||
} |
||||
# may fail if it's locked by anoter process |
||||
variable _BaseDir |
||||
file copy -force ${_BaseDir}/Tpt_NoPage.pdf $filename |
||||
|
||||
return [mupdf::open $filename] |
||||
} |
||||
|
||||
|
||||
## list all opened documents (as object-commnds) |
||||
proc mupdf::documents {} { |
||||
mupdf::Doc names |
||||
} |
||||
|
||||
## list all opened documents (as normalized fullnames) |
||||
## NOTE: "opened" means "opened by mupdf in this process" |
||||
proc mupdf::documentnames {} { |
||||
set L {} |
||||
foreach docObj [documents] { |
||||
lappend L [$docObj fullname] |
||||
} |
||||
return $L |
||||
} |
||||
|
||||
## check if a given filename is a currently opened document |
||||
## NOTE: "opened" means "opened by mupdf in this process"" |
||||
proc mupdf::isopen {filename} { |
||||
# NOTE: filenames returned by [documentnames] are normalized with the same |
||||
# identical logic; |
||||
# therefore it's enough to check if the "normalized names" are identical. |
||||
expr {[file normalize $filename] in [documentnames]} |
||||
} |
||||
|
||||
## just for 1.x compatibility |
||||
proc mupdf::isobject {obj} { |
||||
info object is object $obj |
||||
} |
||||
|
||||
|
||||
|
||||
## -- utilities for password ----------------------------------------------- |
||||
|
||||
## === Internal procs. ======================================================= |
||||
## WARNING: these are internal and unsupported procs. |
||||
## Do not use them in your apps! |
||||
## =========================================================================== |
||||
|
||||
namespace eval mupdf { |
||||
variable _PasswordHelper |
||||
variable _SerialNo |
||||
|
||||
set _PasswordHelper(cli,default) mupdf::_cli_askpassword |
||||
set _PasswordHelper(tk,default) mupdf::_tk_askpassword |
||||
set _PasswordHelper(cli) $_PasswordHelper(cli,default) |
||||
set _PasswordHelper(tk) $_PasswordHelper(tk,default) |
||||
|
||||
set _SerialNo 0 |
||||
} |
||||
|
||||
|
||||
proc mupdf::_newSerialNo {} { |
||||
variable _SerialNo |
||||
incr _SerialNo |
||||
} |
||||
|
||||
proc mupdf::cli_passwordhelper {args} { |
||||
_passwordhelper cli {*}$args |
||||
} |
||||
proc mupdf::tk_passwordhelper {args} { |
||||
_passwordhelper tk {*}$args |
||||
} |
||||
|
||||
# get/set |
||||
proc mupdf::_passwordhelper {mode args} { |
||||
# mode is cli or tk |
||||
variable _PasswordHelper |
||||
|
||||
switch -- [llength $args] { |
||||
0 { return $_PasswordHelper($mode) } |
||||
1 { |
||||
set cb [lindex $args 0] |
||||
if { $cb == "" } { |
||||
set _PasswordHelper($mode) $_PasswordHelper($mode,default) |
||||
} else { |
||||
set _PasswordHelper($mode) $cb |
||||
} |
||||
} |
||||
default { |
||||
error "wrong # args: should be \"mupdf::${mode}_passwordhelper ?command?\"" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# very very simple |
||||
proc mupdf::_cli_askpassword {filename} { |
||||
puts -nonewline stdout "Enter password for \"[file tail $filename]\":" ; flush stdout |
||||
gets stdin |
||||
} |
||||
|
||||
# ask with timeout |
||||
proc mupdf::_cli_askpassword_timeout {timeout filename} { |
||||
set passGVarName "::mupdf::__TIMEOUT_[_newSerialNo]" |
||||
puts stdout "Enter pass for $filename ($timeout seconds):" ; flush stdout |
||||
# set timeout and fileevent on stdin ; |
||||
# both the timeout and fileevent callback will set the ::PASS global variable |
||||
set afterID [after [expr {1000*$timeout}] [list set $passGVarName "none"] ] |
||||
set oldCmd [fileevent stdin readable] |
||||
fileevent stdin readable [list apply { {f gvarname} { |
||||
upvar #0 $gvarname var |
||||
set var [gets $f] |
||||
}} stdin $passGVarName] |
||||
vwait $passGVarName |
||||
# -- reset timeout and fileevent |
||||
after cancel $afterID |
||||
fileevent stdin readable $oldCmd |
||||
|
||||
# get the result from the global variable, and unset it ! |
||||
set x [set $passGVarName] |
||||
unset $passGVarName |
||||
return $x |
||||
} |
||||
|
||||
|
||||
proc mupdf::_tk_askpassword {filename} { |
||||
# to do: center the window |
||||
set uniqueID [_newSerialNo] |
||||
set passGVarName "::mupdf::__PASS_${uniqueID}" |
||||
|
||||
set password "" |
||||
set topW [toplevel .ask_${uniqueID} -padx 10 -pady 10] |
||||
wm title $topW [file tail $filename] |
||||
wm attributes $topW -topmost true |
||||
label $topW.label -text "Enter password" |
||||
entry $topW.entry -textvariable $passGVarName |
||||
bind $topW.entry <Key-Return> {destroy [winfo toplevel %W]} |
||||
pack $topW.label $topW.entry -side left |
||||
focus $topW.entry |
||||
|
||||
tkwait window $topW |
||||
after 0 [list unset $passGVarName] |
||||
return [set $passGVarName] |
||||
} |
||||
|
||||
proc mupdf::_tk_askpassword:timeout {filename} { |
||||
# to do: center the window |
||||
set uniqueID [_newSerialNo] |
||||
set passGVarName "::mupdf::__PASS_${uniqueID}" |
||||
|
||||
set password "" |
||||
set topW [toplevel .ask_${uniqueID} -padx 10 -pady 10] |
||||
wm title $topW [file tail $filename] |
||||
wm attributes $topW -topmost true |
||||
label $topW.label -text "Enter password" |
||||
entry $topW.entry -textvariable $passGVarName |
||||
bind $topW.entry <Key-Return> {destroy [winfo toplevel %W]} |
||||
pack $topW.label $topW.entry -side left |
||||
focus $topW.entry |
||||
|
||||
set afterID [after [expr {1000*$timeout}] [list destroy $topW] ] |
||||
|
||||
tkwait window $topW |
||||
after 0 [list unset $passGVarName] |
||||
return [set $passGVarName] |
||||
} |
||||
@ -0,0 +1,156 @@
|
||||
# class_Page.tcl |
||||
# |
||||
# class mupdf::Page extends class mupdf::Page_C (implemented in C) |
||||
# plus |
||||
# mudf::imagepattern command. |
||||
|
||||
# - Constructor |
||||
# The direct constructor is rarely used. |
||||
# Usually a new Page is created starting from a Doc object |
||||
# set pageObj [$docObj getpage _n_] |
||||
# Note that if page _n_ is already opened, the previous method returns the same |
||||
# pageObj |
||||
# |
||||
# - Destructor |
||||
# $pageObj destroy |
||||
# $pageObj close ;# alias for "$pageObj destroy" |
||||
# |
||||
# - Methods |
||||
# $pageObj pagenumber (* inherithed from Page_C *) |
||||
# $pageObj size (* inherithed from Page_C *) |
||||
# $pageObj savePNG _filename_ .... (* inherithed from Page_C *) |
||||
# $pageObj saveImage _tkImage_ .... (* inherithed from Page_C *) |
||||
# $pageObj blocks (* inherithed from Page_C *) |
||||
# $pageObj lines (* inherithed from Page_C *) |
||||
# $pageObj text (* inherithed from Page_C *) |
||||
# |
||||
# $pageObj images list ... (* inherithed from Page_C *) |
||||
# $pageObj images extract ... (* inherithed from Page_C *) |
||||
# |
||||
# $pageObj addimage ... (* inherithed from Page_C *) |
||||
# |
||||
# $pageObj annots (* inherithed from Page_C *) |
||||
# $pageObj annot create _type_ ..... (* inherithed from Page_C *) |
||||
# $pageObj annot ?get? _annotID_ (* inherithed from Page_C *) |
||||
# $pageObj annot ?get? _annotID_ -option (* inherithed from Page_C *) |
||||
# $pageObj annot ?set? _annotID_ -option value ...(* inherithed from Page_C *) |
||||
# $pageObj annot flatten _annotID_ ... (* inherithed from Page_C *) |
||||
# $pageObj annot delete _annotID_ ... (* inherithed from Page_C *) |
||||
|
||||
# Command for setting the filename pattern of the extracted images |
||||
# ( see above $pageObj images extract ... ) |
||||
# |
||||
# mupdf::imagepattern |
||||
# mupdf::imagepattern _newPattern_ |
||||
|
||||
|
||||
|
||||
oo::class create mupdf::Page { |
||||
superclass mupdf::Page_C |
||||
# has-component publisher .. see constructor |
||||
|
||||
variable -append DocRef |
||||
|
||||
constructor {docRef pageNum} { |
||||
set DocRef $docRef |
||||
|
||||
# create a publisher component and delegate some methods |
||||
publisher create [self]::publisher |
||||
oo::objdefine [self] forward events [self]::publisher events |
||||
oo::objdefine [self] forward register [self]::publisher register |
||||
oo::objdefine [self] forward unregister [self]::publisher unregister |
||||
|
||||
# when DocRef is destroyed, then destroy this page |
||||
$DocRef register !destroyed [self] [list [self] destroy] |
||||
|
||||
next $DocRef $pageNum |
||||
} |
||||
|
||||
destructor { |
||||
$DocRef unregister * [self] |
||||
if { [info object isa object [self]::publisher] } { |
||||
[self]::publisher destroy |
||||
} |
||||
next |
||||
} |
||||
|
||||
method close {} { |
||||
my destroy |
||||
} |
||||
|
||||
method docref {} { |
||||
return $DocRef |
||||
} |
||||
} |
||||
|
||||
# add common methods to mupdf::Page |
||||
oo::objdefine mupdf::Page { mixin mupdf::COMMON_TYPEMETHODS } |
||||
|
||||
|
||||
|
||||
## |
||||
## mupdf::imagepattern |
||||
## |
||||
namespace eval mupdf { |
||||
|
||||
variable _IMG_PATTERN_SYMBOLS "pPiI" ;# CONSTANT |
||||
variable _IMG_PATTERN "" |
||||
variable _IMG_POSITIONAL_PATTERN "" |
||||
|
||||
proc __positional_pattern { format symbols } { |
||||
set rexpr "%(\[0-9\]*)(\[$symbols\])" ;# if symbols is "ABC" --> %([0-9]*)([ABC]) |
||||
set format [regsub -all $rexpr $format {%\20\1d}] |
||||
|
||||
set symPos 1 |
||||
foreach sym [split $symbols ""] { |
||||
# replace "%S" with "%i$"" ;# S is the symbol, i is its position |
||||
set format [regsub -all "%${sym}" $format "%${symPos}\$"] |
||||
incr symPos |
||||
} |
||||
return $format |
||||
} |
||||
|
||||
proc __used_symbols { pattern symbols } { |
||||
set usedSymbols "" |
||||
set rexpr "%\[0-9\]*(\[$symbols\])" ;# if symbols is "ABC" --> %[0-9]*([ABC]) |
||||
foreach {match sym} [regexp -all -inline $rexpr $pattern] { |
||||
if { [string first $sym $usedSymbols] == -1 } { |
||||
append usedSymbols $sym |
||||
} |
||||
} |
||||
return $usedSymbols |
||||
} |
||||
|
||||
proc _used_symbols {pattern} { |
||||
variable _IMG_PATTERN_SYMBOLS |
||||
__used_symbols $pattern ${_IMG_PATTERN_SYMBOLS} |
||||
} |
||||
|
||||
proc _positional_pattern {pattern} { |
||||
variable _IMG_PATTERN_SYMBOLS |
||||
__positional_pattern $pattern ${_IMG_PATTERN_SYMBOLS} |
||||
} |
||||
|
||||
proc imagepattern {args} { |
||||
variable _IMG_PATTERN |
||||
switch -- [llength $args] { |
||||
0 { return ${_IMG_PATTERN} } |
||||
1 { |
||||
variable _IMG_POSITIONAL_PATTERN |
||||
variable _IMG_USED_SYMBOLS |
||||
|
||||
set pattern [lindex $args 0] |
||||
set _IMG_PATTERN $pattern |
||||
set _IMG_USED_SYMBOLS [_used_symbols ${_IMG_PATTERN}] |
||||
set _IMG_POSITIONAL_PATTERN [_positional_pattern ${_IMG_PATTERN}] |
||||
} |
||||
default { |
||||
set myName [lindex [info level 0] 0] |
||||
error "wrong # args: must be: $myName ?pattern?" |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
imagepattern "IM-%4p" |
||||
} |
||||
@ -0,0 +1,188 @@
|
||||
# class_TextSearch.tcl |
||||
# |
||||
# class mupdf::TextSearch extends class mupdf::TextSearch_C (implemented in C) |
||||
# |
||||
|
||||
# - Constructor |
||||
# The following commands create a new TextSearch object acting on a given mupdf::Doc |
||||
# mupdf::TextSearch new $doc |
||||
# mupdf::TextSearch create id $doc |
||||
# |
||||
# - Destructor |
||||
# $searchObj destroy |
||||
# |
||||
# TextSearch objects are automatically destroyed when the related mupdf::Doc |
||||
# is destroyed. |
||||
# |
||||
# - Methods |
||||
# $searchObj docref |
||||
# $searchObj currpage ?pageNumber? |
||||
# $searchObj find _searchStr_ ?-max _N_? ?-currpage true/false? |
||||
|
||||
# inherithed from TextSearch_C |
||||
# $searchObj _pagesearch .... (low-level method used by 'find' *hidden*) |
||||
|
||||
|
||||
|
||||
oo::class create mupdf::TextSearch { |
||||
superclass mupdf::TextSearch_C |
||||
# hide internal C methods |
||||
unexport _pagesearch |
||||
|
||||
# has-component publisher .. see constructor |
||||
variable -append DocRef |
||||
variable -append CurrPageNumber |
||||
variable -append FromTop |
||||
|
||||
constructor {docRef args} { |
||||
set DocRef $docRef |
||||
# BugFix: Tcl8.6.4 returns an error if $docRef is NOT an object, |
||||
# instead of returning 0 (false). |
||||
# For this reason, do both things: catch the error and check if false |
||||
try { |
||||
set isDoc [info object isa typeof $docRef mupdf::Doc] |
||||
} on error {} { |
||||
set isDoc false |
||||
} |
||||
if { ! $isDoc } { |
||||
error "\"$docRef\" must be an instance of mupdf::Doc" |
||||
} |
||||
|
||||
set CurrPageNumber 0 |
||||
set FromTop true |
||||
|
||||
# create a publisher component and delegate some methods |
||||
publisher create [self]::publisher |
||||
oo::objdefine [self] forward events [self]::publisher events |
||||
oo::objdefine [self] forward register [self]::publisher register |
||||
oo::objdefine [self] forward unregister [self]::publisher unregister |
||||
|
||||
$DocRef register !destroyed [self] [list [self] destroy] |
||||
|
||||
next {*}$args ;# initialize TextSearch_C |
||||
} |
||||
|
||||
destructor { |
||||
catch {$DocRef unregister * [self]} |
||||
|
||||
if { [info object isa object [self]::publisher] } { |
||||
[self]::publisher destroy |
||||
} |
||||
next |
||||
} |
||||
|
||||
method docref {} { |
||||
return $DocRef |
||||
} |
||||
|
||||
# get/set the current search page |
||||
method currpage {args} { |
||||
switch -- [llength $args] { |
||||
0 { |
||||
return $CurrPageNumber |
||||
} |
||||
1 { |
||||
set pageNum [lindex $args 0] |
||||
set lastPage [expr [$DocRef npages] -1] |
||||
if { $pageNum < 0 || $pageNum > $lastPage } { |
||||
error "page-number must be between 0 and $lastPage" |
||||
} |
||||
set CurrPageNumber $pageNum |
||||
set FromTop true |
||||
return $CurrPageNumber |
||||
} |
||||
default { |
||||
error wrong # args: should be "[self] currpage ?pageNumber?" |
||||
} |
||||
} |
||||
} |
||||
|
||||
method find {searchStr args} { |
||||
# default |
||||
set max_hits 10 |
||||
set currpageOnly false |
||||
|
||||
set usage "[self] find _searchStr_ ?-max _N_? ?-currpageonly true/false?" |
||||
|
||||
while { $args != {} } { |
||||
set args [lassign $args opt] |
||||
if { [llength $args] == 0 } { |
||||
error "wrong # args: missing value for the last options \"$opt\"" |
||||
} |
||||
set args [lassign $args value] |
||||
|
||||
switch -- $opt { |
||||
"-max" { |
||||
set max_hits $value |
||||
# this is an arbitrary limit |
||||
if { $max_hits > 100 } { |
||||
error "value for \"${opt}\" must be between 1 and 100" |
||||
} |
||||
} |
||||
"-currpageonly" { |
||||
set currpageOnly $value |
||||
if { ! [string is boolean $currpageOnly] } { |
||||
error "value for \"${opt}\" must be a boolean value" |
||||
} |
||||
} |
||||
default { |
||||
error "bad option \"$opt\": should be \"$usage\"" |
||||
} |
||||
} |
||||
} |
||||
|
||||
# the following method will also update CurrPageNumber and |
||||
# FromTop will be set to false (i.e. next search will continue from the current position |
||||
set L [my _Extended_find $DocRef $CurrPageNumber $searchStr $FromTop $max_hits $currpageOnly] |
||||
return $L |
||||
} |
||||
|
||||
|
||||
# Look for $searchStr from the current search-position on the current page |
||||
# ( unless $resumeFromTop is true). |
||||
# If $currpageonly is true, the search is limited to the current page |
||||
# ( you can change it with $searchObj currpage _N_ ) |
||||
# else the search may continue on the next pages until $max_hits are found |
||||
# (or no more pages exist!). |
||||
# Side-effect: CurrentPageNumber may be changed, FromTop becomes false |
||||
|
||||
# MUMBLING.. : this method may open a lot of pages. |
||||
# Since you cannot simply do a "$doc closeallpages" sinces there may be |
||||
# somepages in use before, evaluate the convenience to check if a page was |
||||
# opened ($doc isopenedpage $n) before calling ($doc getpage $n) ; |
||||
# you could then close these 'new' pages (but please, don't close the |
||||
# last scanned page...it could be useful for more search ...) |
||||
# .. Think it over ... |
||||
method _Extended_find {doc pageNumber searchStr resumeFromTop max_hits currpageOnly} { |
||||
if { $searchStr == {} } { |
||||
error "undefined search string" |
||||
} |
||||
set L {} |
||||
set nPages [$DocRef npages] |
||||
while { true } { |
||||
# the following may fail if pageNumber is invalid .. OK |
||||
set pageHandle [$doc getpage $pageNumber] |
||||
set rectList [my _pagesearch $pageHandle $searchStr $max_hits $resumeFromTop] |
||||
foreach rect $rectList { |
||||
lappend L [list $pageNumber $rect] |
||||
} |
||||
incr max_hits [expr {-[llength $rectList]}] |
||||
|
||||
if { $currpageOnly } break |
||||
|
||||
if { $max_hits == 0 } break |
||||
|
||||
if { $pageNumber+1 == $nPages } { break } |
||||
|
||||
incr pageNumber |
||||
set resumeFromTop true |
||||
} |
||||
set CurrPageNumber $pageNumber |
||||
set FromTop false |
||||
return $L |
||||
} |
||||
|
||||
} |
||||
|
||||
# add common methods to mupdf::TextSearch |
||||
oo::objdefine mupdf::TextSearch { mixin mupdf::COMMON_TYPEMETHODS } |
||||
@ -0,0 +1,104 @@
|
||||
# mupdf.tcl |
||||
# |
||||
# Startup utilities for the Tcl->MuPDF integration |
||||
# Load sub-modules for all the required Classes |
||||
# |
||||
|
||||
|
||||
namespace eval mupdf { |
||||
variable _BaseDir |
||||
set _BaseDir [file dirname [file normalize [info script]]] |
||||
|
||||
set ::auto_path [linsert $::auto_path 0 $_BaseDir/lib] |
||||
} |
||||
|
||||
proc mupdf::_findDLL {dir pkgName} { |
||||
set thisDir [file normalize ${dir}] |
||||
|
||||
set os $::tcl_platform(platform) |
||||
switch -- $os { |
||||
windows { set os win } |
||||
unix { |
||||
switch -- $::tcl_platform(os) { |
||||
Darwin { set os darwin } |
||||
Linux { set os linux } |
||||
} |
||||
} |
||||
} |
||||
set majorVersion [lindex [split [package present Tcl] "."] 0] |
||||
switch -- $majorVersion { |
||||
8 {set vtag "86"} |
||||
9 {set vtag "90"} |
||||
default { error "tclMuPDF: Unsupported Tcl version" } |
||||
} |
||||
switch -- $pkgName { |
||||
MuPDF - |
||||
tkMuPDF { |
||||
set libName "tkMuPDF" |
||||
} |
||||
tclMuPDF { |
||||
set libName "tclMuPDF" |
||||
} |
||||
default { |
||||
error "Unregistered package name \"$pkgName\"" |
||||
} |
||||
} |
||||
|
||||
set tail_libFile ${libName}${vtag}[info sharedlibextension] |
||||
# try to guess the tcl-interpreter architecture (32/64 bit) |
||||
set arch $::tcl_platform(pointerSize) |
||||
switch -- $arch { |
||||
4 { set arch x32 } |
||||
8 { set arch x64 } |
||||
default { error "${pkgName}: Unsupported architecture: Unexpected pointer-size $arch!!! "} |
||||
} |
||||
set dir_libFile [file join $thisDir ${os}-${arch}] |
||||
if { ! [file isdirectory $dir_libFile ] } { |
||||
error "${pkgName}: Unsupported platform ${os}-${arch}" |
||||
} |
||||
|
||||
set full_libFile [file join $dir_libFile $tail_libFile] |
||||
return $full_libFile |
||||
} |
||||
|
||||
# |
||||
# basic module for publish/subscribe pattern |
||||
# |
||||
package require publisher 2.0 |
||||
# helper for defining callbacks |
||||
proc oocallback {args} { |
||||
linsert $args 0 [uplevel 1 [list self namespace]]::my |
||||
} |
||||
|
||||
|
||||
namespace eval mupdf { |
||||
variable _classes |
||||
variable _BaseDir |
||||
|
||||
proc classes {} { |
||||
variable _classes |
||||
return $_classes |
||||
} |
||||
|
||||
proc classinfo {obj} { |
||||
info object class $obj |
||||
} |
||||
|
||||
oo::class create COMMON_TYPEMETHODS { |
||||
# return the (sorted) list of current instances |
||||
method names {} { |
||||
lsort [info class instances [lindex [info level 0] 0]] |
||||
} |
||||
} |
||||
|
||||
# create some basic classes whose implementation will be mostly written in C |
||||
|
||||
foreach clazz {Doc Page TextSearch} { |
||||
lappend _classes [namespace current]::$clazz |
||||
::oo::class create ${clazz}_C { |
||||
# Constructor and methods are written in C |
||||
} |
||||
uplevel #0 source [list [file join $_BaseDir class_${clazz}.tcl]] |
||||
} |
||||
unset clazz |
||||
} |
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in new issue