97 changed files with 8343 additions and 20602 deletions
@ -1,145 +1,145 @@ |
|||||||
# dictutils.tcl -- |
# dictutils.tcl -- |
||||||
# |
# |
||||||
# Various dictionary utilities. |
# Various dictionary utilities. |
||||||
# |
# |
||||||
# Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). |
# Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). |
||||||
# |
# |
||||||
# License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). |
# License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). |
||||||
# |
# |
||||||
|
|
||||||
#2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" |
#2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" |
||||||
|
|
||||||
package require Tcl 8.6- |
package require Tcl 8.6- |
||||||
package provide dictutils 0.2.1 |
package provide dictutils 0.2.1 |
||||||
|
|
||||||
namespace eval dictutils { |
namespace eval dictutils { |
||||||
namespace export equal apply capture witharray nlappend |
namespace export equal apply capture witharray nlappend |
||||||
namespace ensemble create |
namespace ensemble create |
||||||
|
|
||||||
# dictutils witharray dictVar arrayVar script -- |
# dictutils witharray dictVar arrayVar script -- |
||||||
# |
# |
||||||
# Unpacks the elements of the dictionary in dictVar into the array |
# Unpacks the elements of the dictionary in dictVar into the array |
||||||
# variable arrayVar and then evaluates the script. If the script |
# variable arrayVar and then evaluates the script. If the script |
||||||
# completes with an ok, return or continue status, then the result is copied |
# completes with an ok, return or continue status, then the result is copied |
||||||
# back into the dictionary variable, otherwise it is discarded. A |
# back into the dictionary variable, otherwise it is discarded. A |
||||||
# [break] can be used to explicitly abort the transaction. |
# [break] can be used to explicitly abort the transaction. |
||||||
# |
# |
||||||
proc witharray {dictVar arrayVar script} { |
proc witharray {dictVar arrayVar script} { |
||||||
upvar 1 $dictVar dict $arrayVar array |
upvar 1 $dictVar dict $arrayVar array |
||||||
array set array $dict |
array set array $dict |
||||||
try { uplevel 1 $script |
try { uplevel 1 $script |
||||||
} on break {} { # Discard the result |
} on break {} { # Discard the result |
||||||
} on continue result - on ok result { |
} on continue result - on ok result { |
||||||
set dict [array get array] ;# commit changes |
set dict [array get array] ;# commit changes |
||||||
return $result |
return $result |
||||||
} on return {result opts} { |
} on return {result opts} { |
||||||
set dict [array get array] ;# commit changes |
set dict [array get array] ;# commit changes |
||||||
dict incr opts -level ;# remove this proc from level |
dict incr opts -level ;# remove this proc from level |
||||||
return -options $opts $result |
return -options $opts $result |
||||||
} |
} |
||||||
# All other cases will discard the changes and propagage |
# All other cases will discard the changes and propagage |
||||||
} |
} |
||||||
|
|
||||||
# dictutils equal equalp d1 d2 -- |
# dictutils equal equalp d1 d2 -- |
||||||
# |
# |
||||||
# Compare two dictionaries for equality. Two dictionaries are equal |
# Compare two dictionaries for equality. Two dictionaries are equal |
||||||
# if they (a) have the same keys, (b) the corresponding values for |
# if they (a) have the same keys, (b) the corresponding values for |
||||||
# each key in the two dictionaries are equal when compared using the |
# each key in the two dictionaries are equal when compared using the |
||||||
# equality predicate, equalp (passed as an argument). The equality |
# equality predicate, equalp (passed as an argument). The equality |
||||||
# predicate is invoked with the key and the two values from each |
# predicate is invoked with the key and the two values from each |
||||||
# dictionary as arguments. |
# dictionary as arguments. |
||||||
# |
# |
||||||
proc equal {equalp d1 d2} { |
proc equal {equalp d1 d2} { |
||||||
if {[dict size $d1] != [dict size $d2]} { return 0 } |
if {[dict size $d1] != [dict size $d2]} { return 0 } |
||||||
dict for {k v} $d1 { |
dict for {k v} $d1 { |
||||||
if {![dict exists $d2 $k]} { return 0 } |
if {![dict exists $d2 $k]} { return 0 } |
||||||
if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } |
if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } |
||||||
} |
} |
||||||
return 1 |
return 1 |
||||||
} |
} |
||||||
|
|
||||||
# apply dictVar lambdaExpr ?arg1 arg2 ...? -- |
# apply dictVar lambdaExpr ?arg1 arg2 ...? -- |
||||||
# |
# |
||||||
# A combination of *dict with* and *apply*, this procedure creates a |
# A combination of *dict with* and *apply*, this procedure creates a |
||||||
# new procedure scope populated with the values in the dictionary |
# new procedure scope populated with the values in the dictionary |
||||||
# variable. It then applies the lambdaTerm (anonymous procedure) in |
# variable. It then applies the lambdaTerm (anonymous procedure) in |
||||||
# this new scope. If the procedure completes normally, then any |
# this new scope. If the procedure completes normally, then any |
||||||
# changes made to variables in the dictionary are reflected back to |
# changes made to variables in the dictionary are reflected back to |
||||||
# the dictionary variable, otherwise they are ignored. This provides |
# the dictionary variable, otherwise they are ignored. This provides |
||||||
# a transaction-style semantics whereby atomic updates to a |
# a transaction-style semantics whereby atomic updates to a |
||||||
# dictionary can be performed. This procedure can also be useful for |
# dictionary can be performed. This procedure can also be useful for |
||||||
# implementing a variety of control constructs, such as mutable |
# implementing a variety of control constructs, such as mutable |
||||||
# closures. |
# closures. |
||||||
# |
# |
||||||
proc apply {dictVar lambdaExpr args} { |
proc apply {dictVar lambdaExpr args} { |
||||||
upvar 1 $dictVar dict |
upvar 1 $dictVar dict |
||||||
set env $dict ;# copy |
set env $dict ;# copy |
||||||
lassign $lambdaExpr params body ns |
lassign $lambdaExpr params body ns |
||||||
if {$ns eq ""} { set ns "::" } |
if {$ns eq ""} { set ns "::" } |
||||||
set body [format { |
set body [format { |
||||||
upvar 1 env __env__ |
upvar 1 env __env__ |
||||||
dict with __env__ %s |
dict with __env__ %s |
||||||
} [list $body]] |
} [list $body]] |
||||||
set lambdaExpr [list $params $body $ns] |
set lambdaExpr [list $params $body $ns] |
||||||
set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] |
set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] |
||||||
if {$rc == 0} { |
if {$rc == 0} { |
||||||
# Copy back any updates |
# Copy back any updates |
||||||
set dict $env |
set dict $env |
||||||
} |
} |
||||||
return -options $opts $ret |
return -options $opts $ret |
||||||
} |
} |
||||||
|
|
||||||
# capture ?level? ?exclude? ?include? -- |
# capture ?level? ?exclude? ?include? -- |
||||||
# |
# |
||||||
# Captures a snapshot of the current (scalar) variable bindings at |
# Captures a snapshot of the current (scalar) variable bindings at |
||||||
# $level on the stack into a dictionary environment. This dictionary |
# $level on the stack into a dictionary environment. This dictionary |
||||||
# can later be used with *dictutils apply* to partially restore the |
# can later be used with *dictutils apply* to partially restore the |
||||||
# scope, creating a first approximation of closures. The *level* |
# scope, creating a first approximation of closures. The *level* |
||||||
# argument should be of the forms accepted by *uplevel* and |
# argument should be of the forms accepted by *uplevel* and |
||||||
# designates which level to capture. It defaults to 1 as in uplevel. |
# designates which level to capture. It defaults to 1 as in uplevel. |
||||||
# The *exclude* argument specifies an optional list of literal |
# The *exclude* argument specifies an optional list of literal |
||||||
# variable names to avoid when performing the capture. No variables |
# variable names to avoid when performing the capture. No variables |
||||||
# matching any item in this list will be captured. The *include* |
# matching any item in this list will be captured. The *include* |
||||||
# argument can be used to specify a list of glob patterns of |
# argument can be used to specify a list of glob patterns of |
||||||
# variables to capture. Only variables matching one of these |
# variables to capture. Only variables matching one of these |
||||||
# patterns are captured. The default is a single pattern "*", for |
# patterns are captured. The default is a single pattern "*", for |
||||||
# capturing all visible variables (as determined by *info vars*). |
# capturing all visible variables (as determined by *info vars*). |
||||||
# |
# |
||||||
proc capture {{level 1} {exclude {}} {include {*}}} { |
proc capture {{level 1} {exclude {}} {include {*}}} { |
||||||
if {[string is integer $level]} { incr level } |
if {[string is integer $level]} { incr level } |
||||||
set env [dict create] |
set env [dict create] |
||||||
foreach pattern $include { |
foreach pattern $include { |
||||||
foreach name [uplevel $level [list info vars $pattern]] { |
foreach name [uplevel $level [list info vars $pattern]] { |
||||||
if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } |
if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } |
||||||
upvar $level $name value |
upvar $level $name value |
||||||
catch { dict set env $name $value } ;# no arrays |
catch { dict set env $name $value } ;# no arrays |
||||||
} |
} |
||||||
} |
} |
||||||
return $env |
return $env |
||||||
} |
} |
||||||
|
|
||||||
# nlappend dictVar keyList ?value ...? |
# nlappend dictVar keyList ?value ...? |
||||||
# |
# |
||||||
# Append zero or more elements to the list value stored in the given |
# Append zero or more elements to the list value stored in the given |
||||||
# dictionary at the path of keys specified in $keyList. If $keyList |
# dictionary at the path of keys specified in $keyList. If $keyList |
||||||
# specifies a non-existent path of keys, nlappend will behave as if |
# specifies a non-existent path of keys, nlappend will behave as if |
||||||
# the path mapped to an empty list. |
# the path mapped to an empty list. |
||||||
# |
# |
||||||
proc nlappend {dictvar keylist args} { |
proc nlappend {dictvar keylist args} { |
||||||
upvar 1 $dictvar dict |
upvar 1 $dictvar dict |
||||||
if {[info exists dict] && [dict exists $dict {*}$keylist]} { |
if {[info exists dict] && [dict exists $dict {*}$keylist]} { |
||||||
set list [dict get $dict {*}$keylist] |
set list [dict get $dict {*}$keylist] |
||||||
} |
} |
||||||
lappend list {*}$args |
lappend list {*}$args |
||||||
dict set dict {*}$keylist $list |
dict set dict {*}$keylist $list |
||||||
} |
} |
||||||
|
|
||||||
# invoke cmd args... -- |
# invoke cmd args... -- |
||||||
# |
# |
||||||
# Helper procedure to invoke a callback command with arguments at |
# Helper procedure to invoke a callback command with arguments at |
||||||
# the global scope. The helper ensures that proper quotation is |
# the global scope. The helper ensures that proper quotation is |
||||||
# used. The command is expected to be a list, e.g. {string equal}. |
# used. The command is expected to be a list, e.g. {string equal}. |
||||||
# |
# |
||||||
proc invoke {cmd args} { uplevel #0 $cmd $args } |
proc invoke {cmd args} { uplevel #0 $cmd $args } |
||||||
|
|
||||||
} |
} |
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
@ -1,201 +1,201 @@ |
|||||||
#JMN - api should be kept in sync with package patternlib where possible |
#JMN - api should be kept in sync with package patternlib where possible |
||||||
# |
# |
||||||
package provide oolib [namespace eval oolib { |
package provide oolib [namespace eval oolib { |
||||||
variable version |
variable version |
||||||
set version 0.1.2 |
set version 0.1.2 |
||||||
}] |
}] |
||||||
|
|
||||||
namespace eval oolib { |
namespace eval oolib { |
||||||
oo::class create collection { |
oo::class create collection { |
||||||
variable o_data ;#dict |
variable o_data ;#dict |
||||||
#variable o_alias |
#variable o_alias |
||||||
constructor {} { |
constructor {} { |
||||||
set o_data [dict create] |
set o_data [dict create] |
||||||
} |
} |
||||||
method info {} { |
method info {} { |
||||||
return [dict info $o_data] |
return [dict info $o_data] |
||||||
} |
} |
||||||
method count {} { |
method count {} { |
||||||
return [dict size $o_data] |
return [dict size $o_data] |
||||||
} |
} |
||||||
method isEmpty {} { |
method isEmpty {} { |
||||||
expr {[dict size $o_data] == 0} |
expr {[dict size $o_data] == 0} |
||||||
} |
} |
||||||
method names {{globOrIdx {}}} { |
method names {{globOrIdx {}}} { |
||||||
if {[llength $globOrIdx]} { |
if {[llength $globOrIdx]} { |
||||||
if {[string is integer -strict $globOrIdx]} { |
if {[string is integer -strict $globOrIdx]} { |
||||||
set idx $globOrIdx |
set idx $globOrIdx |
||||||
if {$idx < 0} { |
if {$idx < 0} { |
||||||
set idx "end-[expr {abs($idx + 1)}]" |
set idx "end-[expr {abs($idx + 1)}]" |
||||||
} |
} |
||||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||||
error "[self object] no such index : '$idx'" |
error "[self object] no such index : '$idx'" |
||||||
} else { |
} else { |
||||||
return $result |
return $result |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
#glob |
#glob |
||||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
return [dict keys $o_data] |
return [dict keys $o_data] |
||||||
} |
} |
||||||
} |
} |
||||||
#like names but without globbing |
#like names but without globbing |
||||||
method keys {} { |
method keys {} { |
||||||
dict keys $o_data |
dict keys $o_data |
||||||
} |
} |
||||||
method key {{posn 0}} { |
method key {{posn 0}} { |
||||||
if {$posn < 0} { |
if {$posn < 0} { |
||||||
set posn "end-[expr {abs($posn + 1)}]" |
set posn "end-[expr {abs($posn + 1)}]" |
||||||
} |
} |
||||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||||
error "[self object] no such index : '$posn'" |
error "[self object] no such index : '$posn'" |
||||||
} else { |
} else { |
||||||
return $result |
return $result |
||||||
} |
} |
||||||
} |
} |
||||||
method hasKey {key} { |
method hasKey {key} { |
||||||
dict exists $o_data $key |
dict exists $o_data $key |
||||||
} |
} |
||||||
method get {} { |
method get {} { |
||||||
return $o_data |
return $o_data |
||||||
} |
} |
||||||
method items {} { |
method items {} { |
||||||
return [dict values $o_data] |
return [dict values $o_data] |
||||||
} |
} |
||||||
method item {key} { |
method item {key} { |
||||||
if {[string is integer -strict $key]} { |
if {[string is integer -strict $key]} { |
||||||
if {$key >= 0} { |
if {$key >= 0} { |
||||||
set valposn [expr {(2*$key) +1}] |
set valposn [expr {(2*$key) +1}] |
||||||
return [lindex $o_data $valposn] |
return [lindex $o_data $valposn] |
||||||
} else { |
} else { |
||||||
set key "end-[expr {abs($key + 1)}]" |
set key "end-[expr {abs($key + 1)}]" |
||||||
return [lindex $o_data $key] |
return [lindex $o_data $key] |
||||||
#return [lindex [dict keys $o_data] $key] |
#return [lindex [dict keys $o_data] $key] |
||||||
} |
} |
||||||
} |
} |
||||||
if {[dict exists $o_data $key]} { |
if {[dict exists $o_data $key]} { |
||||||
return [dict get $o_data $key] |
return [dict get $o_data $key] |
||||||
} |
} |
||||||
} |
} |
||||||
#inverse lookup |
#inverse lookup |
||||||
method itemKeys {value} { |
method itemKeys {value} { |
||||||
set value_indices [lsearch -all [dict values $o_data] $value] |
set value_indices [lsearch -all [dict values $o_data] $value] |
||||||
set keylist [list] |
set keylist [list] |
||||||
foreach i $value_indices { |
foreach i $value_indices { |
||||||
set idx [expr {(($i + 1) *2) -2}] |
set idx [expr {(($i + 1) *2) -2}] |
||||||
lappend keylist [lindex $o_data $idx] |
lappend keylist [lindex $o_data $idx] |
||||||
} |
} |
||||||
return $keylist |
return $keylist |
||||||
} |
} |
||||||
method search {value args} { |
method search {value args} { |
||||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||||
if {"-inline" in $args} { |
if {"-inline" in $args} { |
||||||
return $matches |
return $matches |
||||||
} else { |
} else { |
||||||
set keylist [list] |
set keylist [list] |
||||||
foreach i $matches { |
foreach i $matches { |
||||||
set idx [expr {(($i + 1) *2) -2}] |
set idx [expr {(($i + 1) *2) -2}] |
||||||
lappend keylist [lindex $o_data $idx] |
lappend keylist [lindex $o_data $idx] |
||||||
} |
} |
||||||
return $keylist |
return $keylist |
||||||
} |
} |
||||||
} |
} |
||||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||||
#review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? |
#review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? |
||||||
#method alias {newAlias existingKeyOrAlias} { |
#method alias {newAlias existingKeyOrAlias} { |
||||||
# if {[string is integer -strict $newAlias]} { |
# if {[string is integer -strict $newAlias]} { |
||||||
# error "[self object] collection key alias cannot be integer" |
# error "[self object] collection key alias cannot be integer" |
||||||
# } |
# } |
||||||
# if {[string length $existingKeyOrAlias]} { |
# if {[string length $existingKeyOrAlias]} { |
||||||
# set o_alias($newAlias) $existingKeyOrAlias |
# set o_alias($newAlias) $existingKeyOrAlias |
||||||
# } else { |
# } else { |
||||||
# unset o_alias($newAlias) |
# unset o_alias($newAlias) |
||||||
# } |
# } |
||||||
#} |
#} |
||||||
#method aliases {{key ""}} { |
#method aliases {{key ""}} { |
||||||
# if {[string length $key]} { |
# if {[string length $key]} { |
||||||
# set result [list] |
# set result [list] |
||||||
# foreach {n v} [array get o_alias] { |
# foreach {n v} [array get o_alias] { |
||||||
# if {$v eq $key} { |
# if {$v eq $key} { |
||||||
# lappend result $n $v |
# lappend result $n $v |
||||||
# } |
# } |
||||||
# } |
# } |
||||||
# return $result |
# return $result |
||||||
# } else { |
# } else { |
||||||
# return [array get o_alias] |
# return [array get o_alias] |
||||||
# } |
# } |
||||||
#} |
#} |
||||||
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||||
#method realKey {idx} { |
#method realKey {idx} { |
||||||
# if {[catch {set o_alias($idx)} key]} { |
# if {[catch {set o_alias($idx)} key]} { |
||||||
# return $idx |
# return $idx |
||||||
# } else { |
# } else { |
||||||
# return $key |
# return $key |
||||||
# } |
# } |
||||||
#} |
#} |
||||||
method add {value key} { |
method add {value key} { |
||||||
if {[string is integer -strict $key]} { |
if {[string is integer -strict $key]} { |
||||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||||
} |
} |
||||||
if {[dict exists $o_data $key]} { |
if {[dict exists $o_data $key]} { |
||||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||||
} |
} |
||||||
dict set o_data $key $value |
dict set o_data $key $value |
||||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||||
} |
} |
||||||
method remove {idx {endRange ""}} { |
method remove {idx {endRange ""}} { |
||||||
if {[string length $endRange]} { |
if {[string length $endRange]} { |
||||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||||
} |
} |
||||||
if {[string is integer -strict $idx]} { |
if {[string is integer -strict $idx]} { |
||||||
if {$idx < 0} { |
if {$idx < 0} { |
||||||
set idx "end-[expr {abs($idx+1)}]" |
set idx "end-[expr {abs($idx+1)}]" |
||||||
} |
} |
||||||
set key [lindex [dict keys $o_data] $idx] |
set key [lindex [dict keys $o_data] $idx] |
||||||
set posn $idx |
set posn $idx |
||||||
} else { |
} else { |
||||||
set key $idx |
set key $idx |
||||||
set posn [lsearch -exact [dict keys $o_data] $key] |
set posn [lsearch -exact [dict keys $o_data] $key] |
||||||
if {$posn < 0} { |
if {$posn < 0} { |
||||||
error "[self object] no such index: '$idx' in this collection" |
error "[self object] no such index: '$idx' in this collection" |
||||||
} |
} |
||||||
} |
} |
||||||
dict unset o_data $key |
dict unset o_data $key |
||||||
return |
return |
||||||
} |
} |
||||||
method clear {} { |
method clear {} { |
||||||
set o_data [dict create] |
set o_data [dict create] |
||||||
return |
return |
||||||
} |
} |
||||||
method reverse_the_collection {} { |
method reverse_the_collection {} { |
||||||
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
#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. |
#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. |
#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] |
set dictnew [dict create] |
||||||
foreach k [lreverse [dict keys $o_data]] { |
foreach k [lreverse [dict keys $o_data]] { |
||||||
dict set dictnew $k [dict get $o_data $k] |
dict set dictnew $k [dict get $o_data $k] |
||||||
} |
} |
||||||
set o_data $dictnew |
set o_data $dictnew |
||||||
return |
return |
||||||
} |
} |
||||||
#review - cmd as list vs cmd as script? |
#review - cmd as list vs cmd as script? |
||||||
method map {cmd} { |
method map {cmd} { |
||||||
set seed [list] |
set seed [list] |
||||||
dict for {k v} $o_data { |
dict for {k v} $o_data { |
||||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||||
} |
} |
||||||
return $seed |
return $seed |
||||||
} |
} |
||||||
method objectmap {cmd} { |
method objectmap {cmd} { |
||||||
set seed [list] |
set seed [list] |
||||||
dict for {k v} $o_data { |
dict for {k v} $o_data { |
||||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||||
} |
} |
||||||
return $seed |
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
@ -0,0 +1,53 @@ |
|||||||
|
apply {code { |
||||||
|
set scriptpath [file normalize [info script]] |
||||||
|
if {[string match "#modpod-loadscript*.tcl" [file tail $scriptpath]]} { |
||||||
|
#jump up an extra dir level if we are within a #modpod-loadscript file. |
||||||
|
set mypath [file dirname [file dirname $scriptpath]] |
||||||
|
#expect to be in folder #modpod-<module>-<ver> |
||||||
|
#Now we need to test if we are in a mounted folder vs an extracted folder |
||||||
|
set container [file dirname $mypath] |
||||||
|
if {[string match "#mounted-modpod-*" $container]} { |
||||||
|
set mypath [file dirname $container] |
||||||
|
} |
||||||
|
set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #modpod-<module>-<ver> |
||||||
|
} else { |
||||||
|
set mypath [file dirname $scriptpath] |
||||||
|
set modver [file root [file tail [info script]]] |
||||||
|
} |
||||||
|
set mysegs [file split $mypath] |
||||||
|
set overhang [list] |
||||||
|
foreach libpath [tcl::tm::list] { |
||||||
|
set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & / |
||||||
|
if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} { |
||||||
|
#mypath is below libpath |
||||||
|
set overhang [lrange $mysegs [llength $libsegs]+1 end] |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [split $modver -] moduletail version |
||||||
|
set ns [join [concat $overhang $moduletail] ::] |
||||||
|
#if {![catch {package require modpod}]} { |
||||||
|
# ::modpod::disconnect [info script] |
||||||
|
#} |
||||||
|
package provide $ns $version |
||||||
|
namespace eval $ns $code |
||||||
|
} ::} { |
||||||
|
# |
||||||
|
# Module procs here, where current namespace is that of the module. |
||||||
|
# Package version can, if needed, be accessed as [uplevel 1 {set version}] |
||||||
|
# Last element of module name: [uplevel 1 {set moduletail}] |
||||||
|
# Full module name: [uplevel 1 {set ns}] |
||||||
|
|
||||||
|
#<modulecode> |
||||||
|
# |
||||||
|
#</modulecode> |
||||||
|
|
||||||
|
#<sourcefiles> |
||||||
|
# |
||||||
|
#</sourcefiles> |
||||||
|
|
||||||
|
#<loadfiles> |
||||||
|
# |
||||||
|
#</loadfiles> |
||||||
|
|
||||||
|
} |
||||||
Binary file not shown.
@ -1,3 +1,3 @@ |
|||||||
%Major.Minor.Level% |
%Major.Minor.Level% |
||||||
#First line must be a semantic version number |
#First line must be a semantic version number |
||||||
#all other lines are ignored. |
#all other lines are ignored. |
||||||
|
|||||||
@ -1,10 +1,10 @@ |
|||||||
Identifier: %package% |
Identifier: %package% |
||||||
Version: %version% |
Version: %version% |
||||||
Title: %title% |
Title: %title% |
||||||
Creator: %name% <%email%> |
Creator: %name% <%email%> |
||||||
Description: %description% |
Description: %description% |
||||||
Rights: BSD |
Rights: BSD |
||||||
URL: %url% |
URL: %url% |
||||||
Available: |
Available: |
||||||
Architecture: tcl |
Architecture: tcl |
||||||
Subject: |
Subject: |
||||||
|
|||||||
@ -1,7 +0,0 @@ |
|||||||
::lindex tcl;#\ |
|
||||||
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
|
||||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
|
||||||
puts stdout "script: [info script]" |
|
||||||
puts stdout "argv: $::argc" |
|
||||||
puts stdout "args: '$::argv'" |
|
||||||
|
|
||||||
@ -1,3 +1,3 @@ |
|||||||
::lindex tcl;#\ |
::lindex tcl;#\ |
||||||
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
||||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||||
|
|||||||
@ -1,8 +1,8 @@ |
|||||||
::lindex tcl;#\ |
::lindex tcl;#\ |
||||||
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
||||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||||
puts stdout "exe: [info nameof]" |
puts stdout "exe: [info nameof]" |
||||||
puts stdout "scr: [info script]" |
puts stdout "scr: [info script]" |
||||||
puts stdout "argc: $::argc" |
puts stdout "argc: $::argc" |
||||||
puts stdout "argv: '$::argv'" |
puts stdout "argv: '$::argv'" |
||||||
|
|
||||||
|
|||||||
@ -1,19 +1,19 @@ |
|||||||
::set - { |
::set - { |
||||||
@goto start |
@goto start |
||||||
# -- tcl bat |
# -- tcl bat |
||||||
:start |
:start |
||||||
@echo off |
@echo off |
||||||
set script=%0 |
set script=%0 |
||||||
echo %* |
echo %* |
||||||
if exist %script%.bat set script=%script%.bat |
if exist %script%.bat set script=%script%.bat |
||||||
tclsh %script% %* |
tclsh %script% %* |
||||||
goto end of BAT file |
goto end of BAT file |
||||||
};unset - ;# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
};unset - ;# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||||
|
|
||||||
puts stdout "exe: [info nameof]" |
puts stdout "exe: [info nameof]" |
||||||
puts stdout "scr: [info script]" |
puts stdout "scr: [info script]" |
||||||
puts stdout "argc: $::argc" |
puts stdout "argc: $::argc" |
||||||
puts stdout "argv: '$::argv'" |
puts stdout "argv: '$::argv'" |
||||||
|
|
||||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl\ |
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl\ |
||||||
:end of BAT file |
:end of BAT file |
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,9 @@ |
|||||||
|
|
||||||
|
#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project |
||||||
|
#They must be already built, so generally shouldn't come directly from src/modules. |
||||||
|
|
||||||
|
#each entry - base module |
||||||
|
set bootsupport_modules [list\ |
||||||
|
modules_tcl8 thread\ |
||||||
|
] |
||||||
|
|
||||||
@ -0,0 +1,53 @@ |
|||||||
|
apply {code { |
||||||
|
set scriptpath [file normalize [info script]] |
||||||
|
if {[string match "#modpod-loadscript*.tcl" [file tail $scriptpath]]} { |
||||||
|
#jump up an extra dir level if we are within a #modpod-loadscript file. |
||||||
|
set mypath [file dirname [file dirname $scriptpath]] |
||||||
|
#expect to be in folder #modpod-<module>-<ver> |
||||||
|
#Now we need to test if we are in a mounted folder vs an extracted folder |
||||||
|
set container [file dirname $mypath] |
||||||
|
if {[string match "#mounted-modpod-*" $container]} { |
||||||
|
set mypath [file dirname $container] |
||||||
|
} |
||||||
|
set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #modpod-<module>-<ver> |
||||||
|
} else { |
||||||
|
set mypath [file dirname $scriptpath] |
||||||
|
set modver [file root [file tail [info script]]] |
||||||
|
} |
||||||
|
set mysegs [file split $mypath] |
||||||
|
set overhang [list] |
||||||
|
foreach libpath [tcl::tm::list] { |
||||||
|
set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & / |
||||||
|
if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} { |
||||||
|
#mypath is below libpath |
||||||
|
set overhang [lrange $mysegs [llength $libsegs]+1 end] |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [split $modver -] moduletail version |
||||||
|
set ns [join [concat $overhang $moduletail] ::] |
||||||
|
#if {![catch {package require modpod}]} { |
||||||
|
# ::modpod::disconnect [info script] |
||||||
|
#} |
||||||
|
package provide $ns $version |
||||||
|
namespace eval $ns $code |
||||||
|
} ::} { |
||||||
|
# |
||||||
|
# Module procs here, where current namespace is that of the module. |
||||||
|
# Package version can, if needed, be accessed as [uplevel 1 {set version}] |
||||||
|
# Last element of module name: [uplevel 1 {set moduletail}] |
||||||
|
# Full module name: [uplevel 1 {set ns}] |
||||||
|
|
||||||
|
#<modulecode> |
||||||
|
# |
||||||
|
#</modulecode> |
||||||
|
|
||||||
|
#<sourcefiles> |
||||||
|
# |
||||||
|
#</sourcefiles> |
||||||
|
|
||||||
|
#<loadfiles> |
||||||
|
# |
||||||
|
#</loadfiles> |
||||||
|
|
||||||
|
} |
||||||
@ -0,0 +1,181 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application modpodtest 999999.0a1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_modpodtest 0 999999.0a1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require modpodtest] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of modpodtest |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by modpodtest |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
|
||||||
|
# #package require frobz |
||||||
|
# #*** !doctools |
||||||
|
# #[item] [package {frobz}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval modpodtest::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpodtest::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval modpodtest { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpodtest}] |
||||||
|
#[para] Core API functions for modpodtest |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#proc sample1 {p1 n args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] |
||||||
|
# #[para]Description of sample1 |
||||||
|
# #[para] Arguments: |
||||||
|
# # [list_begin arguments] |
||||||
|
# # [arg_def tring p1] A description of string argument p1. |
||||||
|
# # [arg_def integer n] A description of integer argument n. |
||||||
|
# # [list_end] |
||||||
|
# return "ok" |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace modpodtest ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval modpodtest::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpodtest::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 modpodtest::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval modpodtest::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace modpodtest::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide modpodtest [tcl::namespace::eval modpodtest { |
||||||
|
variable pkg modpodtest |
||||||
|
variable version |
||||||
|
set version 999999.0a1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,120 @@ |
|||||||
|
# ZIP file constructor |
||||||
|
|
||||||
|
package provide zipper 0.11 |
||||||
|
|
||||||
|
namespace eval zipper { |
||||||
|
namespace export initialize addentry finalize |
||||||
|
|
||||||
|
namespace eval v { |
||||||
|
variable fd |
||||||
|
variable base |
||||||
|
variable toc |
||||||
|
} |
||||||
|
|
||||||
|
proc initialize {fd} { |
||||||
|
set v::fd $fd |
||||||
|
set v::base [tell $fd] |
||||||
|
set v::toc {} |
||||||
|
fconfigure $fd -translation binary -encoding binary |
||||||
|
} |
||||||
|
|
||||||
|
proc emit {s} { |
||||||
|
puts -nonewline $v::fd $s |
||||||
|
} |
||||||
|
|
||||||
|
proc dostime {sec} { |
||||||
|
set f [clock format $sec -format {%Y %m %d %H %M %S} -gmt 1] |
||||||
|
regsub -all { 0(\d)} $f { \1} f |
||||||
|
foreach {Y M D h m s} $f break |
||||||
|
set date [expr {(($Y-1980)<<9) | ($M<<5) | $D}] |
||||||
|
set time [expr {($h<<11) | ($m<<5) | ($s>>1)}] |
||||||
|
return [list $date $time] |
||||||
|
} |
||||||
|
|
||||||
|
proc addentry {name contents {date ""} {force 0}} { |
||||||
|
if {$date == ""} { set date [clock seconds] } |
||||||
|
foreach {date time} [dostime $date] break |
||||||
|
set flag 0 |
||||||
|
set type 0 ;# stored |
||||||
|
set fsize [string length $contents] |
||||||
|
set csize $fsize |
||||||
|
set fnlen [string length $name] |
||||||
|
|
||||||
|
if {$force > 0 && $force != [string length $contents]} { |
||||||
|
set csize $fsize |
||||||
|
set fsize $force |
||||||
|
set type 8 ;# if we're passing in compressed data, it's deflated |
||||||
|
} |
||||||
|
|
||||||
|
if {[catch { zlib crc32 $contents } crc]} { |
||||||
|
set crc 0 |
||||||
|
} elseif {$type == 0} { |
||||||
|
set cdata [zlib deflate $contents] |
||||||
|
if {[string length $cdata] < [string length $contents]} { |
||||||
|
set contents $cdata |
||||||
|
set csize [string length $cdata] |
||||||
|
set type 8 ;# deflate |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ |
||||||
|
$flag $type $time $date $crc $csize $fsize $fnlen \ |
||||||
|
{0 0 0 0} 128 [tell $v::fd]]$name" |
||||||
|
|
||||||
|
emit [binary format a2c4ssssiiiss PK {3 4 20 0} \ |
||||||
|
$flag $type $time $date $crc $csize $fsize $fnlen 0] |
||||||
|
emit $name |
||||||
|
emit $contents |
||||||
|
} |
||||||
|
|
||||||
|
proc finalize {} { |
||||||
|
set pos [tell $v::fd] |
||||||
|
|
||||||
|
set ntoc [llength $v::toc] |
||||||
|
foreach x $v::toc { emit $x } |
||||||
|
set v::toc {} |
||||||
|
|
||||||
|
set len [expr {[tell $v::fd] - $pos}] |
||||||
|
incr pos -$v::base |
||||||
|
|
||||||
|
emit [binary format a2c2ssssiis PK {5 6} 0 0 $ntoc $ntoc $len $pos 0] |
||||||
|
|
||||||
|
return $v::fd |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[info exists pkgtest] && $pkgtest} { |
||||||
|
puts "no test code" |
||||||
|
} |
||||||
|
|
||||||
|
# test code below runs when this is launched as the main script |
||||||
|
if {[info exists argv0] && [string match zipper-* [file tail $argv0]]} { |
||||||
|
|
||||||
|
catch { package require zlib } |
||||||
|
|
||||||
|
zipper::initialize [open try.zip w] |
||||||
|
|
||||||
|
set dirs [list .] |
||||||
|
while {[llength $dirs] > 0} { |
||||||
|
set d [lindex $dirs 0] |
||||||
|
set dirs [lrange $dirs 1 end] |
||||||
|
foreach f [lsort [glob -nocomplain [file join $d *]]] { |
||||||
|
if {[file isfile $f]} { |
||||||
|
regsub {^\./} $f {} f |
||||||
|
set fd [open $f] |
||||||
|
fconfigure $fd -translation binary -encoding binary |
||||||
|
zipper::addentry $f [read $fd] [file mtime $f] |
||||||
|
close $fd |
||||||
|
} elseif {[file isdir $f]} { |
||||||
|
lappend dirs $f |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
close [zipper::finalize] |
||||||
|
|
||||||
|
puts "size = [file size try.zip]" |
||||||
|
puts [exec unzip -v try.zip] |
||||||
|
|
||||||
|
file delete try.zip |
||||||
|
} |
||||||
@ -0,0 +1,28 @@ |
|||||||
|
Creating ZIP archives in Tcl |
||||||
|
============================ |
||||||
|
|
||||||
|
Rev 0.11: Added ?force? arg to bypass re-compression |
||||||
|
Rev 0.10: Initial release |
||||||
|
|
||||||
|
|
||||||
|
Zipper is a package to create ZIP archives with a few simple commands: |
||||||
|
|
||||||
|
zipper::initialize $fd |
||||||
|
initialize things to start writing zip file entries |
||||||
|
|
||||||
|
zipper::addentry name contents ?date? ?force? |
||||||
|
add one entry, modification date defaults to [clock seconds] |
||||||
|
|
||||||
|
zipper::finalize |
||||||
|
write trailing table of contents, returns file descriptor |
||||||
|
|
||||||
|
Example: |
||||||
|
|
||||||
|
package require zipper |
||||||
|
zipper::initialize [open try.zip w] |
||||||
|
zipper::addentry dir/file.txt "some data to store" |
||||||
|
close [zipper::finalize] |
||||||
|
|
||||||
|
If the "zlib" package is available, it will be used to to compress the |
||||||
|
data when possible and to calculate proper CRC-32 checksums. Otherwise, |
||||||
|
the output file will contain uncompressed data and zero checksums. |
||||||
@ -0,0 +1,3 @@ |
|||||||
|
0.1.0 |
||||||
|
#First line must be a semantic version number |
||||||
|
#all other lines are ignored. |
||||||
@ -1,201 +1,201 @@ |
|||||||
#JMN - api should be kept in sync with package patternlib where possible |
#JMN - api should be kept in sync with package patternlib where possible |
||||||
# |
# |
||||||
package provide oolib [namespace eval oolib { |
package provide oolib [namespace eval oolib { |
||||||
variable version |
variable version |
||||||
set version 0.1.2 |
set version 0.1.2 |
||||||
}] |
}] |
||||||
|
|
||||||
namespace eval oolib { |
namespace eval oolib { |
||||||
oo::class create collection { |
oo::class create collection { |
||||||
variable o_data ;#dict |
variable o_data ;#dict |
||||||
#variable o_alias |
#variable o_alias |
||||||
constructor {} { |
constructor {} { |
||||||
set o_data [dict create] |
set o_data [dict create] |
||||||
} |
} |
||||||
method info {} { |
method info {} { |
||||||
return [dict info $o_data] |
return [dict info $o_data] |
||||||
} |
} |
||||||
method count {} { |
method count {} { |
||||||
return [dict size $o_data] |
return [dict size $o_data] |
||||||
} |
} |
||||||
method isEmpty {} { |
method isEmpty {} { |
||||||
expr {[dict size $o_data] == 0} |
expr {[dict size $o_data] == 0} |
||||||
} |
} |
||||||
method names {{globOrIdx {}}} { |
method names {{globOrIdx {}}} { |
||||||
if {[llength $globOrIdx]} { |
if {[llength $globOrIdx]} { |
||||||
if {[string is integer -strict $globOrIdx]} { |
if {[string is integer -strict $globOrIdx]} { |
||||||
set idx $globOrIdx |
set idx $globOrIdx |
||||||
if {$idx < 0} { |
if {$idx < 0} { |
||||||
set idx "end-[expr {abs($idx + 1)}]" |
set idx "end-[expr {abs($idx + 1)}]" |
||||||
} |
} |
||||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||||
error "[self object] no such index : '$idx'" |
error "[self object] no such index : '$idx'" |
||||||
} else { |
} else { |
||||||
return $result |
return $result |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
#glob |
#glob |
||||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||||
} |
} |
||||||
} else { |
} else { |
||||||
return [dict keys $o_data] |
return [dict keys $o_data] |
||||||
} |
} |
||||||
} |
} |
||||||
#like names but without globbing |
#like names but without globbing |
||||||
method keys {} { |
method keys {} { |
||||||
dict keys $o_data |
dict keys $o_data |
||||||
} |
} |
||||||
method key {{posn 0}} { |
method key {{posn 0}} { |
||||||
if {$posn < 0} { |
if {$posn < 0} { |
||||||
set posn "end-[expr {abs($posn + 1)}]" |
set posn "end-[expr {abs($posn + 1)}]" |
||||||
} |
} |
||||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||||
error "[self object] no such index : '$posn'" |
error "[self object] no such index : '$posn'" |
||||||
} else { |
} else { |
||||||
return $result |
return $result |
||||||
} |
} |
||||||
} |
} |
||||||
method hasKey {key} { |
method hasKey {key} { |
||||||
dict exists $o_data $key |
dict exists $o_data $key |
||||||
} |
} |
||||||
method get {} { |
method get {} { |
||||||
return $o_data |
return $o_data |
||||||
} |
} |
||||||
method items {} { |
method items {} { |
||||||
return [dict values $o_data] |
return [dict values $o_data] |
||||||
} |
} |
||||||
method item {key} { |
method item {key} { |
||||||
if {[string is integer -strict $key]} { |
if {[string is integer -strict $key]} { |
||||||
if {$key >= 0} { |
if {$key >= 0} { |
||||||
set valposn [expr {(2*$key) +1}] |
set valposn [expr {(2*$key) +1}] |
||||||
return [lindex $o_data $valposn] |
return [lindex $o_data $valposn] |
||||||
} else { |
} else { |
||||||
set key "end-[expr {abs($key + 1)}]" |
set key "end-[expr {abs($key + 1)}]" |
||||||
return [lindex $o_data $key] |
return [lindex $o_data $key] |
||||||
#return [lindex [dict keys $o_data] $key] |
#return [lindex [dict keys $o_data] $key] |
||||||
} |
} |
||||||
} |
} |
||||||
if {[dict exists $o_data $key]} { |
if {[dict exists $o_data $key]} { |
||||||
return [dict get $o_data $key] |
return [dict get $o_data $key] |
||||||
} |
} |
||||||
} |
} |
||||||
#inverse lookup |
#inverse lookup |
||||||
method itemKeys {value} { |
method itemKeys {value} { |
||||||
set value_indices [lsearch -all [dict values $o_data] $value] |
set value_indices [lsearch -all [dict values $o_data] $value] |
||||||
set keylist [list] |
set keylist [list] |
||||||
foreach i $value_indices { |
foreach i $value_indices { |
||||||
set idx [expr {(($i + 1) *2) -2}] |
set idx [expr {(($i + 1) *2) -2}] |
||||||
lappend keylist [lindex $o_data $idx] |
lappend keylist [lindex $o_data $idx] |
||||||
} |
} |
||||||
return $keylist |
return $keylist |
||||||
} |
} |
||||||
method search {value args} { |
method search {value args} { |
||||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||||
if {"-inline" in $args} { |
if {"-inline" in $args} { |
||||||
return $matches |
return $matches |
||||||
} else { |
} else { |
||||||
set keylist [list] |
set keylist [list] |
||||||
foreach i $matches { |
foreach i $matches { |
||||||
set idx [expr {(($i + 1) *2) -2}] |
set idx [expr {(($i + 1) *2) -2}] |
||||||
lappend keylist [lindex $o_data $idx] |
lappend keylist [lindex $o_data $idx] |
||||||
} |
} |
||||||
return $keylist |
return $keylist |
||||||
} |
} |
||||||
} |
} |
||||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||||
#review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? |
#review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? |
||||||
#method alias {newAlias existingKeyOrAlias} { |
#method alias {newAlias existingKeyOrAlias} { |
||||||
# if {[string is integer -strict $newAlias]} { |
# if {[string is integer -strict $newAlias]} { |
||||||
# error "[self object] collection key alias cannot be integer" |
# error "[self object] collection key alias cannot be integer" |
||||||
# } |
# } |
||||||
# if {[string length $existingKeyOrAlias]} { |
# if {[string length $existingKeyOrAlias]} { |
||||||
# set o_alias($newAlias) $existingKeyOrAlias |
# set o_alias($newAlias) $existingKeyOrAlias |
||||||
# } else { |
# } else { |
||||||
# unset o_alias($newAlias) |
# unset o_alias($newAlias) |
||||||
# } |
# } |
||||||
#} |
#} |
||||||
#method aliases {{key ""}} { |
#method aliases {{key ""}} { |
||||||
# if {[string length $key]} { |
# if {[string length $key]} { |
||||||
# set result [list] |
# set result [list] |
||||||
# foreach {n v} [array get o_alias] { |
# foreach {n v} [array get o_alias] { |
||||||
# if {$v eq $key} { |
# if {$v eq $key} { |
||||||
# lappend result $n $v |
# lappend result $n $v |
||||||
# } |
# } |
||||||
# } |
# } |
||||||
# return $result |
# return $result |
||||||
# } else { |
# } else { |
||||||
# return [array get o_alias] |
# return [array get o_alias] |
||||||
# } |
# } |
||||||
#} |
#} |
||||||
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||||
#method realKey {idx} { |
#method realKey {idx} { |
||||||
# if {[catch {set o_alias($idx)} key]} { |
# if {[catch {set o_alias($idx)} key]} { |
||||||
# return $idx |
# return $idx |
||||||
# } else { |
# } else { |
||||||
# return $key |
# return $key |
||||||
# } |
# } |
||||||
#} |
#} |
||||||
method add {value key} { |
method add {value key} { |
||||||
if {[string is integer -strict $key]} { |
if {[string is integer -strict $key]} { |
||||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||||
} |
} |
||||||
if {[dict exists $o_data $key]} { |
if {[dict exists $o_data $key]} { |
||||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||||
} |
} |
||||||
dict set o_data $key $value |
dict set o_data $key $value |
||||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||||
} |
} |
||||||
method remove {idx {endRange ""}} { |
method remove {idx {endRange ""}} { |
||||||
if {[string length $endRange]} { |
if {[string length $endRange]} { |
||||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||||
} |
} |
||||||
if {[string is integer -strict $idx]} { |
if {[string is integer -strict $idx]} { |
||||||
if {$idx < 0} { |
if {$idx < 0} { |
||||||
set idx "end-[expr {abs($idx+1)}]" |
set idx "end-[expr {abs($idx+1)}]" |
||||||
} |
} |
||||||
set key [lindex [dict keys $o_data] $idx] |
set key [lindex [dict keys $o_data] $idx] |
||||||
set posn $idx |
set posn $idx |
||||||
} else { |
} else { |
||||||
set key $idx |
set key $idx |
||||||
set posn [lsearch -exact [dict keys $o_data] $key] |
set posn [lsearch -exact [dict keys $o_data] $key] |
||||||
if {$posn < 0} { |
if {$posn < 0} { |
||||||
error "[self object] no such index: '$idx' in this collection" |
error "[self object] no such index: '$idx' in this collection" |
||||||
} |
} |
||||||
} |
} |
||||||
dict unset o_data $key |
dict unset o_data $key |
||||||
return |
return |
||||||
} |
} |
||||||
method clear {} { |
method clear {} { |
||||||
set o_data [dict create] |
set o_data [dict create] |
||||||
return |
return |
||||||
} |
} |
||||||
method reverse_the_collection {} { |
method reverse_the_collection {} { |
||||||
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
#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. |
#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. |
#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] |
set dictnew [dict create] |
||||||
foreach k [lreverse [dict keys $o_data]] { |
foreach k [lreverse [dict keys $o_data]] { |
||||||
dict set dictnew $k [dict get $o_data $k] |
dict set dictnew $k [dict get $o_data $k] |
||||||
} |
} |
||||||
set o_data $dictnew |
set o_data $dictnew |
||||||
return |
return |
||||||
} |
} |
||||||
#review - cmd as list vs cmd as script? |
#review - cmd as list vs cmd as script? |
||||||
method map {cmd} { |
method map {cmd} { |
||||||
set seed [list] |
set seed [list] |
||||||
dict for {k v} $o_data { |
dict for {k v} $o_data { |
||||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||||
} |
} |
||||||
return $seed |
return $seed |
||||||
} |
} |
||||||
method objectmap {cmd} { |
method objectmap {cmd} { |
||||||
set seed [list] |
set seed [list] |
||||||
dict for {k v} $o_data { |
dict for {k v} $o_data { |
||||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||||
} |
} |
||||||
return $seed |
return $seed |
||||||
} |
} |
||||||
} |
} |
||||||
|
|
||||||
} |
} |
||||||
|
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,3 @@ |
|||||||
|
0.3.1 |
||||||
|
#First line must be a semantic version number |
||||||
|
#all other lines are ignored. |
||||||
@ -0,0 +1,53 @@ |
|||||||
|
apply {code { |
||||||
|
set scriptpath [file normalize [info script]] |
||||||
|
if {[string match "#modpod-loadscript*.tcl" [file tail $scriptpath]]} { |
||||||
|
#jump up an extra dir level if we are within a #modpod-loadscript file. |
||||||
|
set mypath [file dirname [file dirname $scriptpath]] |
||||||
|
#expect to be in folder #modpod-<module>-<ver> |
||||||
|
#Now we need to test if we are in a mounted folder vs an extracted folder |
||||||
|
set container [file dirname $mypath] |
||||||
|
if {[string match "#mounted-modpod-*" $container]} { |
||||||
|
set mypath [file dirname $container] |
||||||
|
} |
||||||
|
set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #modpod-<module>-<ver> |
||||||
|
} else { |
||||||
|
set mypath [file dirname $scriptpath] |
||||||
|
set modver [file root [file tail [info script]]] |
||||||
|
} |
||||||
|
set mysegs [file split $mypath] |
||||||
|
set overhang [list] |
||||||
|
foreach libpath [tcl::tm::list] { |
||||||
|
set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & / |
||||||
|
if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} { |
||||||
|
#mypath is below libpath |
||||||
|
set overhang [lrange $mysegs [llength $libsegs]+1 end] |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
lassign [split $modver -] moduletail version |
||||||
|
set ns [join [concat $overhang $moduletail] ::] |
||||||
|
#if {![catch {package require modpod}]} { |
||||||
|
# ::modpod::disconnect [info script] |
||||||
|
#} |
||||||
|
package provide $ns $version |
||||||
|
namespace eval $ns $code |
||||||
|
} ::} { |
||||||
|
# |
||||||
|
# Module procs here, where current namespace is that of the module. |
||||||
|
# Package version can, if needed, be accessed as [uplevel 1 {set version}] |
||||||
|
# Last element of module name: [uplevel 1 {set moduletail}] |
||||||
|
# Full module name: [uplevel 1 {set ns}] |
||||||
|
|
||||||
|
#<modulecode> |
||||||
|
# |
||||||
|
#</modulecode> |
||||||
|
|
||||||
|
#<sourcefiles> |
||||||
|
# |
||||||
|
#</sourcefiles> |
||||||
|
|
||||||
|
#<loadfiles> |
||||||
|
# |
||||||
|
#</loadfiles> |
||||||
|
|
||||||
|
} |
||||||
Binary file not shown.
@ -0,0 +1,632 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-buildversion.txt |
||||||
|
# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm |
||||||
|
# |
||||||
|
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||||
|
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# (C) 2024 JMN |
||||||
|
# (C) 2009 Path Thoyts <patthyts@users.sourceforge.net> |
||||||
|
# |
||||||
|
# @@ Meta Begin |
||||||
|
# Application punk::zip 999999.0a1.0 |
||||||
|
# Meta platform tcl |
||||||
|
# Meta license <unspecified> |
||||||
|
# @@ Meta End |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# doctools header |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[manpage_begin shellspy_module_punk::zip 0 999999.0a1.0] |
||||||
|
#[copyright "2024"] |
||||||
|
#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] |
||||||
|
#[moddesc {-}] [comment {-- Description at end of page heading --}] |
||||||
|
#[require punk::zip] |
||||||
|
#[keywords module] |
||||||
|
#[description] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section Overview] |
||||||
|
#[para] overview of punk::zip |
||||||
|
#[subsection Concepts] |
||||||
|
#[para] - |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Requirements |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection dependencies] |
||||||
|
#[para] packages used by punk::zip |
||||||
|
#[list_begin itemized] |
||||||
|
|
||||||
|
package require Tcl 8.6- |
||||||
|
package require punk::args |
||||||
|
#*** !doctools |
||||||
|
#[item] [package {Tcl 8.6}] |
||||||
|
#[item] [package {punk::args}] |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[section API] |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# oo::class namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#tcl::namespace::eval punk::zip::class { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip::class}] |
||||||
|
#[para] class definitions |
||||||
|
#if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { |
||||||
|
#*** !doctools |
||||||
|
#[list_begin enumerated] |
||||||
|
|
||||||
|
# oo::class create interface_sample1 { |
||||||
|
# #*** !doctools |
||||||
|
# #[enum] CLASS [class interface_sample1] |
||||||
|
# #[list_begin definitions] |
||||||
|
|
||||||
|
# method test {arg1} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call class::interface_sample1 [method test] [arg arg1]] |
||||||
|
# #[para] test method |
||||||
|
# puts "test: $arg1" |
||||||
|
# } |
||||||
|
|
||||||
|
# #*** !doctools |
||||||
|
# #[list_end] [comment {-- end definitions interface_sample1}] |
||||||
|
# } |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end class enumeration ---}] |
||||||
|
#} |
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Base namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::zip { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
#variable xyz |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip}] |
||||||
|
#[para] Core API functions for punk::zip |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
proc Path_a_atorbelow_b {path_a path_b} { |
||||||
|
return [expr {[StripPath $path_b $path_a] ne $path_a}] |
||||||
|
} |
||||||
|
proc Path_a_at_b {path_a path_b} { |
||||||
|
return [expr {[StripPath $path_a $path_b] eq "." }] |
||||||
|
} |
||||||
|
|
||||||
|
proc Path_strip_alreadynormalized_prefixdepth {path prefix} { |
||||||
|
if {$prefix eq ""} { |
||||||
|
return $path |
||||||
|
} |
||||||
|
set pathparts [file split $path] |
||||||
|
set prefixparts [file split $prefix] |
||||||
|
if {[llength $prefixparts] >= [llength $pathparts]} { |
||||||
|
return "" |
||||||
|
} |
||||||
|
return [file join \ |
||||||
|
{*}[lrange \ |
||||||
|
$pathparts \ |
||||||
|
[llength $prefixparts] \ |
||||||
|
end]] |
||||||
|
} |
||||||
|
|
||||||
|
#StripPath - borrowed from tcllib fileutil |
||||||
|
# ::fileutil::stripPath -- |
||||||
|
# |
||||||
|
# If the specified path references/is a path in prefix (or prefix itself) it |
||||||
|
# is made relative to prefix. Otherwise it is left unchanged. |
||||||
|
# In the case of it being prefix itself the result is the string '.'. |
||||||
|
# |
||||||
|
# Arguments: |
||||||
|
# prefix prefix to strip from the path. |
||||||
|
# path path to modify |
||||||
|
# |
||||||
|
# Results: |
||||||
|
# path The (possibly) modified path. |
||||||
|
|
||||||
|
if {[string equal $tcl_platform(platform) windows]} { |
||||||
|
# Windows. While paths are stored with letter-case preserved al |
||||||
|
# comparisons have to be done case-insensitive. For reference see |
||||||
|
# SF Tcllib Bug 2499641. |
||||||
|
|
||||||
|
proc StripPath {prefix path} { |
||||||
|
# [file split] is used to generate a canonical form for both |
||||||
|
# paths, for easy comparison, and also one which is easy to modify |
||||||
|
# using list commands. |
||||||
|
|
||||||
|
set prefix [file split $prefix] |
||||||
|
set npath [file split $path] |
||||||
|
|
||||||
|
if {[string equal -nocase $prefix $npath]} { |
||||||
|
return "." |
||||||
|
} |
||||||
|
|
||||||
|
if {[string match -nocase "${prefix} *" $npath]} { |
||||||
|
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||||
|
} |
||||||
|
return $path |
||||||
|
} |
||||||
|
} else { |
||||||
|
proc StripPath {prefix path} { |
||||||
|
# [file split] is used to generate a canonical form for both |
||||||
|
# paths, for easy comparison, and also one which is easy to modify |
||||||
|
# using list commands. |
||||||
|
|
||||||
|
set prefix [file split $prefix] |
||||||
|
set npath [file split $path] |
||||||
|
|
||||||
|
if {[string equal $prefix $npath]} { |
||||||
|
return "." |
||||||
|
} |
||||||
|
|
||||||
|
if {[string match "${prefix} *" $npath]} { |
||||||
|
set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] |
||||||
|
} |
||||||
|
return $path |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc Timet_to_dos {time_t} { |
||||||
|
#*** !doctools |
||||||
|
#[call] [fun Timet_to_dos] [arg time_t] |
||||||
|
#[para] convert a unix timestamp into a DOS timestamp for ZIP times. |
||||||
|
#[example { |
||||||
|
# DOS timestamps are 32 bits split into bit regions as follows: |
||||||
|
# 24 16 8 0 |
||||||
|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||||
|
# |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| |
||||||
|
# +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ |
||||||
|
#}] |
||||||
|
set s [clock format $time_t -format {%Y %m %e %k %M %S}] |
||||||
|
scan $s {%d %d %d %d %d %d} year month day hour min sec |
||||||
|
expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) |
||||||
|
| ($hour << 11) | ($min << 5) | ($sec >> 1)} |
||||||
|
} |
||||||
|
|
||||||
|
proc walk {args} { |
||||||
|
#*** !doctools |
||||||
|
#[call] [fun walk] [arg ?options?] [arg base] |
||||||
|
#[para] Walk a directory tree rooted at base |
||||||
|
#[para] the -excludes list can be a set of glob expressions to match against files and avoid |
||||||
|
#[para] e.g |
||||||
|
#[example { |
||||||
|
# punk::zip::walk -exclude {CVS/* *~.#*} library |
||||||
|
#}] |
||||||
|
|
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::zip::walk |
||||||
|
-excludes -default "" -help "list of glob expressions to match against files and exclude" |
||||||
|
-subpath -default "" |
||||||
|
*values -min 1 -max -1 |
||||||
|
base |
||||||
|
fileglobs -default {*} -multiple 1 |
||||||
|
} $args] |
||||||
|
set base [dict get $argd values base] |
||||||
|
set fileglobs [dict get $argd values fileglobs] |
||||||
|
set subpath [dict get $argd opts -subpath] |
||||||
|
set excludes [dict get $argd opts -excludes] |
||||||
|
|
||||||
|
|
||||||
|
set imatch [list] |
||||||
|
foreach fg $fileglobs { |
||||||
|
lappend imatch [file join $subpath $fg] |
||||||
|
} |
||||||
|
|
||||||
|
set result {} |
||||||
|
#set imatch [file join $subpath $match] |
||||||
|
set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] |
||||||
|
foreach file $files { |
||||||
|
set excluded 0 |
||||||
|
foreach glob $excludes { |
||||||
|
if {[string match $glob $file]} { |
||||||
|
set excluded 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {!$excluded} {lappend result $file} |
||||||
|
} |
||||||
|
foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { |
||||||
|
set subdir [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] |
||||||
|
if {[llength $subdir]>0} { |
||||||
|
set result [concat $result $dir $subdir] |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
# Mkzipfile -- |
||||||
|
# |
||||||
|
# FIX ME: should handle the current offset for non-seekable channels |
||||||
|
# |
||||||
|
proc Mkzipfile {zipchan base path {comment ""}} { |
||||||
|
#*** !doctools |
||||||
|
#[call] [fun Mkzipfile] [arg zipchan] [arg base] [arg path] [arg ?comment?] |
||||||
|
#[para] Add a single file to a zip archive |
||||||
|
#[para] The zipchan channel should already be open and binary. |
||||||
|
#[para] You can provide a -comment for the file. |
||||||
|
#[para] The return value is the central directory record that will need to be used when finalizing the zip archive. |
||||||
|
|
||||||
|
set fullpath [file join $base $path] |
||||||
|
set mtime [Timet_to_dos [file mtime $fullpath]] |
||||||
|
set utfpath [encoding convertto utf-8 $path] |
||||||
|
set utfcomment [encoding convertto utf-8 $comment] |
||||||
|
set flags [expr {(1<<11)}] ;# utf-8 comment and path |
||||||
|
set method 0 ;# store 0, deflate 8 |
||||||
|
set attr 0 ;# text or binary (default binary) |
||||||
|
set version 20 ;# minumum version req'd to extract |
||||||
|
set extra "" |
||||||
|
set crc 0 |
||||||
|
set size 0 |
||||||
|
set csize 0 |
||||||
|
set data "" |
||||||
|
set seekable [expr {[tell $zipchan] != -1}] |
||||||
|
if {[file isdirectory $fullpath]} { |
||||||
|
set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) |
||||||
|
#set attrex 0x40000010 |
||||||
|
} elseif {[file executable $fullpath]} { |
||||||
|
set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) |
||||||
|
} else { |
||||||
|
set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) |
||||||
|
if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { |
||||||
|
set attr 1 ;# text |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {[file isfile $fullpath]} { |
||||||
|
set size [file size $fullpath] |
||||||
|
if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
set offset [tell $zipchan] |
||||||
|
set local [binary format a4sssiiiiss PK\03\04 \ |
||||||
|
$version $flags $method $mtime $crc $csize $size \ |
||||||
|
[string length $utfpath] [string length $extra]] |
||||||
|
append local $utfpath $extra |
||||||
|
puts -nonewline $zipchan $local |
||||||
|
|
||||||
|
if {[file isfile $fullpath]} { |
||||||
|
# If the file is under 2MB then zip in one chunk, otherwize we use |
||||||
|
# streaming to avoid requiring excess memory. This helps to prevent |
||||||
|
# storing re-compressed data that may be larger than the source when |
||||||
|
# handling PNG or JPEG or nested ZIP files. |
||||||
|
if {$size < 0x00200000} { |
||||||
|
set fin [open $fullpath rb] |
||||||
|
set data [read $fin] |
||||||
|
set crc [zlib crc32 $data] |
||||||
|
set cdata [zlib deflate $data] |
||||||
|
if {[string length $cdata] < $size} { |
||||||
|
set method 8 |
||||||
|
set data $cdata |
||||||
|
} |
||||||
|
close $fin |
||||||
|
set csize [string length $data] |
||||||
|
puts -nonewline $zipchan $data |
||||||
|
} else { |
||||||
|
set method 8 |
||||||
|
set fin [open $fullpath rb] |
||||||
|
set zlib [zlib stream deflate] |
||||||
|
while {![eof $fin]} { |
||||||
|
set data [read $fin 4096] |
||||||
|
set crc [zlib crc32 $data $crc] |
||||||
|
$zlib put $data |
||||||
|
if {[string length [set zdata [$zlib get]]]} { |
||||||
|
incr csize [string length $zdata] |
||||||
|
puts -nonewline $zipchan $zdata |
||||||
|
} |
||||||
|
} |
||||||
|
close $fin |
||||||
|
$zlib finalize |
||||||
|
set zdata [$zlib get] |
||||||
|
incr csize [string length $zdata] |
||||||
|
puts -nonewline $zipchan $zdata |
||||||
|
$zlib close |
||||||
|
} |
||||||
|
|
||||||
|
if {$seekable} { |
||||||
|
# update the header if the output is seekable |
||||||
|
set local [binary format a4sssiiii PK\03\04 \ |
||||||
|
$version $flags $method $mtime $crc $csize $size] |
||||||
|
set current [tell $zipchan] |
||||||
|
seek $zipchan $offset |
||||||
|
puts -nonewline $zipchan $local |
||||||
|
seek $zipchan $current |
||||||
|
} else { |
||||||
|
# Write a data descriptor record |
||||||
|
set ddesc [binary format a4iii PK\7\8 $crc $csize $size] |
||||||
|
puts -nonewline $zipchan $ddesc |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#PK\x01\x02 Cdentral directory file header |
||||||
|
#set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 |
||||||
|
set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) |
||||||
|
|
||||||
|
set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ |
||||||
|
$version $flags $method $mtime $crc $csize $size \ |
||||||
|
[string length $utfpath] [string length $extra]\ |
||||||
|
[string length $utfcomment] 0 $attr $attrex $offset] |
||||||
|
append hdr $utfpath $extra $utfcomment |
||||||
|
return $hdr |
||||||
|
} |
||||||
|
# zip::mkzip -- |
||||||
|
# |
||||||
|
# eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt |
||||||
|
# |
||||||
|
proc mkzip {args} { |
||||||
|
#*** !doctools |
||||||
|
#[call] [fun mkzip] [arg ?options?] [arg filename] |
||||||
|
#[para] Create a zip archive in 'filename' |
||||||
|
#[para] If a file already exists, an error will be raised. |
||||||
|
set argd [punk::args::get_dict { |
||||||
|
*proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" |
||||||
|
*opts |
||||||
|
-return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive |
||||||
|
the option -return pretty is the default and uses the punk::lib pdict/plist system |
||||||
|
to return a formatted list for the terminal |
||||||
|
" |
||||||
|
-zipkit -default 0 -type none -help "" |
||||||
|
-runtime -default "" -help "specify a prefix file |
||||||
|
e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip |
||||||
|
will create a self-extracting zip archive from the subdir/ folder. |
||||||
|
" |
||||||
|
-comment -default "" -help "An optional comment for the archive" |
||||||
|
-directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" |
||||||
|
-base -default "" -help "The new zip archive will be rooted in this directory if provided |
||||||
|
it must be a parent of -directory" |
||||||
|
-exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} |
||||||
|
*values -min 1 -max -1 |
||||||
|
filename -default "" -help "name of zipfile to create" |
||||||
|
globs -default {*} -multiple 1 -help "list of glob patterns to match. |
||||||
|
Only directories with matching files will be included in the archive" |
||||||
|
} $args] |
||||||
|
|
||||||
|
set filename [dict get $argd values filename] |
||||||
|
if {$filename eq ""} { |
||||||
|
error "mkzip filename cannot be empty string" |
||||||
|
} |
||||||
|
if {[regexp {[?*]} $filename]} { |
||||||
|
#catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name |
||||||
|
error "mkzip filename should not contain glob characters ? *" |
||||||
|
} |
||||||
|
if {[file exists $filename]} { |
||||||
|
error "mkzip filename:$filename already exists" |
||||||
|
} |
||||||
|
dict for {k v} [dict get $argd opts] { |
||||||
|
switch -- $k { |
||||||
|
-comment { |
||||||
|
dict set argd opts $k [encoding convertto utf-8 $v] |
||||||
|
} |
||||||
|
-directory - -base { |
||||||
|
dict set argd opts $k [file normalize $v] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
array set opts [dict get $argd opts] |
||||||
|
|
||||||
|
|
||||||
|
if {$opts(-directory) ne ""} { |
||||||
|
if {$opts(-base) ne ""} { |
||||||
|
#-base and -directory have been normalized already |
||||||
|
if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { |
||||||
|
error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)" |
||||||
|
} |
||||||
|
set base $opts(-base) |
||||||
|
set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] |
||||||
|
} else { |
||||||
|
set base $opts(-directory) |
||||||
|
set relpath "" |
||||||
|
} |
||||||
|
set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] |
||||||
|
|
||||||
|
set norm_filename [file normalize $filename] |
||||||
|
set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) |
||||||
|
if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { |
||||||
|
#check that we aren't adding the zipfile to itself |
||||||
|
#REVIEW - now that we open zipfile after scanning - this isn't really a concern! |
||||||
|
#keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) |
||||||
|
#In the case of -force - we may want to delay replacement of original until scan is done? |
||||||
|
|
||||||
|
#try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each |
||||||
|
#1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths |
||||||
|
set self_globs_match 0 |
||||||
|
foreach g [dict get $argd values globs] { |
||||||
|
if {[string match $g [file tail $filename]]} { |
||||||
|
set self_globs_match 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {$self_globs_match} { |
||||||
|
#still dangerous |
||||||
|
set self_excluded 0 |
||||||
|
foreach e $opts(-exclude) { |
||||||
|
if {[string match $e [file tail $filename]]} { |
||||||
|
set self_excluded 1 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {!$self_excluded} { |
||||||
|
#still dangerous - likely to be in resultset - check each path |
||||||
|
#puts stderr "zip file $filename is below directory $opts(-directory)" |
||||||
|
set self_is_matched 0 |
||||||
|
set i 0 |
||||||
|
foreach p $paths { |
||||||
|
set norm_p [file normalize [file join $opts(-directory) $p]] |
||||||
|
if {[Path_a_at_b $norm_filename $norm_p]} { |
||||||
|
set self_is_matched 1 |
||||||
|
break |
||||||
|
} |
||||||
|
incr i |
||||||
|
} |
||||||
|
if {$self_is_matched} { |
||||||
|
puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" |
||||||
|
set paths [lremove $paths $i] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
set paths [list] |
||||||
|
set dir [pwd] |
||||||
|
if {$opts(-base) ne ""} { |
||||||
|
if {![Path_a_atorbelow_b $dir $opts(-base)]} { |
||||||
|
error "punk::zip::mkzip -base $opts(-base) must be above current directory" |
||||||
|
} |
||||||
|
set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] |
||||||
|
} else { |
||||||
|
set relpath "" |
||||||
|
} |
||||||
|
set base $opts(-base) |
||||||
|
|
||||||
|
set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] |
||||||
|
foreach m $matches { |
||||||
|
if {$m eq $filename} { |
||||||
|
#puts stderr "--> excluding $filename" |
||||||
|
continue |
||||||
|
} |
||||||
|
set isok 1 |
||||||
|
foreach e [concat $opts(-exclude) $filename] { |
||||||
|
if {[string match $e $m]} { |
||||||
|
set isok 0 |
||||||
|
break |
||||||
|
} |
||||||
|
} |
||||||
|
if {$isok} { |
||||||
|
lappend paths [file join $relpath $m] |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
if {![llength $paths]} { |
||||||
|
return "" |
||||||
|
} |
||||||
|
|
||||||
|
set zf [open $filename wb] |
||||||
|
if {$opts(-runtime) ne ""} { |
||||||
|
set rt [open $opts(-runtime) rb] |
||||||
|
fcopy $rt $zf |
||||||
|
close $rt |
||||||
|
} elseif {$opts(-zipkit)} { |
||||||
|
set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" |
||||||
|
append zkd "package require vfs::zip\n" |
||||||
|
append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" |
||||||
|
append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" |
||||||
|
append zkd " source \[file join \[info script\] main.tcl\]\n" |
||||||
|
append zkd "}\n" |
||||||
|
append zkd \x1A |
||||||
|
puts -nonewline $zf $zkd |
||||||
|
} |
||||||
|
set count 0 |
||||||
|
set cd "" |
||||||
|
|
||||||
|
set members [list] |
||||||
|
foreach path $paths { |
||||||
|
#puts $path |
||||||
|
lappend members $path |
||||||
|
append cd [Mkzipfile $zf $base $path] ;#path already includes relpath |
||||||
|
incr count |
||||||
|
} |
||||||
|
set cdoffset [tell $zf] |
||||||
|
set endrec [binary format a4ssssiis PK\05\06 0 0 \ |
||||||
|
$count $count [string length $cd] $cdoffset\ |
||||||
|
[string length $opts(-comment)]] |
||||||
|
append endrec $opts(-comment) |
||||||
|
puts -nonewline $zf $cd |
||||||
|
puts -nonewline $zf $endrec |
||||||
|
close $zf |
||||||
|
|
||||||
|
set result "" |
||||||
|
switch -exact -- $opts(-return) { |
||||||
|
list { |
||||||
|
set result $members |
||||||
|
} |
||||||
|
pretty { |
||||||
|
if {[info commands showlist] ne ""} { |
||||||
|
set result [plist -channel none members] |
||||||
|
} else { |
||||||
|
set result $members |
||||||
|
} |
||||||
|
} |
||||||
|
none { |
||||||
|
set result "" |
||||||
|
} |
||||||
|
} |
||||||
|
return $result |
||||||
|
} |
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::zip ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
# Secondary API namespace |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
tcl::namespace::eval punk::zip::lib { |
||||||
|
tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase |
||||||
|
tcl::namespace::path [tcl::namespace::parent] |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip::lib}] |
||||||
|
#[para] Secondary functions that are part of the API |
||||||
|
#[list_begin definitions] |
||||||
|
|
||||||
|
#proc utility1 {p1 args} { |
||||||
|
# #*** !doctools |
||||||
|
# #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] |
||||||
|
# #[para]Description of utility1 |
||||||
|
# return 1 |
||||||
|
#} |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] |
||||||
|
} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
#*** !doctools |
||||||
|
#[section Internal] |
||||||
|
#tcl::namespace::eval punk::zip::system { |
||||||
|
#*** !doctools |
||||||
|
#[subsection {Namespace punk::zip::system}] |
||||||
|
#[para] Internal functions that are not part of the API |
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
#} |
||||||
|
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||||
|
## Ready |
||||||
|
package provide punk::zip [tcl::namespace::eval punk::zip { |
||||||
|
variable pkg punk::zip |
||||||
|
variable version |
||||||
|
set version 999999.0a1.0 |
||||||
|
}] |
||||||
|
return |
||||||
|
|
||||||
|
#*** !doctools |
||||||
|
#[manpage_end] |
||||||
|
|
||||||
@ -0,0 +1,3 @@ |
|||||||
|
0.1.0 |
||||||
|
#First line must be a semantic version number |
||||||
|
#all other lines are ignored. |
||||||
@ -0,0 +1,130 @@ |
|||||||
|
proc tclInit {} { |
||||||
|
rename tclInit {} |
||||||
|
|
||||||
|
global auto_path tcl_library tcl_libPath tcl_version tclkit_system_encoding |
||||||
|
|
||||||
|
# find the file to mount. |
||||||
|
set noe $::tcl::kitpath |
||||||
|
# resolve symlinks |
||||||
|
set noe [file dirname [file normalize [file join $noe __dummy__]]] |
||||||
|
set tcl_library [file join $noe lib tcl$tcl_version] |
||||||
|
set tcl_libPath [list $tcl_library [file join $noe lib]] |
||||||
|
|
||||||
|
# get rid of a build residue |
||||||
|
unset -nocomplain ::tclDefaultLibrary |
||||||
|
|
||||||
|
# The following code only gets executed if we don't have our exe |
||||||
|
# already mounted. This should only happen once per thread. |
||||||
|
# We could use [vfs::filesystem info], but that would require |
||||||
|
# loading vfs into every interp. |
||||||
|
if {![file isdirectory $noe]} { |
||||||
|
load {} vfs |
||||||
|
|
||||||
|
# lookup and emulate "source" of lib/vfs1*/{vfs*.tcl,mk4vfs.tcl} |
||||||
|
if {[llength [info command mk::file]]} { |
||||||
|
set driver mk4 |
||||||
|
|
||||||
|
# must use raw Metakit calls because VFS is not yet in place |
||||||
|
set d [mk::select exe.dirs parent 0 name lib] |
||||||
|
set d [mk::select exe.dirs parent $d -glob name vfs1*] |
||||||
|
|
||||||
|
foreach x {vfsUtils vfslib mk4vfs} { |
||||||
|
set n [mk::select exe.dirs!$d.files name $x.tcl] |
||||||
|
if {[llength $n] != 1} { error "$x: cannot find startup script"} |
||||||
|
|
||||||
|
set s [mk::get exe.dirs!$d.files!$n contents] |
||||||
|
catch {set s [zlib decompress $s]} |
||||||
|
uplevel #0 $s |
||||||
|
} |
||||||
|
|
||||||
|
# use on-the-fly decompression, if mk4vfs understands that |
||||||
|
# Note: 8.6 core zlib does not support this for mk4vfs |
||||||
|
if {![package vsatisfies [package require Tcl] 8.6]} { |
||||||
|
set mk4vfs::zstreamed 1 |
||||||
|
} |
||||||
|
} else { |
||||||
|
set driver mkcl |
||||||
|
|
||||||
|
# use raw Vlerq calls if Mk4tcl is not available |
||||||
|
# $::vlerq::starkit_root is set in the init script in kitInit.c |
||||||
|
set rootv [vlerq get $::vlerq::starkit_root 0 dirs] |
||||||
|
set dname [vlerq get $rootv * name] |
||||||
|
set prows [vlerq get $rootv * parent] |
||||||
|
foreach r [lsearch -int -all $prows 0] { |
||||||
|
if {[lindex $dname $r] eq "lib"} break |
||||||
|
} |
||||||
|
|
||||||
|
# glob for a subdir in "lib", then source the specified file inside it |
||||||
|
foreach {d f} { |
||||||
|
vfs1* vfsUtils.tcl vfs1* vfslib.tcl vqtcl4* mkclvfs.tcl |
||||||
|
} { |
||||||
|
foreach z [lsearch -int -all $prows $r] { |
||||||
|
if {[string match $d [lindex $dname $z]]} break |
||||||
|
} |
||||||
|
|
||||||
|
set files [vlerq get $rootv $z files] |
||||||
|
set names [vlerq get $files * name] |
||||||
|
|
||||||
|
set n [lsearch $names $f] |
||||||
|
if {$n < 0} { error "$d/$f: cannot find startup script"} |
||||||
|
|
||||||
|
set s [vlerq get $files $n contents] |
||||||
|
catch {set s [zlib decompress $s]} |
||||||
|
uplevel #0 $s |
||||||
|
} |
||||||
|
|
||||||
|
# hack the mkcl info so it will know this mount point as "exe" |
||||||
|
set vfs::mkcl::v::rootv(exe) $rootv |
||||||
|
set vfs::mkcl::v::dname(exe) $dname |
||||||
|
set vfs::mkcl::v::prows(exe) $prows |
||||||
|
} |
||||||
|
|
||||||
|
# mount the executable, i.e. make all runtime files available |
||||||
|
vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe] |
||||||
|
|
||||||
|
# alter path to find encodings |
||||||
|
if {[info tclversion] eq "8.4"} { |
||||||
|
load {} pwb |
||||||
|
librarypath [info library] |
||||||
|
} else { |
||||||
|
encoding dirs [list [file join [info library] encoding]] ;# TIP 258 |
||||||
|
} |
||||||
|
# if the C code passed us a system encoding, apply it here. |
||||||
|
if {[info exists tclkit_system_encoding]} { |
||||||
|
# It is possible the chosen encoding is unavailable in which case |
||||||
|
# we will be left with 'identity' to be handled below. |
||||||
|
catch {encoding system $tclkit_system_encoding} |
||||||
|
unset tclkit_system_encoding |
||||||
|
} |
||||||
|
# fix system encoding, if it wasn't properly set up (200207.004 bug) |
||||||
|
if {[encoding system] eq "identity"} { |
||||||
|
switch $::tcl_platform(platform) { |
||||||
|
windows { encoding system cp1252 } |
||||||
|
macintosh { encoding system macRoman } |
||||||
|
default { encoding system iso8859-1 } |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
# now remount the executable with the correct encoding |
||||||
|
vfs::filesystem unmount $noe |
||||||
|
set noe $::tcl::kitpath |
||||||
|
# resolve symlinks |
||||||
|
set noe [file dirname [file normalize [file join $noe __dummy__]]] |
||||||
|
|
||||||
|
set tcl_library [file join $noe lib tcl$tcl_version] |
||||||
|
set tcl_libPath [list $tcl_library [file join $noe lib]] |
||||||
|
vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe] |
||||||
|
} |
||||||
|
|
||||||
|
# load config settings file if present |
||||||
|
namespace eval ::vfs { variable tclkit_version 1 } |
||||||
|
catch { uplevel #0 [list source [file join $noe config.tcl]] } |
||||||
|
|
||||||
|
uplevel #0 [list source [file join $tcl_library init.tcl]] |
||||||
|
|
||||||
|
# reset auto_path, so that init.tcl's search outside of tclkit is cancelled |
||||||
|
set auto_path $tcl_libPath |
||||||
|
# Ditto for Tcl module search path |
||||||
|
tcl::tm::path remove {*}[tcl::tm::path list] |
||||||
|
tcl::tm::roots [list [file join $noe lib]] |
||||||
|
} |
||||||
@ -1,36 +0,0 @@ |
|||||||
This software (GRIDPLUS) is Copyright (c) 2004-2015 by Adrian Davis (adrian@satisoft.com). |
|
||||||
|
|
||||||
The author hereby grants permission to use, copy, modify, distribute, |
|
||||||
and license this software and its documentation for any purpose, provided |
|
||||||
that existing copyright notices are retained in all copies and that |
|
||||||
this notice is included verbatim in any distributions. No written agreement, |
|
||||||
license, or royalty fee is required for any of the authorized uses. |
|
||||||
Modifications to this software may be copyrighted by their authors |
|
||||||
and need not follow the licensing terms described here, provided that |
|
||||||
the new terms are clearly indicated on the first page of each file |
|
||||||
where they apply. |
|
||||||
|
|
||||||
IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY |
|
||||||
FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES |
|
||||||
ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY |
|
||||||
DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY |
|
||||||
OF SUCH DAMAGE. |
|
||||||
|
|
||||||
THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, |
|
||||||
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, |
|
||||||
FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE |
|
||||||
IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE |
|
||||||
NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, |
|
||||||
OR MODIFICATIONS. |
|
||||||
|
|
||||||
GOVERNMENT USE: If you are acquiring this software on behalf of the |
|
||||||
U.S. government, the Government shall have only "Restricted Rights" |
|
||||||
in the software and related documentation as defined in the Federal |
|
||||||
Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you |
|
||||||
are acquiring the software on behalf of the Department of Defense, |
|
||||||
the software shall be classified as "Commercial Computer Software" |
|
||||||
and the Government shall have only "Restricted Rights" as defined in |
|
||||||
Clause 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, |
|
||||||
the authors grant the U.S. Government and others acting in its behalf |
|
||||||
permission to use and distribute the software in accordance with the |
|
||||||
terms specified in this license. |
|
||||||
File diff suppressed because it is too large
Load Diff
@ -1 +0,0 @@ |
|||||||
package ifneeded gridplus 2.11 [list source [file join $dir gridplus.tcl]] |
|
||||||
Binary file not shown.
Binary file not shown.
@ -1,145 +1,145 @@ |
|||||||
# dictutils.tcl -- |
# dictutils.tcl -- |
||||||
# |
# |
||||||
# Various dictionary utilities. |
# Various dictionary utilities. |
||||||
# |
# |
||||||
# Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). |
# Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). |
||||||
# |
# |
||||||
# License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). |
# License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). |
||||||
# |
# |
||||||
|
|
||||||
#2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" |
#2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" |
||||||
|
|
||||||
package require Tcl 8.6- |
package require Tcl 8.6- |
||||||
package provide dictutils 0.2.1 |
package provide dictutils 0.2.1 |
||||||
|
|
||||||
namespace eval dictutils { |
namespace eval dictutils { |
||||||
namespace export equal apply capture witharray nlappend |
namespace export equal apply capture witharray nlappend |
||||||
namespace ensemble create |
namespace ensemble create |
||||||
|
|
||||||
# dictutils witharray dictVar arrayVar script -- |
# dictutils witharray dictVar arrayVar script -- |
||||||
# |
# |
||||||
# Unpacks the elements of the dictionary in dictVar into the array |
# Unpacks the elements of the dictionary in dictVar into the array |
||||||
# variable arrayVar and then evaluates the script. If the script |
# variable arrayVar and then evaluates the script. If the script |
||||||
# completes with an ok, return or continue status, then the result is copied |
# completes with an ok, return or continue status, then the result is copied |
||||||
# back into the dictionary variable, otherwise it is discarded. A |
# back into the dictionary variable, otherwise it is discarded. A |
||||||
# [break] can be used to explicitly abort the transaction. |
# [break] can be used to explicitly abort the transaction. |
||||||
# |
# |
||||||
proc witharray {dictVar arrayVar script} { |
proc witharray {dictVar arrayVar script} { |
||||||
upvar 1 $dictVar dict $arrayVar array |
upvar 1 $dictVar dict $arrayVar array |
||||||
array set array $dict |
array set array $dict |
||||||
try { uplevel 1 $script |
try { uplevel 1 $script |
||||||
} on break {} { # Discard the result |
} on break {} { # Discard the result |
||||||
} on continue result - on ok result { |
} on continue result - on ok result { |
||||||
set dict [array get array] ;# commit changes |
set dict [array get array] ;# commit changes |
||||||
return $result |
return $result |
||||||
} on return {result opts} { |
} on return {result opts} { |
||||||
set dict [array get array] ;# commit changes |
set dict [array get array] ;# commit changes |
||||||
dict incr opts -level ;# remove this proc from level |
dict incr opts -level ;# remove this proc from level |
||||||
return -options $opts $result |
return -options $opts $result |
||||||
} |
} |
||||||
# All other cases will discard the changes and propagage |
# All other cases will discard the changes and propagage |
||||||
} |
} |
||||||
|
|
||||||
# dictutils equal equalp d1 d2 -- |
# dictutils equal equalp d1 d2 -- |
||||||
# |
# |
||||||
# Compare two dictionaries for equality. Two dictionaries are equal |
# Compare two dictionaries for equality. Two dictionaries are equal |
||||||
# if they (a) have the same keys, (b) the corresponding values for |
# if they (a) have the same keys, (b) the corresponding values for |
||||||
# each key in the two dictionaries are equal when compared using the |
# each key in the two dictionaries are equal when compared using the |
||||||
# equality predicate, equalp (passed as an argument). The equality |
# equality predicate, equalp (passed as an argument). The equality |
||||||
# predicate is invoked with the key and the two values from each |
# predicate is invoked with the key and the two values from each |
||||||
# dictionary as arguments. |
# dictionary as arguments. |
||||||
# |
# |
||||||
proc equal {equalp d1 d2} { |
proc equal {equalp d1 d2} { |
||||||
if {[dict size $d1] != [dict size $d2]} { return 0 } |
if {[dict size $d1] != [dict size $d2]} { return 0 } |
||||||
dict for {k v} $d1 { |
dict for {k v} $d1 { |
||||||
if {![dict exists $d2 $k]} { return 0 } |
if {![dict exists $d2 $k]} { return 0 } |
||||||
if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } |
if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } |
||||||
} |
} |
||||||
return 1 |
return 1 |
||||||
} |
} |
||||||
|
|
||||||
# apply dictVar lambdaExpr ?arg1 arg2 ...? -- |
# apply dictVar lambdaExpr ?arg1 arg2 ...? -- |
||||||
# |
# |
||||||
# A combination of *dict with* and *apply*, this procedure creates a |
# A combination of *dict with* and *apply*, this procedure creates a |
||||||
# new procedure scope populated with the values in the dictionary |
# new procedure scope populated with the values in the dictionary |
||||||
# variable. It then applies the lambdaTerm (anonymous procedure) in |
# variable. It then applies the lambdaTerm (anonymous procedure) in |
||||||
# this new scope. If the procedure completes normally, then any |
# this new scope. If the procedure completes normally, then any |
||||||
# changes made to variables in the dictionary are reflected back to |
# changes made to variables in the dictionary are reflected back to |
||||||
# the dictionary variable, otherwise they are ignored. This provides |
# the dictionary variable, otherwise they are ignored. This provides |
||||||
# a transaction-style semantics whereby atomic updates to a |
# a transaction-style semantics whereby atomic updates to a |
||||||
# dictionary can be performed. This procedure can also be useful for |
# dictionary can be performed. This procedure can also be useful for |
||||||
# implementing a variety of control constructs, such as mutable |
# implementing a variety of control constructs, such as mutable |
||||||
# closures. |
# closures. |
||||||
# |
# |
||||||
proc apply {dictVar lambdaExpr args} { |
proc apply {dictVar lambdaExpr args} { |
||||||
upvar 1 $dictVar dict |
upvar 1 $dictVar dict |
||||||
set env $dict ;# copy |
set env $dict ;# copy |
||||||
lassign $lambdaExpr params body ns |
lassign $lambdaExpr params body ns |
||||||
if {$ns eq ""} { set ns "::" } |
if {$ns eq ""} { set ns "::" } |
||||||
set body [format { |
set body [format { |
||||||
upvar 1 env __env__ |
upvar 1 env __env__ |
||||||
dict with __env__ %s |
dict with __env__ %s |
||||||
} [list $body]] |
} [list $body]] |
||||||
set lambdaExpr [list $params $body $ns] |
set lambdaExpr [list $params $body $ns] |
||||||
set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] |
set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] |
||||||
if {$rc == 0} { |
if {$rc == 0} { |
||||||
# Copy back any updates |
# Copy back any updates |
||||||
set dict $env |
set dict $env |
||||||
} |
} |
||||||
return -options $opts $ret |
return -options $opts $ret |
||||||
} |
} |
||||||
|
|
||||||
# capture ?level? ?exclude? ?include? -- |
# capture ?level? ?exclude? ?include? -- |
||||||
# |
# |
||||||
# Captures a snapshot of the current (scalar) variable bindings at |
# Captures a snapshot of the current (scalar) variable bindings at |
||||||
# $level on the stack into a dictionary environment. This dictionary |
# $level on the stack into a dictionary environment. This dictionary |
||||||
# can later be used with *dictutils apply* to partially restore the |
# can later be used with *dictutils apply* to partially restore the |
||||||
# scope, creating a first approximation of closures. The *level* |
# scope, creating a first approximation of closures. The *level* |
||||||
# argument should be of the forms accepted by *uplevel* and |
# argument should be of the forms accepted by *uplevel* and |
||||||
# designates which level to capture. It defaults to 1 as in uplevel. |
# designates which level to capture. It defaults to 1 as in uplevel. |
||||||
# The *exclude* argument specifies an optional list of literal |
# The *exclude* argument specifies an optional list of literal |
||||||
# variable names to avoid when performing the capture. No variables |
# variable names to avoid when performing the capture. No variables |
||||||
# matching any item in this list will be captured. The *include* |
# matching any item in this list will be captured. The *include* |
||||||
# argument can be used to specify a list of glob patterns of |
# argument can be used to specify a list of glob patterns of |
||||||
# variables to capture. Only variables matching one of these |
# variables to capture. Only variables matching one of these |
||||||
# patterns are captured. The default is a single pattern "*", for |
# patterns are captured. The default is a single pattern "*", for |
||||||
# capturing all visible variables (as determined by *info vars*). |
# capturing all visible variables (as determined by *info vars*). |
||||||
# |
# |
||||||
proc capture {{level 1} {exclude {}} {include {*}}} { |
proc capture {{level 1} {exclude {}} {include {*}}} { |
||||||
if {[string is integer $level]} { incr level } |
if {[string is integer $level]} { incr level } |
||||||
set env [dict create] |
set env [dict create] |
||||||
foreach pattern $include { |
foreach pattern $include { |
||||||
foreach name [uplevel $level [list info vars $pattern]] { |
foreach name [uplevel $level [list info vars $pattern]] { |
||||||
if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } |
if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } |
||||||
upvar $level $name value |
upvar $level $name value |
||||||
catch { dict set env $name $value } ;# no arrays |
catch { dict set env $name $value } ;# no arrays |
||||||
} |
} |
||||||
} |
} |
||||||
return $env |
return $env |
||||||
} |
} |
||||||
|
|
||||||
# nlappend dictVar keyList ?value ...? |
# nlappend dictVar keyList ?value ...? |
||||||
# |
# |
||||||
# Append zero or more elements to the list value stored in the given |
# Append zero or more elements to the list value stored in the given |
||||||
# dictionary at the path of keys specified in $keyList. If $keyList |
# dictionary at the path of keys specified in $keyList. If $keyList |
||||||
# specifies a non-existent path of keys, nlappend will behave as if |
# specifies a non-existent path of keys, nlappend will behave as if |
||||||
# the path mapped to an empty list. |
# the path mapped to an empty list. |
||||||
# |
# |
||||||
proc nlappend {dictvar keylist args} { |
proc nlappend {dictvar keylist args} { |
||||||
upvar 1 $dictvar dict |
upvar 1 $dictvar dict |
||||||
if {[info exists dict] && [dict exists $dict {*}$keylist]} { |
if {[info exists dict] && [dict exists $dict {*}$keylist]} { |
||||||
set list [dict get $dict {*}$keylist] |
set list [dict get $dict {*}$keylist] |
||||||
} |
} |
||||||
lappend list {*}$args |
lappend list {*}$args |
||||||
dict set dict {*}$keylist $list |
dict set dict {*}$keylist $list |
||||||
} |
} |
||||||
|
|
||||||
# invoke cmd args... -- |
# invoke cmd args... -- |
||||||
# |
# |
||||||
# Helper procedure to invoke a callback command with arguments at |
# Helper procedure to invoke a callback command with arguments at |
||||||
# the global scope. The helper ensures that proper quotation is |
# the global scope. The helper ensures that proper quotation is |
||||||
# used. The command is expected to be a list, e.g. {string equal}. |
# used. The command is expected to be a list, e.g. {string equal}. |
||||||
# |
# |
||||||
proc invoke {cmd args} { uplevel #0 $cmd $args } |
proc invoke {cmd args} { uplevel #0 $cmd $args } |
||||||
|
|
||||||
} |
} |
||||||
|
|||||||
@ -1,143 +0,0 @@ |
|||||||
# dictutils.tcl -- |
|
||||||
# |
|
||||||
# Various dictionary utilities. |
|
||||||
# |
|
||||||
# Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). |
|
||||||
# |
|
||||||
# License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). |
|
||||||
# |
|
||||||
|
|
||||||
package require Tcl 8.6- |
|
||||||
package provide dictutils 0.2 |
|
||||||
|
|
||||||
namespace eval dictutils { |
|
||||||
namespace export equal apply capture witharray nlappend |
|
||||||
namespace ensemble create |
|
||||||
|
|
||||||
# dictutils witharray dictVar arrayVar script -- |
|
||||||
# |
|
||||||
# Unpacks the elements of the dictionary in dictVar into the array |
|
||||||
# variable arrayVar and then evaluates the script. If the script |
|
||||||
# completes with an ok, return or continue status, then the result is copied |
|
||||||
# back into the dictionary variable, otherwise it is discarded. A |
|
||||||
# [break] can be used to explicitly abort the transaction. |
|
||||||
# |
|
||||||
proc witharray {dictVar arrayVar script} { |
|
||||||
upvar 1 $dictVar dict $arrayVar array |
|
||||||
array set array $dict |
|
||||||
try { uplevel 1 $script |
|
||||||
} on break {} { # Discard the result |
|
||||||
} on continue result - on ok result { |
|
||||||
set dict [array get array] ;# commit changes |
|
||||||
return $result |
|
||||||
} on return {result opts} { |
|
||||||
set dict [array get array] ;# commit changes |
|
||||||
dict incr opts -level ;# remove this proc from level |
|
||||||
return -options $opts $result |
|
||||||
} |
|
||||||
# All other cases will discard the changes and propagage |
|
||||||
} |
|
||||||
|
|
||||||
# dictutils equal equalp d1 d2 -- |
|
||||||
# |
|
||||||
# Compare two dictionaries for equality. Two dictionaries are equal |
|
||||||
# if they (a) have the same keys, (b) the corresponding values for |
|
||||||
# each key in the two dictionaries are equal when compared using the |
|
||||||
# equality predicate, equalp (passed as an argument). The equality |
|
||||||
# predicate is invoked with the key and the two values from each |
|
||||||
# dictionary as arguments. |
|
||||||
# |
|
||||||
proc equal {equalp d1 d2} { |
|
||||||
if {[dict size $d1] != [dict size $d2]} { return 0 } |
|
||||||
dict for {k v} $d1 { |
|
||||||
if {![dict exists $d2 $k]} { return 0 } |
|
||||||
if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } |
|
||||||
} |
|
||||||
return 1 |
|
||||||
} |
|
||||||
|
|
||||||
# apply dictVar lambdaExpr ?arg1 arg2 ...? -- |
|
||||||
# |
|
||||||
# A combination of *dict with* and *apply*, this procedure creates a |
|
||||||
# new procedure scope populated with the values in the dictionary |
|
||||||
# variable. It then applies the lambdaTerm (anonymous procedure) in |
|
||||||
# this new scope. If the procedure completes normally, then any |
|
||||||
# changes made to variables in the dictionary are reflected back to |
|
||||||
# the dictionary variable, otherwise they are ignored. This provides |
|
||||||
# a transaction-style semantics whereby atomic updates to a |
|
||||||
# dictionary can be performed. This procedure can also be useful for |
|
||||||
# implementing a variety of control constructs, such as mutable |
|
||||||
# closures. |
|
||||||
# |
|
||||||
proc apply {dictVar lambdaExpr args} { |
|
||||||
upvar 1 $dictVar dict |
|
||||||
set env $dict ;# copy |
|
||||||
lassign $lambdaExpr params body ns |
|
||||||
if {$ns eq ""} { set ns "::" } |
|
||||||
set body [format { |
|
||||||
upvar 1 env __env__ |
|
||||||
dict with __env__ %s |
|
||||||
} [list $body]] |
|
||||||
set lambdaExpr [list $params $body $ns] |
|
||||||
set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] |
|
||||||
if {$rc == 0} { |
|
||||||
# Copy back any updates |
|
||||||
set dict $env |
|
||||||
} |
|
||||||
return -options $opts $ret |
|
||||||
} |
|
||||||
|
|
||||||
# capture ?level? ?exclude? ?include? -- |
|
||||||
# |
|
||||||
# Captures a snapshot of the current (scalar) variable bindings at |
|
||||||
# $level on the stack into a dictionary environment. This dictionary |
|
||||||
# can later be used with *dictutils apply* to partially restore the |
|
||||||
# scope, creating a first approximation of closures. The *level* |
|
||||||
# argument should be of the forms accepted by *uplevel* and |
|
||||||
# designates which level to capture. It defaults to 1 as in uplevel. |
|
||||||
# The *exclude* argument specifies an optional list of literal |
|
||||||
# variable names to avoid when performing the capture. No variables |
|
||||||
# matching any item in this list will be captured. The *include* |
|
||||||
# argument can be used to specify a list of glob patterns of |
|
||||||
# variables to capture. Only variables matching one of these |
|
||||||
# patterns are captured. The default is a single pattern "*", for |
|
||||||
# capturing all visible variables (as determined by *info vars*). |
|
||||||
# |
|
||||||
proc capture {{level 1} {exclude {}} {include {*}}} { |
|
||||||
if {[string is integer $level]} { incr level } |
|
||||||
set env [dict create] |
|
||||||
foreach pattern $include { |
|
||||||
foreach name [uplevel $level [list info vars $pattern]] { |
|
||||||
if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } |
|
||||||
upvar $level $name value |
|
||||||
catch { dict set env $name $value } ;# no arrays |
|
||||||
} |
|
||||||
} |
|
||||||
return $env |
|
||||||
} |
|
||||||
|
|
||||||
# nlappend dictVar keyList ?value ...? |
|
||||||
# |
|
||||||
# Append zero or more elements to the list value stored in the given |
|
||||||
# dictionary at the path of keys specified in $keyList. If $keyList |
|
||||||
# specifies a non-existent path of keys, nlappend will behave as if |
|
||||||
# the path mapped to an empty list. |
|
||||||
# |
|
||||||
proc nlappend {dictvar keylist args} { |
|
||||||
upvar 1 $dictvar dict |
|
||||||
if {[info exists dict] && [dict exists $dict {*}$keylist]} { |
|
||||||
set list [dict get $dict {*}$keylist] |
|
||||||
} |
|
||||||
lappend list {*}$args |
|
||||||
dict set dict {*}$keylist $list |
|
||||||
} |
|
||||||
|
|
||||||
# invoke cmd args... -- |
|
||||||
# |
|
||||||
# Helper procedure to invoke a callback command with arguments at |
|
||||||
# the global scope. The helper ensures that proper quotation is |
|
||||||
# used. The command is expected to be a list, e.g. {string equal}. |
|
||||||
# |
|
||||||
proc invoke {cmd args} { uplevel #0 $cmd $args } |
|
||||||
|
|
||||||
} |
|
||||||
Binary file not shown.
@ -0,0 +1,17 @@ |
|||||||
|
|
||||||
|
set local_modules [list\ |
||||||
|
c:/repo/jn/tclmodules/overtype/modules overtype\ |
||||||
|
c:/repo/jn/tclmodules/modpod/modules modpod\ |
||||||
|
c:/repo/jn/tclmodules/packageTest/modules packageTest\ |
||||||
|
c:/repo/jn/tclmodules/gridplus/modules gridplus\ |
||||||
|
c:/repo/jn/tclmodules/tablelist/modules tablelist\ |
||||||
|
c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\ |
||||||
|
c:/repo/jn/tclmodules/Thread/modules Thread\ |
||||||
|
c:/repo/jn/tclmodules/Thread/modules Thread::platform::win32_x86_64\ |
||||||
|
] |
||||||
|
|
||||||
|
set fossil_modules [dict create\ |
||||||
|
] |
||||||
|
|
||||||
|
set git_modules [dict create\ |
||||||
|
] |
||||||
@ -0,0 +1,700 @@ |
|||||||
|
# -*- 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 non-existance) |
||||||
|
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 |
||||||
|
puts stderr ">>> tcl::zipfs::mount //zipfs://$mount_at $modfile" |
||||||
|
tcl::zipfs::mount //zipfs:/$mount_at $modfile |
||||||
|
} |
||||||
|
if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { |
||||||
|
puts stderr "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 $ |
||||||
|
} |
||||||
|
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] |
||||||
|
|
||||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
@ -0,0 +1 @@ |
|||||||
|
source [file dirname [info script]]/tablelist-6.22.tm |
||||||
@ -0,0 +1,11 @@ |
|||||||
|
|
||||||
|
set local_modules [list\ |
||||||
|
c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread\ |
||||||
|
c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread::platform::win32_x86_64_tcl8\ |
||||||
|
] |
||||||
|
|
||||||
|
set fossil_modules [dict create\ |
||||||
|
] |
||||||
|
|
||||||
|
set git_modules [dict create\ |
||||||
|
] |
||||||
Binary file not shown.
Binary file not shown.
@ -0,0 +1,11 @@ |
|||||||
|
|
||||||
|
set local_modules [list\ |
||||||
|
c:/repo/jn/tclmodules/Thread/modules_tcl9 Thread\ |
||||||
|
c:/repo/jn/tclmodules/Thread/modules_tcl9 Thread::platform::win32_x86_64_tcl9\ |
||||||
|
] |
||||||
|
|
||||||
|
set fossil_modules [dict create\ |
||||||
|
] |
||||||
|
|
||||||
|
set git_modules [dict create\ |
||||||
|
] |
||||||
Loading…
Reference in new issue