Posted to tcl by aspect at Thu Sep 11 04:47:17 GMT 2014view pretty

#
# for providing commands:
#   eg: [evalwith $obj [info object methods -all $obj] $script
#   will make all methods of obj available as top-level commands
proc evalwith {eval commands script} {
    set eval [uplevel 1 namespace which -command [list $eval]]
    set ns [newns]
    set path [uplevel 1 {linsert [namespace path] 0 [namespace current]}]
    namespace eval $ns [list namespace path $path]
    foreach cmd $commands {
        interp alias {} ${ns}::$cmd {} $eval $cmd
    }
    interp alias {} ${ns}::self {} ::uplevel 1 self
    try {
        uplevel 1 [list namespace eval $ns $script]
    } finally {
        namespace delete $ns
    }
}

# from the wiki - extend an ensemble with new commands
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
        }
    }   \; $script]
    namespace ensemble configure $ens -unknown ${ens}::_unknown

}

extend dict {
    # dict lambda can create a lambdaexpr with the dict keys as params, defaulted to their values
    proc lambda {dict script} {
        tailcall ::lambda [lmap {k v} $dict {list $k $v}] $script
    }
}


extend array {  

    # like [dict with], but for an array
    # and without leaking.  So it needs a namespace argument
    proc with {_array script {ns ""}} {
        upvar 1 $_array a
        set prelude [lmap name [array names a] {
            list upvar 1 a($name) $name
        }]
        set prelude [join $prelude \n]
        set script $prelude\n$script
        if {$ns eq ""} {set ns [list $ns]}
        apply [list {} $script {*}$ns]
    }
}