Julian Noble
1 year ago
38 changed files with 5774 additions and 4269 deletions
@ -1,195 +1,195 @@
|
||||
#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 |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
#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 |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
|
@ -0,0 +1,52 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap::handlers::caphandler 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap::handlers::caphandler { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { |
||||
variable pkg punk::cap::handlers::caphandler |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -0,0 +1,52 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap::handlers::scriptlibs 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap::handlers::scriptlibs { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap::handlers::scriptlibs [namespace eval punk::cap::handlers::scriptlibs { |
||||
variable pkg punk::cap::handlers::scriptlibs |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -0,0 +1,127 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap::handlers::templates 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#register using: |
||||
# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates |
||||
|
||||
#By convention and for consistency, we don't register here during package loading - but require the calling app to do it. |
||||
# (even if it tends to be done immediately after package require anyway) |
||||
# registering capability handlers can involve validating existing provider data and is best done explicitly as required. |
||||
# It is also possible for a capability handler to be registered to handle more than one capabilityname |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap::handlers::templates { |
||||
namespace eval capsystem { |
||||
#interfaces for punk::cap to call into |
||||
if {[info commands caphandler.registry] eq ""} { |
||||
punk::cap::interface_caphandler.registry create caphandler.registry |
||||
oo::objdefine caphandler.registry { |
||||
method pkg_register {pkg capname capdict caplist} { |
||||
#caplist may not be complete set - which somewhat reduces its utility here regarding any decisions based on the context of this capname/capdict (review - remove this arg?) |
||||
if {![dict exists $capdict relpath]} { |
||||
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing 'relpath' key" |
||||
return 0 |
||||
} |
||||
set provide_statement [package ifneeded $pkg [package require $pkg]] |
||||
set tmfile [lindex $provide_statement end] |
||||
if {![file exists $tmfile]} { |
||||
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" |
||||
return 0 |
||||
} |
||||
set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder |
||||
if {![file isdirectory $tpath]} { |
||||
puts stderr "punk::cap::handlers::templates::capsystem pkg_register WARNING - unable to validate relpath location [dict get $capdict relpath] ($tpath) for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" |
||||
} |
||||
if {$capname ni $::punk::cap::handlers::templates::handled_caps} { |
||||
lappend ::punk::cap::handlers::templates::handled_caps $capname |
||||
} |
||||
if {[info commands punk::cap::handlers::templates::$capname] eq ""} { |
||||
punk::cap::handlers::templates::api create ::punk::cap::handlers::templates::$capname $capname |
||||
} |
||||
set cname [string map [list . _] $capname] |
||||
upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders |
||||
dict lappend pfolders $pkg $tpath |
||||
return 1 |
||||
} |
||||
method pkg_unregister {pkg} { |
||||
upvar ::punk::cap::handlers::templates::handled_caps hcaps |
||||
foreach capname $hcaps { |
||||
set cname [string map [list . _] $capname] |
||||
upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders |
||||
dict unset pfolders $pkg |
||||
#destroy api objects? |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
variable handled_caps [list] |
||||
#variable pkg_folders [dict create] |
||||
|
||||
# -- --- --- --- --- --- --- |
||||
#handler api for clients of this capability - called via punk::cap::call_handler <capname> <method> ?args? |
||||
# -- --- --- --- --- --- --- |
||||
namespace export * |
||||
|
||||
oo::class create api { |
||||
#return a dict keyed on folder with source pkg as value |
||||
constructor {capname} { |
||||
variable capabilityname |
||||
variable cname |
||||
set cname [string map [list . _] $capname] |
||||
set capabilityname $capname |
||||
} |
||||
method folders {} { |
||||
variable capabilityname |
||||
variable cname |
||||
upvar punk::cap::handlers::templates::pkg_folders_$cname pkg_folders |
||||
package require punk::cap |
||||
set capinfo [punk::cap::capability $capabilityname] |
||||
# e.g {punk.templates {handler punk::mix::templates providers ::somepkg}} |
||||
|
||||
#use the order of pkgs as registered with punk::cap - may have been modified with punk::cap::promote_package/demote_package |
||||
set pkgs [dict get $capinfo providers] |
||||
set folderdict [dict create] |
||||
foreach pkg $pkgs { |
||||
foreach pfolder [dict get $pkg_folders $pkg] { |
||||
dict set folderdict $pfolder [list source $pkg sourcetype package] |
||||
} |
||||
} |
||||
return $folderdict |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { |
||||
variable pkg punk::cap::handlers::templates |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
File diff suppressed because it is too large
Load Diff
@ -1,158 +1,158 @@
|
||||
|
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![string match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [namespace qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [namespace tail $routine] |
||||
|
||||
if {![string match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [namespace which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![namespace exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [namespace eval $base [ |
||||
list [namespace which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
namespace eval $routine [ |
||||
list namespace ensemble configure $routine -unknown [ |
||||
list apply {{base ensemble subcommand args} { |
||||
list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] { |
||||
if {[namespace exists <base>::lib]} { |
||||
set current_paths [namespace path] |
||||
if {"<routine>" ni $current_paths} { |
||||
lappend current_paths <routine> |
||||
} |
||||
namespace path $current_paths |
||||
} |
||||
}] |
||||
|
||||
namespace eval $routine { |
||||
set exportlist [list] |
||||
foreach cmd [info commands [namespace current]::*] { |
||||
set c [namespace tail $cmd] |
||||
if {![string match _* $c]} { |
||||
lappend exportlist $c |
||||
} |
||||
} |
||||
namespace export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[string range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [string range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![namespace exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![namespace exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[string length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] { |
||||
set nspaths [namespace path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
lappend nspaths <cmdns> |
||||
} |
||||
namespace path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set nscaller [uplevel 1 [list namespace current]] |
||||
if {[catch { |
||||
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] |
||||
foreach cmd [info commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [namespace tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
} |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [namespace eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![string match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [namespace qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [namespace tail $routine] |
||||
|
||||
if {![string match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [namespace which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![namespace exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [namespace eval $base [ |
||||
list [namespace which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
namespace eval $routine [ |
||||
list namespace ensemble configure $routine -unknown [ |
||||
list apply {{base ensemble subcommand args} { |
||||
list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] { |
||||
if {[namespace exists <base>::lib]} { |
||||
set current_paths [namespace path] |
||||
if {"<routine>" ni $current_paths} { |
||||
lappend current_paths <routine> |
||||
} |
||||
namespace path $current_paths |
||||
} |
||||
}] |
||||
|
||||
namespace eval $routine { |
||||
set exportlist [list] |
||||
foreach cmd [info commands [namespace current]::*] { |
||||
set c [namespace tail $cmd] |
||||
if {![string match _* $c]} { |
||||
lappend exportlist $c |
||||
} |
||||
} |
||||
namespace export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[string range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [string range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![namespace exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![namespace exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[string length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] { |
||||
set nspaths [namespace path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
lappend nspaths <cmdns> |
||||
} |
||||
namespace path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set nscaller [uplevel 1 [list namespace current]] |
||||
if {[catch { |
||||
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] |
||||
foreach cmd [info commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [namespace tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
} |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [namespace eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
@ -1,195 +1,195 @@
|
||||
#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 |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
#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 |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
|
@ -0,0 +1,52 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap::handlers::caphandler 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap::handlers::caphandler { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { |
||||
variable pkg punk::cap::handlers::caphandler |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -0,0 +1,52 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap::handlers::scriptlibs 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap::handlers::scriptlibs { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap::handlers::scriptlibs [namespace eval punk::cap::handlers::scriptlibs { |
||||
variable pkg punk::cap::handlers::scriptlibs |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -0,0 +1,127 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap::handlers::templates 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#register using: |
||||
# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates |
||||
|
||||
#By convention and for consistency, we don't register here during package loading - but require the calling app to do it. |
||||
# (even if it tends to be done immediately after package require anyway) |
||||
# registering capability handlers can involve validating existing provider data and is best done explicitly as required. |
||||
# It is also possible for a capability handler to be registered to handle more than one capabilityname |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap::handlers::templates { |
||||
namespace eval capsystem { |
||||
#interfaces for punk::cap to call into |
||||
if {[info commands caphandler.registry] eq ""} { |
||||
punk::cap::interface_caphandler.registry create caphandler.registry |
||||
oo::objdefine caphandler.registry { |
||||
method pkg_register {pkg capname capdict caplist} { |
||||
#caplist may not be complete set - which somewhat reduces its utility here regarding any decisions based on the context of this capname/capdict (review - remove this arg?) |
||||
if {![dict exists $capdict relpath]} { |
||||
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing 'relpath' key" |
||||
return 0 |
||||
} |
||||
set provide_statement [package ifneeded $pkg [package require $pkg]] |
||||
set tmfile [lindex $provide_statement end] |
||||
if {![file exists $tmfile]} { |
||||
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" |
||||
return 0 |
||||
} |
||||
set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder |
||||
if {![file isdirectory $tpath]} { |
||||
puts stderr "punk::cap::handlers::templates::capsystem pkg_register WARNING - unable to validate relpath location [dict get $capdict relpath] ($tpath) for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" |
||||
} |
||||
if {$capname ni $::punk::cap::handlers::templates::handled_caps} { |
||||
lappend ::punk::cap::handlers::templates::handled_caps $capname |
||||
} |
||||
if {[info commands punk::cap::handlers::templates::$capname] eq ""} { |
||||
punk::cap::handlers::templates::api create ::punk::cap::handlers::templates::$capname $capname |
||||
} |
||||
set cname [string map [list . _] $capname] |
||||
upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders |
||||
dict lappend pfolders $pkg $tpath |
||||
return 1 |
||||
} |
||||
method pkg_unregister {pkg} { |
||||
upvar ::punk::cap::handlers::templates::handled_caps hcaps |
||||
foreach capname $hcaps { |
||||
set cname [string map [list . _] $capname] |
||||
upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders |
||||
dict unset pfolders $pkg |
||||
#destroy api objects? |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
variable handled_caps [list] |
||||
#variable pkg_folders [dict create] |
||||
|
||||
# -- --- --- --- --- --- --- |
||||
#handler api for clients of this capability - called via punk::cap::call_handler <capname> <method> ?args? |
||||
# -- --- --- --- --- --- --- |
||||
namespace export * |
||||
|
||||
oo::class create api { |
||||
#return a dict keyed on folder with source pkg as value |
||||
constructor {capname} { |
||||
variable capabilityname |
||||
variable cname |
||||
set cname [string map [list . _] $capname] |
||||
set capabilityname $capname |
||||
} |
||||
method folders {} { |
||||
variable capabilityname |
||||
variable cname |
||||
upvar punk::cap::handlers::templates::pkg_folders_$cname pkg_folders |
||||
package require punk::cap |
||||
set capinfo [punk::cap::capability $capabilityname] |
||||
# e.g {punk.templates {handler punk::mix::templates providers ::somepkg}} |
||||
|
||||
#use the order of pkgs as registered with punk::cap - may have been modified with punk::cap::promote_package/demote_package |
||||
set pkgs [dict get $capinfo providers] |
||||
set folderdict [dict create] |
||||
foreach pkg $pkgs { |
||||
foreach pfolder [dict get $pkg_folders $pkg] { |
||||
dict set folderdict $pfolder [list source $pkg sourcetype package] |
||||
} |
||||
} |
||||
return $folderdict |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { |
||||
variable pkg punk::cap::handlers::templates |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
File diff suppressed because it is too large
Load Diff
@ -1,158 +1,158 @@
|
||||
|
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![string match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [namespace qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [namespace tail $routine] |
||||
|
||||
if {![string match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [namespace which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![namespace exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [namespace eval $base [ |
||||
list [namespace which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
namespace eval $routine [ |
||||
list namespace ensemble configure $routine -unknown [ |
||||
list apply {{base ensemble subcommand args} { |
||||
list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] { |
||||
if {[namespace exists <base>::lib]} { |
||||
set current_paths [namespace path] |
||||
if {"<routine>" ni $current_paths} { |
||||
lappend current_paths <routine> |
||||
} |
||||
namespace path $current_paths |
||||
} |
||||
}] |
||||
|
||||
namespace eval $routine { |
||||
set exportlist [list] |
||||
foreach cmd [info commands [namespace current]::*] { |
||||
set c [namespace tail $cmd] |
||||
if {![string match _* $c]} { |
||||
lappend exportlist $c |
||||
} |
||||
} |
||||
namespace export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[string range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [string range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![namespace exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![namespace exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[string length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] { |
||||
set nspaths [namespace path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
lappend nspaths <cmdns> |
||||
} |
||||
namespace path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set nscaller [uplevel 1 [list namespace current]] |
||||
if {[catch { |
||||
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] |
||||
foreach cmd [info commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [namespace tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
} |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [namespace eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![string match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [namespace qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [namespace tail $routine] |
||||
|
||||
if {![string match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [namespace which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![namespace exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [namespace eval $base [ |
||||
list [namespace which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
namespace eval $routine [ |
||||
list namespace ensemble configure $routine -unknown [ |
||||
list apply {{base ensemble subcommand args} { |
||||
list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] { |
||||
if {[namespace exists <base>::lib]} { |
||||
set current_paths [namespace path] |
||||
if {"<routine>" ni $current_paths} { |
||||
lappend current_paths <routine> |
||||
} |
||||
namespace path $current_paths |
||||
} |
||||
}] |
||||
|
||||
namespace eval $routine { |
||||
set exportlist [list] |
||||
foreach cmd [info commands [namespace current]::*] { |
||||
set c [namespace tail $cmd] |
||||
if {![string match _* $c]} { |
||||
lappend exportlist $c |
||||
} |
||||
} |
||||
namespace export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[string range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [string range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![namespace exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![namespace exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[string length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] { |
||||
set nspaths [namespace path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
lappend nspaths <cmdns> |
||||
} |
||||
namespace path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set nscaller [uplevel 1 [list namespace current]] |
||||
if {[catch { |
||||
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] |
||||
foreach cmd [info commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [namespace tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
} |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [namespace eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
@ -1,195 +1,195 @@
|
||||
#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 |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
#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 |
||||
} |
||||
} |
||||
|
||||
} |
||||
|
||||
|
@ -0,0 +1,52 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap::handlers::caphandler 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap::handlers::caphandler { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap::handlers::caphandler [namespace eval punk::cap::handlers::caphandler { |
||||
variable pkg punk::cap::handlers::caphandler |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -0,0 +1,52 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap::handlers::scriptlibs 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap::handlers::scriptlibs { |
||||
|
||||
|
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap::handlers::scriptlibs [namespace eval punk::cap::handlers::scriptlibs { |
||||
variable pkg punk::cap::handlers::scriptlibs |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
@ -0,0 +1,127 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from <pkg>-buildversion.txt |
||||
# |
||||
# Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. |
||||
# Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# (C) 2023 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::cap::handlers::templates 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license <unspecified> |
||||
# @@ Meta End |
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
##e.g package require frobz |
||||
|
||||
|
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
#register using: |
||||
# punk::cap::register_capabilityname templates ::punk::cap::handlers::templates |
||||
|
||||
#By convention and for consistency, we don't register here during package loading - but require the calling app to do it. |
||||
# (even if it tends to be done immediately after package require anyway) |
||||
# registering capability handlers can involve validating existing provider data and is best done explicitly as required. |
||||
# It is also possible for a capability handler to be registered to handle more than one capabilityname |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
namespace eval punk::cap::handlers::templates { |
||||
namespace eval capsystem { |
||||
#interfaces for punk::cap to call into |
||||
if {[info commands caphandler.registry] eq ""} { |
||||
punk::cap::interface_caphandler.registry create caphandler.registry |
||||
oo::objdefine caphandler.registry { |
||||
method pkg_register {pkg capname capdict caplist} { |
||||
#caplist may not be complete set - which somewhat reduces its utility here regarding any decisions based on the context of this capname/capdict (review - remove this arg?) |
||||
if {![dict exists $capdict relpath]} { |
||||
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - package '$pkg' is attempting to register with punk::cap as a provider of '$capname' capability, but is missing 'relpath' key" |
||||
return 0 |
||||
} |
||||
set provide_statement [package ifneeded $pkg [package require $pkg]] |
||||
set tmfile [lindex $provide_statement end] |
||||
if {![file exists $tmfile]} { |
||||
puts stderr "punk::cap::handlers::templates::capsystem::pkg_register WARNING - unable to determine base folder for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" |
||||
return 0 |
||||
} |
||||
set tpath [file normalize [file join $tmfile [dict get $capdict relpath]]] ;#relpath is relative to the tm *file* - not it's containing folder |
||||
if {![file isdirectory $tpath]} { |
||||
puts stderr "punk::cap::handlers::templates::capsystem pkg_register WARNING - unable to validate relpath location [dict get $capdict relpath] ($tpath) for package '$pkg' which is attempting to register with punk::cap as a provider of '$capname' capability" |
||||
} |
||||
if {$capname ni $::punk::cap::handlers::templates::handled_caps} { |
||||
lappend ::punk::cap::handlers::templates::handled_caps $capname |
||||
} |
||||
if {[info commands punk::cap::handlers::templates::$capname] eq ""} { |
||||
punk::cap::handlers::templates::api create ::punk::cap::handlers::templates::$capname $capname |
||||
} |
||||
set cname [string map [list . _] $capname] |
||||
upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders |
||||
dict lappend pfolders $pkg $tpath |
||||
return 1 |
||||
} |
||||
method pkg_unregister {pkg} { |
||||
upvar ::punk::cap::handlers::templates::handled_caps hcaps |
||||
foreach capname $hcaps { |
||||
set cname [string map [list . _] $capname] |
||||
upvar ::punk::cap::handlers::templates::pkg_folders_$cname pfolders |
||||
dict unset pfolders $pkg |
||||
#destroy api objects? |
||||
} |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
variable handled_caps [list] |
||||
#variable pkg_folders [dict create] |
||||
|
||||
# -- --- --- --- --- --- --- |
||||
#handler api for clients of this capability - called via punk::cap::call_handler <capname> <method> ?args? |
||||
# -- --- --- --- --- --- --- |
||||
namespace export * |
||||
|
||||
oo::class create api { |
||||
#return a dict keyed on folder with source pkg as value |
||||
constructor {capname} { |
||||
variable capabilityname |
||||
variable cname |
||||
set cname [string map [list . _] $capname] |
||||
set capabilityname $capname |
||||
} |
||||
method folders {} { |
||||
variable capabilityname |
||||
variable cname |
||||
upvar punk::cap::handlers::templates::pkg_folders_$cname pkg_folders |
||||
package require punk::cap |
||||
set capinfo [punk::cap::capability $capabilityname] |
||||
# e.g {punk.templates {handler punk::mix::templates providers ::somepkg}} |
||||
|
||||
#use the order of pkgs as registered with punk::cap - may have been modified with punk::cap::promote_package/demote_package |
||||
set pkgs [dict get $capinfo providers] |
||||
set folderdict [dict create] |
||||
foreach pkg $pkgs { |
||||
foreach pfolder [dict get $pkg_folders $pkg] { |
||||
dict set folderdict $pfolder [list source $pkg sourcetype package] |
||||
} |
||||
} |
||||
return $folderdict |
||||
} |
||||
} |
||||
|
||||
|
||||
} |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Ready |
||||
package provide punk::cap::handlers::templates [namespace eval punk::cap::handlers::templates { |
||||
variable pkg punk::cap::handlers::templates |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
return |
File diff suppressed because it is too large
Load Diff
@ -1,158 +1,158 @@
|
||||
|
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![string match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [namespace qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [namespace tail $routine] |
||||
|
||||
if {![string match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [namespace which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![namespace exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [namespace eval $base [ |
||||
list [namespace which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
namespace eval $routine [ |
||||
list namespace ensemble configure $routine -unknown [ |
||||
list apply {{base ensemble subcommand args} { |
||||
list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] { |
||||
if {[namespace exists <base>::lib]} { |
||||
set current_paths [namespace path] |
||||
if {"<routine>" ni $current_paths} { |
||||
lappend current_paths <routine> |
||||
} |
||||
namespace path $current_paths |
||||
} |
||||
}] |
||||
|
||||
namespace eval $routine { |
||||
set exportlist [list] |
||||
foreach cmd [info commands [namespace current]::*] { |
||||
set c [namespace tail $cmd] |
||||
if {![string match _* $c]} { |
||||
lappend exportlist $c |
||||
} |
||||
} |
||||
namespace export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[string range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [string range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![namespace exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![namespace exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[string length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] { |
||||
set nspaths [namespace path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
lappend nspaths <cmdns> |
||||
} |
||||
namespace path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set nscaller [uplevel 1 [list namespace current]] |
||||
if {[catch { |
||||
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] |
||||
foreach cmd [info commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [namespace tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
} |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [namespace eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
||||
|
||||
package require punk::mix::util |
||||
|
||||
namespace eval ::punk::overlay { |
||||
#based *loosely* on: wiki.tcl-lang.org/page/ensemble+extend |
||||
# extend an ensemble-like routine with the routines in some namespace |
||||
# |
||||
# e.g custom_from_base ::punk::mix::cli ::punk::mix::base |
||||
# |
||||
proc custom_from_base {routine base} { |
||||
if {![string match ::* $routine]} { |
||||
set resolved [uplevel 1 [list ::namespace which $routine]] |
||||
if {$resolved eq {}} { |
||||
error [list {no such routine} $routine] |
||||
} |
||||
set routine $resolved |
||||
} |
||||
set routinens [namespace qualifiers $routine] |
||||
if {$routinens eq {::}} { |
||||
set routinens {} |
||||
} |
||||
set routinetail [namespace tail $routine] |
||||
|
||||
if {![string match ::* $base]} { |
||||
set base [uplevel 1 [ |
||||
list [namespace which namespace] current]]::$base |
||||
} |
||||
|
||||
if {![namespace exists $base]} { |
||||
error [list {no such namespace} $base] |
||||
} |
||||
|
||||
set base [namespace eval $base [ |
||||
list [namespace which namespace] current]] |
||||
|
||||
|
||||
#while 1 { |
||||
# set renamed ${routinens}::${routinetail}_[info cmdcount] |
||||
# if {[namespace which $renamed] eq {}} break |
||||
#} |
||||
|
||||
namespace eval $routine [ |
||||
list namespace ensemble configure $routine -unknown [ |
||||
list apply {{base ensemble subcommand args} { |
||||
list ${base}::_redirected $ensemble $subcommand |
||||
}} $base |
||||
] |
||||
] |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${routine}::util |
||||
#namespace eval ${routine}::util { |
||||
#namespace import ::punk::mix::util::* |
||||
#} |
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ${base}::lib::* ${routine}::lib |
||||
#namespace eval ${routine}::lib [string map [list <base> $base] { |
||||
# namespace import <base>::lib::* |
||||
#}] |
||||
|
||||
namespace eval ${routine}::lib [string map [list <base> $base <routine> $routine] { |
||||
if {[namespace exists <base>::lib]} { |
||||
set current_paths [namespace path] |
||||
if {"<routine>" ni $current_paths} { |
||||
lappend current_paths <routine> |
||||
} |
||||
namespace path $current_paths |
||||
} |
||||
}] |
||||
|
||||
namespace eval $routine { |
||||
set exportlist [list] |
||||
foreach cmd [info commands [namespace current]::*] { |
||||
set c [namespace tail $cmd] |
||||
if {![string match _* $c]} { |
||||
lappend exportlist $c |
||||
} |
||||
} |
||||
namespace export {*}$exportlist |
||||
} |
||||
|
||||
return $routine |
||||
} |
||||
#load *exported* commands from cmdnamespace into caller's namespace - prefixing each command with $prefix |
||||
#Note: commandset may be imported by different CLIs with different bases *at the same time* |
||||
#so we don't make commands from the cli or its base available automatically (will generally require fully-qualified commands to use code from cli/base) |
||||
#we do load punk::mix::util::* into the util subnamespace even though the commandset might not be loaded in a cli using punk::mix::base i.e punk::mix::util is a common dependency for CLIs. |
||||
#commandsets designed to be used with a specific cli/base may choose to do their own import e.g with util::namespace_import_pattern_to_namespace_noclobber and/or set namespace path if they |
||||
#want the convenience of using lib:xxx with commands coming from those packages. |
||||
#This won't stop the commandset being used with other cli/bases unless the import is done by looking up the callers namespace. |
||||
#The basic principle is that the commandset is loaded into the caller(s) with a prefix |
||||
#- but commandsets should explicitly package require if they have any backwards dependencies on cli/base (which they may or may not be loaded into) |
||||
proc import_commandset {prefix separator cmdnamespace} { |
||||
set bad_seps [list "::"] |
||||
if {$separator in $bad_seps} { |
||||
error "import_commandset invalid separator '$separator'" |
||||
} |
||||
#namespace may or may not be a package |
||||
# allow with or without leading :: |
||||
if {[string range $cmdnamespace 0 1] eq "::"} { |
||||
set cmdpackage [string range $cmdnamespace 2 end] |
||||
} else { |
||||
set cmdpackage $cmdnamespace |
||||
set cmdnamespace ::$cmdnamespace |
||||
} |
||||
|
||||
if {![namespace exists $cmdnamespace]} { |
||||
#only do package require if the namespace not already present |
||||
catch {package require $cmdpackage} pkg_load_info |
||||
#recheck |
||||
if {![namespace exists $cmdnamespace]} { |
||||
set prov [package provide $cmdpackage] |
||||
if {[string length $prov]} { |
||||
set provinfo "(package $cmdpackage is present with version $prov)" |
||||
} else { |
||||
set provinfo "(package $cmdpackage not present)" |
||||
} |
||||
error "punk::overlay::import_commandset supplied namespace '$cmdnamespace' doesn't exist. $provinfo Pkg_load_result: $pkg_load_info Usage: import_commandset prefix separator namespace" |
||||
} |
||||
} |
||||
|
||||
punk::mix::util::namespace_import_pattern_to_namespace_noclobber ::punk::mix::util::* ${cmdnamespace}::util |
||||
|
||||
#let child namespace 'lib' resolve parent namespace and thus util::xxx |
||||
namespace eval ${cmdnamespace}::lib [string map [list <cmdns> $cmdnamespace] { |
||||
set nspaths [namespace path] |
||||
if {"<cmdns>" ni $nspaths} { |
||||
lappend nspaths <cmdns> |
||||
} |
||||
namespace path $nspaths |
||||
}] |
||||
|
||||
set imported_commands [list] |
||||
set nscaller [uplevel 1 [list namespace current]] |
||||
if {[catch { |
||||
namespace eval ${nscaller}::temp_import [list namespace import ${cmdnamespace}::*] |
||||
foreach cmd [info commands ${nscaller}::temp_import::*] { |
||||
set cmdtail [namespace tail $cmd] |
||||
if {$cmdtail eq "_default"} { |
||||
set import_as ${nscaller}::${prefix} |
||||
} else { |
||||
set import_as ${nscaller}::${prefix}${separator}${cmdtail} |
||||
} |
||||
rename $cmd $import_as |
||||
lappend imported_commands $import_as |
||||
} |
||||
} errM]} { |
||||
puts stderr "Error loading commandset $prefix $separator $cmdnamespace" |
||||
puts stderr "err: $errM" |
||||
} |
||||
return $imported_commands |
||||
} |
||||
} |
||||
|
||||
|
||||
package provide punk::overlay [namespace eval punk::overlay { |
||||
variable version |
||||
set version 0.1 |
||||
}] |
||||
|
Loading…
Reference in new issue