CMcC 2006-03-06: Here's a simple bit of code to extend any ensemble-like command by means of tcl8.5's namespace ensemble command.
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.
Larry Smith: stacking does a similar job.
#! /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
}]
}
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)}]
}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]}]
}
extend file 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 modify {var args} {
upvar 1 $var dvar
foreach {name val} $args {
dict set dvar $name $val
}
}LV: So, this seems like a nice bit of functionality. Would it be useful enough to include either in Tcl itself or at least Tcllib?
AMG: See also my [dict getnull] example in [dict get].
samoc: oclib.tcl has a similar extend_proc command.
In comp.lang.tcl, 2014-04-04 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} {
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]
}New extensions defined in this way only appear in the ensemble's after they are first called, so the default error message is misleading. Because this variant of extend accepts a script that is evaluated in an arbitrary namespace, it's more robust to use ::proc rather than proc, avoiding the possibility of inadvertently calling the wrong proc.
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 its 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 keys ${var}}] } {return 0} else {return 1}
}
proc get? {tempDict args} {
if {[dict exists $tempDict {*}$args]} {
return [dict get $tempDict {*}$args]
}
}
proc modify {var args} {
set opVar [lindex $var 0]
set dArgs [lrange $var 1 end]
upvar 1 $opVar theDict
foreach {name val} $args {
dict set theDict {*}$dArgs $name $val
}
return $theDict
}
proc pull {var args} {
if {![dict isDict $var]} { upvar 1 $var theDict } else { set theDict $var }
if {![info exists theDict] || $theDict eq ""} {
throw error "dict pull error: $var doesn't exist"
}
foreach val $args {
set nVar [lindex $val 1]
set val [lindex $val 0]
if {$nVar eq ""} {set nVar $val}
upvar 1 $nVar $nVar
set $nVar [dict get? $theDict $val]
dict set returnDict $nVar [set [set nVar]]
}
if { [ info exists returnDict ] } { return $returnDict }
}
proc pullFrom {var args} {
set opVar [lindex $var 0]
set dArgs [lrange $var 1 end]
upvar 1 $opVar theDict
if {![info exists theDict] || $theDict eq ""} {
throw error "dict pull error: $var doesn't exist"
}
foreach val $args {
set nVar [lindex $val 1]
set val [lindex $val 0]
if {$nVar eq ""} {set nVar $val}
upvar 1 $nVar $nVar
set $nVar [dict get? $theDict {*}$dArgs $val]
dict set returnDict $nVar [set [set nVar]]
}
if { [ info exists returnDict ] } { return $returnDict }
}
proc destruct {var args} {
set opVar [lindex $var 0]
set dArgs [lrange $var 1 end]
upvar 1 $opVar theDict
foreach val $args {
set nVar [lindex $val 1]
set val [lindex $val 0]
if {$nVar eq ""} {set nVar $val}
upvar 1 $nVar $nVar
set $nVar [dict get? $theDict {*}$dArgs $val]
dict unset theDict {*}$dArgs $val
}
}
proc push {var args} {
set opVar [lindex $var 0]
set dArgs [lrange $var 1 end]
upvar 1 $opVar theDict
foreach val $args {
set nVar [lindex $val 1]
set val [lindex $val 0]
if {$nVar eq ""} {set nVar $val}
upvar 1 $val fromVal
if {[info exists fromVal]} {
dict set theDict {*}$dArgs $nVar $fromVal
} else {throw error "$val doesn't exist"}
}
return $theDict
}
}