[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.



** Changes **

[PYK] 2016-10-14:   Fixed various quoting and robustness weaknesses in the implementations on this page.  In order to achieve that with Larry Smith'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.



** Description **

[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]: [https://github.com/samoconnor/oclib.tcl%|%oclib.tcl] has a similar `[https://github.com/samoconnor/oclib.tcl/blob/master/oclib/oc_ensemble-1.0.tm#L17%|%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
    }
}

======


<<categories>> Example