Tcl's ensembles are handy, but sometimes you want to add a command to an existing one. This page shows some ways you can do that.
Dynamically extending ensembles is risky. The first examples on this page put new procs inside the ensemble's namespace. Because these can shadow core commands in ::, this can impact the behaviour of existing ensemble commands: adding a set subcommand is almost guaranteed to cause problems!
PYK's refinements to the versions below take more care to avoid this risk. There is also ycl shelf subcmd, which offers a more fine-grained way to accomplish the task, allowing a subcommand like set to be mapped to a command named set_, which can be placed in any namespace, not just the namespace of the ensemble:
proc ::some_ensemble::set_ args {
error [list {just kidding} $args]
}
shelf subcmd ::some_ensemble set set_Or, if the command is in another namespace:
shelf subcmd ::some_ensemble:: set ::some_other_namespace::some_command
To use shelf subcmd with an ensemble that doesn't have a map, first create a map for it:
foreach command [ensemble commands some_ensemble] {
shelf subcmd some_ensemble $command
}After that, use shelf subcmd to add more commands.
Another alternative is, Ensemble objects, which with the help of TclOO try to design around the problem for new ensembles.
Here's a simple bit of code to extend any ensemble-like command by means of tcl8.5's namespace ensemble command. CMcC 6Mar2006:
package provide extend 1.0
package require Tcl 8.5
# extend a command with a new subcommand
proc extend {cmd body} {
if {![namespace exists ${cmd}]} {
set wrapper [string map [list %C $cmd %B $body] {
namespace eval %C {}
rename %C %C::%C
namespace eval %C {
proc _unknown {junk subc args} {
return [list %C::%C $subc]
}
namespace ensemble create -unknown %C::_unknown
}
}]
}
append wrapper [string map [list %C $cmd %B $body] {
namespace eval %C {
%B
namespace export -clear *
}
}]
uplevel 1 $wrapper
}Here's the file command extended with newer and newerthan subcommands:
extend file {
proc newer {a b} {
return [expr {[file mtime $a] > [file mtime $b]}]
}
proc newerthan {mtime path} {
return [expr {[file exists $path] && ([file mtime $path] > $mtime)}]
}
}Here's the dict command extended with the modify subcommand:
# extra useful dict commands
extend dict {
proc modify {var args} {
upvar 1 $var dvar
foreach {name val} $args {
dict set dvar $name $val
}
}
}In a comp.lang.tcl posting dated Fri, 04 Apr 2014 09:25:30 DKF posted an example of using the ensemble's -unknown parameter to lazily apply extensions. A version of extend using this technique:
proc extend {ens script} {
namespace eval $ens [concat {
proc _unknown {ens cmd args} {
if {$cmd in [namespace eval ::${ens} {::info commands}]} {
set map [namespace ensemble configure $ens -map]
dict set map $cmd ::${ens}::$cmd
namespace ensemble configure $ens -map $map
}
return "" ;# back to namespace ensemble dispatch
;# which will error appropriately if the cmd doesn't exist
}
} \; $script]
namespace ensemble configure $ens -unknown ${ens}::_unknown
}Note that new extensions defined in this way will not appear in the ensemble's map until they are used, so the default error message is misleading.
PYK 2016-10-14: Fixed various quoting and robustness weaknesses in the implementations on this page. In order to achieve that with CMCC's variant, I modified extend to accept as arguments a procedure specification instead of a complete script. The main advantage to this interface change is that the user doesn't have to worry about encountering an alternate proc in some namespace.
#! /usr/bin/env tclsh
package provide extend 1.0
package require tcl 8.5
# extend a command with new subcommands
proc extend {cmd subcmd subspec body} {
namespace eval [uplevel 1 [list namespace which $cmd]] [string map [
list %subcmd [list $subcmd] %subspec [list $subspec] %body [list $body]] {
if {[namespace which [namespace tail [namespace current]]] ne "[
string trimright [namespace current] :]::[
namespace tail [namespace current]]"} {
::rename [::namespace current] [::namespace current]::[
::namespace tail [::namespace current]]
::namespace export *
::namespace ensemble create -unknown [list ::apply [list {ns subc args} {
::return [::list ${ns}::[::namespace tail $ns] $subc]
} [namespace current]]]
}
puts [list creating %subcmd in [namespace current]]
::proc %subcmd %subspec %body
}]
}Example use:
extend file newer {a b} {
return [expr {[file mtime $a] > [file mtime $b]}]
}
extend file newerthan {mtime path} {
return [expr {[file exists $path] && ([file mtime $path] > $mtime)}]
}DKF's version with some tweaks. This still takes a script.
proc extend {ens script} {
uplevel 1 [string map [list %ens [list $ens]] {
namespace ensemble configure %ens -unknown [list ::apply [list {ens cmd args} {
::if {$cmd in [::namespace eval ::${ens} {::info commands}]} {
::set map [::namespace ensemble configure $ens -map]
::dict set map $cmd ::${ens}::$cmd
::namespace ensemble configure $ens -map $map
}
::return {} ;# back to namespace ensemble dispatch
;# which will error appropriately if the cmd doesn't exist
} [namespace current]]]
}]\;[list namespace eval $ens $script]
}Napier / Dash Automation 2015-12-27 --
I really like ES6 Javascripts capabilities to work with objects such as "const { key1, key2 } = myObject", so I decided to give myself similar functionality with a "dict pull" command. One thing I am not sure of, is if setting an empty string is the proper thing to do when a value doesn't exist. I would like to handle it similar to javascript, but tcl doesn't have a "null" option which could be used to default to false
I know this is somewhat similar to dict update or dict with but the syntax is a bit simpler and it's designed for it's exact purpose, except that it only unpacks the requested keys and will create the variables so they may be used without info exists in cases that is too verbose.
The resulting operation with extend:
set tempDict [dict create foo fooVal bar barVal] dict pull $tempDict foo bar rawr puts $foo ; # % fooVal puts $bar ; # % barVal puts $rawr ; # % ""
and the code:
extend dict {
proc isDict {var} {
if { [::catch {::dict size ${var}}] } {::return 0} else {::return 1}
}
proc get? {tempDict key args} {
if {[::dict exists $tempDict $key {*}$args]} {
::return [::dict get $tempDict $key {*}$args]
}
}
proc pull {var args} {
::upvar 1 $var check
if { [::info exists check] } {
::set d $check
} else { ::set d $var }
::foreach v $args {
::set path [::lassign $v variable name default]
::if { $name eq {} } { ::set name $variable }
::upvar 1 $name value
::if { [::dict exists $d {*}$path $variable] } {
::set value [::dict get $d {*}$path $variable]
} else { ::set value $default }
::dict set rd $name $value
}
::return $rd
}
proc pullFrom {var args} {
::set mpath [::lassign $var var]
::upvar 1 $var check
::if { [::info exists check] } {
::set d $check
} else { ::set d $var }
::foreach v $args {
::set path [::lassign $v variable name default]
::if { $name eq {} } { ::set name $variable }
::upvar 1 $name value
::if { [::dict exists $d {*}$mpath $variable {*}$path] } {
::set value [::dict get $d {*}$mpath $variable {*}$path]
} else { ::set value $default }
::dict set rd $name $value
}
::return $rd
}
proc modify {var args} {
::upvar 1 $var d
::if { ! [info exists d] } { ::set d {} }
::if { [::llength $args] == 1 } { ::set args [::lindex $args 0] }
::dict for { k v } $args { ::dict set d $k $v }
::return $d
}
proc push {var args} {
::if {$var ne "->"} { ::upvar 1 $var d }
::if { ! [::info exists d] } { ::set d {} }
::foreach arg $args {
::set default [::lassign $arg variable name]
::upvar 1 $variable value
::if { [::info exists value] } {
::if { $name eq {} } { ::set name $variable }
::if { $value ne {} } {
::dict set d $name $value
} else { ::dict set d $name $default }
} else { ::throw error "$variable doesn't exist when trying to push $name into dict $var" }
}
::return $d
}
proc pushIf {var args} {
::if {$var ne "->"} { ::upvar 1 $var d }
::if { ! [::info exists d] } { ::set d {} }
::foreach arg $args {
::set default [::lassign $arg variable name]
::upvar 1 $variable value
::if { ! [::info exists value] } { ::throw error "$variable doesn't exist when trying to pushIf $name into dict $var" }
::if { $name eq {} } { ::set name $variable }
::if { $value ne {} } {
::dict set d $name $value
} elseif { $default ne {} } {
::dict set d $name $default
}
}
::return $d
}
proc pushTo {var args} {
::set mpath [::lassign $var var]
::if {$var ne "->"} { ::upvar 1 $var d }
::if { ! [::info exists d] } { ::set d {} }
::foreach arg $args {
::set path [::lassign $arg variable name]
::upvar 1 $variable value
::if { ! [::info exists value] } { ::throw error "$variable doesn't exist when trying to pushTo $name into dict $var at path $path" }
::if { $name eq {} } { ::set name $variable }
::dict set d {*}$mpath {*}$path $name $value
}
::return $d
}
proc destruct {var args} {
::set opVar [::lindex $var 0]
::set dArgs [::lrange $var 1 end]
::upvar 1 $opVar theDict
::if { ! [::info exists theDict] } {
::set theDict {}
}
::set returnDict {}
::foreach val $args {
::lassign $val val nVar def
::if {$nVar eq ""} {::set nVar $val}
::upvar 1 $nVar $nVar
::if {$def ne ""} {
::set $nVar [::if? [::dict get? $theDict {*}$dArgs $val] $def]
} else {
::set $nVar [::dict get? $theDict {*}$dArgs $val]
}
::dict set returnDict $nVar [set $nVar]
::catch {::dict unset theDict {*}$dArgs $val}
}
::return $returnDict
}
proc pickIf {var args} { ::return [::dict pick $var {*}$args] }
proc pick {var args} {
::set tempDict {}
::foreach arg $args {
::lassign $arg key as
::if { [::dict exists $var $key] } {
::if { $as eq {} } { ::set as $key }
::set v [::dict get $var $key]
::if { $v ne {} } { ::dict set tempDict $as $v }
}
}
::return $tempDict
}
proc withKey {var key} {
::set tempDict {}
::dict for {k v} $var {
::if { [::dict exists $v $key] } {
::dict set tempDict $k [::dict get $v $key]
}
}
::return $tempDict
}
::proc fromlist { lst {values {}} } {
::set tempDict {}
::append tempDict [::join $lst " [list $values] "] " [list $values]"
}
proc sort {what dict args} {
::set res {}
::if {$dict eq {}} { ::return }
::set dictKeys [::dict keys $dict]
::switch -glob -nocase -- $what {
"v*" {
::set valuePositions [::dict values $dict]
::foreach value [ ::lsort {*}$args [::dict values $dict] ] {
::set position [::lsearch $valuePositions $value]
::if {$position eq -1} { ::puts "Error for $value" }
::set key [::lindex $dictKeys $position]
::set dictKeys [::lreplace $dictKeys $position $position]
::set valuePositions [::lreplace $valuePositions $position $position]
::dict set res $key $value
}
}
"k*" -
default {
::foreach key [::lsort {*}$args $dictKeys] {
::dict set res $key [::dict get $dict $key]
}
}
}
::return $res
}
proc invert {var args} {
::set d {}
::dict for {k v} $var {
::if {"-overwrite" in $args} {
::dict set d $v $k
} else {
::dict lappend d $v $k
}
}
::return $d
}
proc json {json dict {key {}}} {
::puts "TO JSON: $dict $key"
::upvar 1 $dict convertFrom
::if {![info exists convertFrom] || $convertFrom eq {}} { ::return }
::set key [::if? $key $dict]
$json map_key $key map_open
::dict for {k v} $convertFrom {
::if {$v eq {} || $k eq {}} { ::continue }
::if {[::string is entier -strict $v]} { $json string $k number $v
} elseif {[::string is bool -strict $v]} { $json string $k bool $v
} else { $json string $k string $v
}
}
$json map_close
::return
}
proc serialize { json dict } {
::dict for {k v} $dict {
::if {$v eq {} || $k eq {}} { ::continue }
::if {[::string is entier -strict $v]} { $json string $k number $v
} elseif {[::string is bool -strict $v]} { $json string $k bool $v
} else { $json string $k string $v
}
}
}
proc types {tempDict} {
::set typeDict {}
::dict for {k v} $tempDict {
::if {[::string is entier -strict $v]} { ::dict set typeDict $k number
} elseif {[::string is bool -strict $v]} { ::dict set typeDict $k bool
} else { ::dict set typeDict $k string
}
}
::return $typeDict
}
}