97 changed files with 8343 additions and 20602 deletions
@ -1,145 +1,145 @@
|
||||
# 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). |
||||
# |
||||
|
||||
#2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" |
||||
|
||||
package require Tcl 8.6- |
||||
package provide dictutils 0.2.1 |
||||
|
||||
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 } |
||||
|
||||
} |
||||
# 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). |
||||
# |
||||
|
||||
#2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" |
||||
|
||||
package require Tcl 8.6- |
||||
package provide dictutils 0.2.1 |
||||
|
||||
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 } |
||||
|
||||
} |
||||
|
||||
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 |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1.2 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
#variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
set idx $globOrIdx |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key >= 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex $o_data $key] |
||||
#return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
#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} { |
||||
# if {[string is integer -strict $newAlias]} { |
||||
# error "[self object] collection key alias cannot be integer" |
||||
# } |
||||
# if {[string length $existingKeyOrAlias]} { |
||||
# set o_alias($newAlias) $existingKeyOrAlias |
||||
# } else { |
||||
# unset o_alias($newAlias) |
||||
# } |
||||
#} |
||||
#method aliases {{key ""}} { |
||||
# if {[string length $key]} { |
||||
# set result [list] |
||||
# foreach {n v} [array get o_alias] { |
||||
# if {$v eq $key} { |
||||
# lappend result $n $v |
||||
# } |
||||
# } |
||||
# return $result |
||||
# } else { |
||||
# return [array get o_alias] |
||||
# } |
||||
#} |
||||
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
#method realKey {idx} { |
||||
# if {[catch {set o_alias($idx)} key]} { |
||||
# return $idx |
||||
# } else { |
||||
# return $key |
||||
# } |
||||
#} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse_the_collection {} { |
||||
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
||||
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
||||
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1.2 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
#variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
set idx $globOrIdx |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key >= 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex $o_data $key] |
||||
#return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
#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} { |
||||
# if {[string is integer -strict $newAlias]} { |
||||
# error "[self object] collection key alias cannot be integer" |
||||
# } |
||||
# if {[string length $existingKeyOrAlias]} { |
||||
# set o_alias($newAlias) $existingKeyOrAlias |
||||
# } else { |
||||
# unset o_alias($newAlias) |
||||
# } |
||||
#} |
||||
#method aliases {{key ""}} { |
||||
# if {[string length $key]} { |
||||
# set result [list] |
||||
# foreach {n v} [array get o_alias] { |
||||
# if {$v eq $key} { |
||||
# lappend result $n $v |
||||
# } |
||||
# } |
||||
# return $result |
||||
# } else { |
||||
# return [array get o_alias] |
||||
# } |
||||
#} |
||||
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
#method realKey {idx} { |
||||
# if {[catch {set o_alias($idx)} key]} { |
||||
# return $idx |
||||
# } else { |
||||
# return $key |
||||
# } |
||||
#} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse_the_collection {} { |
||||
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
||||
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
||||
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
@ -1,195 +0,0 @@
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key > 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
method alias {newAlias existingKeyOrAlias} { |
||||
if {[string is integer -strict $newAlias]} { |
||||
error "[self object] collection key alias cannot be integer" |
||||
} |
||||
if {[string length $existingKeyOrAlias]} { |
||||
set o_alias($newAlias) $existingKeyOrAlias |
||||
} else { |
||||
unset o_alias($newAlias) |
||||
} |
||||
} |
||||
method aliases {{key ""}} { |
||||
if {[string length $key]} { |
||||
set result [list] |
||||
foreach {n v} [array get o_alias] { |
||||
if {$v eq $key} { |
||||
lappend result $n $v |
||||
} |
||||
} |
||||
return $result |
||||
} else { |
||||
return [array get o_alias] |
||||
} |
||||
} |
||||
#if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
method realKey {idx} { |
||||
if {[catch {set o_alias($idx)} key]} { |
||||
return $idx |
||||
} else { |
||||
return $key |
||||
} |
||||
} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse {} { |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -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% |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
%Major.Minor.Level% |
||||
#First line must be a semantic version number |
||||
#all other lines are ignored. |
||||
|
||||
@ -1,10 +1,10 @@
|
||||
Identifier: %package% |
||||
Version: %version% |
||||
Title: %title% |
||||
Creator: %name% <%email%> |
||||
Description: %description% |
||||
Rights: BSD |
||||
URL: %url% |
||||
Available: |
||||
Architecture: tcl |
||||
Subject: |
||||
Identifier: %package% |
||||
Version: %version% |
||||
Title: %title% |
||||
Creator: %name% <%email%> |
||||
Description: %description% |
||||
Rights: BSD |
||||
URL: %url% |
||||
Available: |
||||
Architecture: tcl |
||||
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;#\ |
||||
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||
::lindex tcl;#\ |
||||
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||
|
||||
@ -1,8 +1,8 @@
|
||||
::lindex tcl;#\ |
||||
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||
puts stdout "exe: [info nameof]" |
||||
puts stdout "scr: [info script]" |
||||
puts stdout "argc: $::argc" |
||||
puts stdout "argv: '$::argv'" |
||||
|
||||
::lindex tcl;#\ |
||||
@call tclsh "%~dp0%~n0.bat" %* & goto :eof |
||||
# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||
puts stdout "exe: [info nameof]" |
||||
puts stdout "scr: [info script]" |
||||
puts stdout "argc: $::argc" |
||||
puts stdout "argv: '$::argv'" |
||||
|
||||
|
||||
@ -1,19 +1,19 @@
|
||||
::set - { |
||||
@goto start |
||||
# -- tcl bat |
||||
:start |
||||
@echo off |
||||
set script=%0 |
||||
echo %* |
||||
if exist %script%.bat set script=%script%.bat |
||||
tclsh %script% %* |
||||
goto end of BAT file |
||||
};unset - ;# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||
|
||||
puts stdout "exe: [info nameof]" |
||||
puts stdout "scr: [info script]" |
||||
puts stdout "argc: $::argc" |
||||
puts stdout "argv: '$::argv'" |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl\ |
||||
:end of BAT file |
||||
::set - { |
||||
@goto start |
||||
# -- tcl bat |
||||
:start |
||||
@echo off |
||||
set script=%0 |
||||
echo %* |
||||
if exist %script%.bat set script=%script%.bat |
||||
tclsh %script% %* |
||||
goto end of BAT file |
||||
};unset - ;# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl |
||||
|
||||
puts stdout "exe: [info nameof]" |
||||
puts stdout "scr: [info script]" |
||||
puts stdout "argc: $::argc" |
||||
puts stdout "argv: '$::argv'" |
||||
|
||||
# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl\ |
||||
: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 |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1.2 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
#variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
set idx $globOrIdx |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key >= 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex $o_data $key] |
||||
#return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
#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} { |
||||
# if {[string is integer -strict $newAlias]} { |
||||
# error "[self object] collection key alias cannot be integer" |
||||
# } |
||||
# if {[string length $existingKeyOrAlias]} { |
||||
# set o_alias($newAlias) $existingKeyOrAlias |
||||
# } else { |
||||
# unset o_alias($newAlias) |
||||
# } |
||||
#} |
||||
#method aliases {{key ""}} { |
||||
# if {[string length $key]} { |
||||
# set result [list] |
||||
# foreach {n v} [array get o_alias] { |
||||
# if {$v eq $key} { |
||||
# lappend result $n $v |
||||
# } |
||||
# } |
||||
# return $result |
||||
# } else { |
||||
# return [array get o_alias] |
||||
# } |
||||
#} |
||||
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
#method realKey {idx} { |
||||
# if {[catch {set o_alias($idx)} key]} { |
||||
# return $idx |
||||
# } else { |
||||
# return $key |
||||
# } |
||||
#} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse_the_collection {} { |
||||
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
||||
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
||||
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
#JMN - api should be kept in sync with package patternlib where possible |
||||
# |
||||
package provide oolib [namespace eval oolib { |
||||
variable version |
||||
set version 0.1.2 |
||||
}] |
||||
|
||||
namespace eval oolib { |
||||
oo::class create collection { |
||||
variable o_data ;#dict |
||||
#variable o_alias |
||||
constructor {} { |
||||
set o_data [dict create] |
||||
} |
||||
method info {} { |
||||
return [dict info $o_data] |
||||
} |
||||
method count {} { |
||||
return [dict size $o_data] |
||||
} |
||||
method isEmpty {} { |
||||
expr {[dict size $o_data] == 0} |
||||
} |
||||
method names {{globOrIdx {}}} { |
||||
if {[llength $globOrIdx]} { |
||||
if {[string is integer -strict $globOrIdx]} { |
||||
set idx $globOrIdx |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $idx} result]} { |
||||
error "[self object] no such index : '$idx'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} else { |
||||
#glob |
||||
return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] |
||||
} |
||||
} else { |
||||
return [dict keys $o_data] |
||||
} |
||||
} |
||||
#like names but without globbing |
||||
method keys {} { |
||||
dict keys $o_data |
||||
} |
||||
method key {{posn 0}} { |
||||
if {$posn < 0} { |
||||
set posn "end-[expr {abs($posn + 1)}]" |
||||
} |
||||
if {[catch {lindex [dict keys $o_data] $posn} result]} { |
||||
error "[self object] no such index : '$posn'" |
||||
} else { |
||||
return $result |
||||
} |
||||
} |
||||
method hasKey {key} { |
||||
dict exists $o_data $key |
||||
} |
||||
method get {} { |
||||
return $o_data |
||||
} |
||||
method items {} { |
||||
return [dict values $o_data] |
||||
} |
||||
method item {key} { |
||||
if {[string is integer -strict $key]} { |
||||
if {$key >= 0} { |
||||
set valposn [expr {(2*$key) +1}] |
||||
return [lindex $o_data $valposn] |
||||
} else { |
||||
set key "end-[expr {abs($key + 1)}]" |
||||
return [lindex $o_data $key] |
||||
#return [lindex [dict keys $o_data] $key] |
||||
} |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
return [dict get $o_data $key] |
||||
} |
||||
} |
||||
#inverse lookup |
||||
method itemKeys {value} { |
||||
set value_indices [lsearch -all [dict values $o_data] $value] |
||||
set keylist [list] |
||||
foreach i $value_indices { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
method search {value args} { |
||||
set matches [lsearch {*}$args [dict values $o_data] $value] |
||||
if {"-inline" in $args} { |
||||
return $matches |
||||
} else { |
||||
set keylist [list] |
||||
foreach i $matches { |
||||
set idx [expr {(($i + 1) *2) -2}] |
||||
lappend keylist [lindex $o_data $idx] |
||||
} |
||||
return $keylist |
||||
} |
||||
} |
||||
#review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? |
||||
#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} { |
||||
# if {[string is integer -strict $newAlias]} { |
||||
# error "[self object] collection key alias cannot be integer" |
||||
# } |
||||
# if {[string length $existingKeyOrAlias]} { |
||||
# set o_alias($newAlias) $existingKeyOrAlias |
||||
# } else { |
||||
# unset o_alias($newAlias) |
||||
# } |
||||
#} |
||||
#method aliases {{key ""}} { |
||||
# if {[string length $key]} { |
||||
# set result [list] |
||||
# foreach {n v} [array get o_alias] { |
||||
# if {$v eq $key} { |
||||
# lappend result $n $v |
||||
# } |
||||
# } |
||||
# return $result |
||||
# } else { |
||||
# return [array get o_alias] |
||||
# } |
||||
#} |
||||
##if the supplied index is an alias, return the underlying key; else return the index supplied. |
||||
#method realKey {idx} { |
||||
# if {[catch {set o_alias($idx)} key]} { |
||||
# return $idx |
||||
# } else { |
||||
# return $key |
||||
# } |
||||
#} |
||||
method add {value key} { |
||||
if {[string is integer -strict $key]} { |
||||
error "[self object] collection key must not be an integer. Use another structure if integer keys required" |
||||
} |
||||
if {[dict exists $o_data $key]} { |
||||
error "[self object] col_processors object error: key '$key' already exists in collection" |
||||
} |
||||
dict set o_data $key $value |
||||
return [expr {[dict size $o_data] - 1}] ;#return index of item |
||||
} |
||||
method remove {idx {endRange ""}} { |
||||
if {[string length $endRange]} { |
||||
error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" |
||||
} |
||||
if {[string is integer -strict $idx]} { |
||||
if {$idx < 0} { |
||||
set idx "end-[expr {abs($idx+1)}]" |
||||
} |
||||
set key [lindex [dict keys $o_data] $idx] |
||||
set posn $idx |
||||
} else { |
||||
set key $idx |
||||
set posn [lsearch -exact [dict keys $o_data] $key] |
||||
if {$posn < 0} { |
||||
error "[self object] no such index: '$idx' in this collection" |
||||
} |
||||
} |
||||
dict unset o_data $key |
||||
return |
||||
} |
||||
method clear {} { |
||||
set o_data [dict create] |
||||
return |
||||
} |
||||
method reverse_the_collection {} { |
||||
#named slightly obtusely because reversing the data when there may be references held is a potential source of bugs |
||||
#the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. |
||||
#todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. |
||||
set dictnew [dict create] |
||||
foreach k [lreverse [dict keys $o_data]] { |
||||
dict set dictnew $k [dict get $o_data $k] |
||||
} |
||||
set o_data $dictnew |
||||
return |
||||
} |
||||
#review - cmd as list vs cmd as script? |
||||
method map {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list {*}$cmd $v]] |
||||
} |
||||
return $seed |
||||
} |
||||
method objectmap {cmd} { |
||||
set seed [list] |
||||
dict for {k v} $o_data { |
||||
lappend seed [uplevel #0 [list $v {*}$cmd]] |
||||
} |
||||
return $seed |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
|
||||
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 -- |
||||
# |
||||
# 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). |
||||
# |
||||
|
||||
#2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" |
||||
|
||||
package require Tcl 8.6- |
||||
package provide dictutils 0.2.1 |
||||
|
||||
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 } |
||||
|
||||
} |
||||
# 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). |
||||
# |
||||
|
||||
#2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" |
||||
|
||||
package require Tcl 8.6- |
||||
package provide dictutils 0.2.1 |
||||
|
||||
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 } |
||||
|
||||
} |
||||
|
||||
@ -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