#! /bin/env tclsh
namespace eval ::tcl::mathop {
namespace export *
}
namespace import ::tcl::mathop::!=
#in version 1.8.3, filter evaluates cmdprefix in the scope of its caller
package require struct::list 1.8.3
namespace eval ::struct::list {
namespace export Lfilter
}
namespace import ::struct::list::Lfilter
catch {rename lfilter {}}
rename Lfilter lfilter
package require {ycl proc}
namespace import [yclprefix]::proc::alias
namespace import [yclprefix]::proc::checkargs
namespace import [yclprefix]::proc::checkspec
namespace import [yclprefix]::proc::formals
namespace import [yclprefix]::proc::upmethod
interp alias {} [namespace current]::dupproc {} [yclprefix]::proc::copy
variable proc [yclprefix]::proc
namespace eval doc {}
variable UNIQUE_IN {}
proc absolute? name {
if {[string match ::* $name]} {
return 1
}
return 0
}
proc dupcmds {from to args} {
if {[llength $args] == 0} {
set filter [list ::apply {{name type} {return 1}}]
} elseif {[llength $args] == 1} {
lassign $args filter
} else {
error [list {wrong # args}]
}
if {[string first {::} $from] != 0} {
set from [uplevel 1 [list namespace which -command $from]]
}
if {[string first {::} $to] != 0} {
set to [normalize $to [uplevel {namespace current}]]
}
set copied {}
set procs [::info procs ${from}::*]
foreach proc $procs {
if {![{*}$filter $proc proc]} continue
set toproc ${to}::[namespace tail $proc]
if {[set origin [namespace origin $proc]] ne $proc} {
#imported command. make an alias
alias $toproc $origin
} else {
dupproc $proc $toproc
}
lappend copied $proc
}
foreach cmd [::info commands ${from}::*] {
if {![{*}$filter $cmd command]} continue
if {$cmd in $procs} continue
set tocmd ${to}::[namespace tail $cmd]
if {[namespace ensemble exists $cmd]} {
set cmdns [namespace ensemble configure $cmd -namespace]
#only duplicate an ensemble namespace if it is a child of $from
if {[string range $cmdns 0 [
expr {[string length $from]-1}]] eq $from} {
set tocmdns $to[
string range $cmdns [string length $from] end]
if {![namespace exists $tocmdns]} {
duplicate $cmdns $tocmdns
}
}
ensemble duplicate $cmd $tocmd
} else {
#alias other non-procedure commands. It's the best we can do.
alias $tocmd [namespace origin $cmd]
lappend copied $cmd
}
}
return $copied
}
variable doc::duplicate {
description {
duplicate a namespace
}
args {
from {
description {
positional
the namespace to duplicate
}
}
to {
description {
positional
the namespace that will become a duplicate of $from
}
}
base {
description {
used internally during recursive calls to duplicate
}
default {
lindex $to
}
}
prune {
description {
A command that receives one argument, the name of a namespace
within $from, and returns true or false, indicating whether or
not to prune (skip for duplication purposes) the namespace.
}
default {
lindex [namespace current]::prune
}
}
vars {
description {
A list of variables to duplicate. If the list is empty, no
variables are duplicated. By default, all variables are
copied.
}
default {}
}
cmd_filter {
description {
A command prefix to which the source name and type will be
appended, and which returns true if the name is excepted an
false otherwise
}
default {}
}
}
}
proc duplicate {from to args} {
checkargs $doc::duplicate {*}$args
if {[string first {::} $from] != 0} {
set from [normalize $from [uplevel {namespace current}]]
}
if {[string first {::} $to] != 0} {
set to [normalize $to [uplevel {namespace current}]]
}
namespace eval $to {}
set fromlen [string length $from]
#duplicate children before duplicating commands so that any
#namespaces needed by ensembles already exist
#This de-laces namespace and ensemble creation
foreach child [namespace children $from] {
if {[string first $base $from] >= 0} {
#don't copy self into self
continue
}
set relchild [string range $child $fromlen end]
if {$child eq $to} {
continue
}
if {[$prune $child]} {
continue
}
duplicate $child $to$relchild base $base
}
set dupvars [list dupvars $from $to]
if {[::info exists vars]} {
lappend dupvars $vars
}
{*}$dupvars
set dupcmds [list dupcmds $from $to]
if {[::info exists cmd_filter]} {
lappend dupcmds $cmd_filter
}
{*}$dupcmds
#could use -clear, but choose instead to keep whatever is there.
#Caveat Emptor.
namespace eval $to [list namespace export {*}[
namespace eval $to {namespace export}] {*}[
namespace eval $from {namespace export}]]
namespace eval $to [list namespace path [
list {*}[namespace eval $to {namespace path}] {*}[
namespace eval $from {namespace path}]]]
namespace eval $to [list namespace unknown [
namespace eval $from {namespace unknown}]]
return $to
}
proc dupproc {from to} {
if {[string first {::} $from] != 0} {
set from [uplevel 1 [list namespace which -command $from]]
}
if {[string first {::} $to] != 0} {
set to [normalize $to [uplevel {namespace current}]]
}
set args [::info args $from]
set newargs [formals $from]
set parent [namespace qualifiers $to]
if {$parent eq {}} {
set parent ::
}
if {![namespace exists $parent]} {
namespace eval $parent {}
}
proc $to $newargs [::info body $from]
}
#copy all procs from namespace $from to namespace $to
proc dupprocs {from to} {
foreach proc [::info proc ${from}::*] {
dupproc $proc ${to}::[namespace tail $proc]
}
}
variable doc::dupvars {
description {
Duplicate variables from one namespace to another.
}
args {
from {
description {
The namespace to copy from.
}
positional true
}
to {
description {
The namespace to copy to.
}
positional true
}
names {
description {
A list of relative variable names in from to copy.
}
positional true
optional true
}
}
}
proc dupvars {from to args} {
if {[llength $args] == 0} {
set names [::info vars ${from}::*]
} elseif {[llength $args] == 1} {
lassign $args names
} else {
error [list {wrong # args}]
}
if {[string first :: $from] != 0} {
set from [normalize $from [uplevel {namespace current}]]
}
if {[string first :: $to] != 0} {
set to [normalize $to [uplevel {namespace current}]]
}
foreach name $names {
if {[string match ::* $name]} {
set fullfrom $name
} else {
set fullfrom ${from}::$name
}
set fullto ${to}::[namespace tail $name]
if {![catch [list upvar #0 $fullfrom $fullfrom]]} {
#Variable was created by upvar. Continue the tradition.
upvar 0 $fullfrom $fullto
continue
}
if {[namespace which -variable $fullfrom] ne {}} {
if {[::info exists $fullfrom]} {
if {[array exists $fullfrom]} {
array set $fullto [array get $fullfrom]
} else {
set $fullto [set $fullfrom]
}
} else {
#var is declared but not defined
variable $name
}
}
}
}
namespace eval info {
namespace ensemble create
namespace export *
namespace eval doc {}
variable doc::vars {
description {
like [info vars], but does not include names of variables in the
global script, and only returns the simple name.
}
}
proc vars {} {
set ns [uplevel 1 {namespace current}]
if {![string match *:: $ns]} {
append ns ::
}
lmap varname [uplevel 1 [list ::info vars]] {
if {[string first $ns $varname]} {
namespace tail $varname
} else {
continue
}
}
}
}
proc join args {
::join [lmap arg $args {namespace qualifiers ${arg}::fake}] ::
}
if 0 {
args:
id
the namespace to operate on
subcommand
name of the new subcommand
args
the command prefix assigned to subcommand
value
modified map for $id
description
as a convenience, if args are not supplied, the calling environment is
searched for a proc having the same name as subcommand
}
proc map {id subcommand args} {
if {![llength $args]} {
set args [list $subcommand]
}
set target [lindex $args 0]
set target [uplevel 1 [list [namespace current]::normalize $target \
[uplevel {namespace current}]]]
if [string equal $target {}] {
return -code error "no such target: $target"
}
set args [lreplace $args[unset args] 0 0 $target]
set map [namespace ensemble configure $id -map]
dict set map $subcommand $args
namespace ensemble configure $id -map $map
return $map
}
variable doc::mv {
}
proc move {old new} {
set new [uplevel 1 [list ::namespace eval $new {namespace current}]]
lassign [uplevel 1 [list ::namespace eval $old {
list [namespace children] [info commands [namespace current]::*] [info vars [namespace current]::*]
}]] children commands vars
foreach var $vars {
variable ${new}::[namespace tail $var] [set $var]
}
set ensembles {}
foreach command $commands {
set status [catch [
list namespace ensemble configure $command] cres copts]
if {$status} {
rename $command ${new}::[namespace tail $command]
} else {
set newname ${new}::[namespace tail $command]
dict set cres -namespace $newname
lappend ensembles $command $cres
}
}
foreach child $children {
set newchild ${new}::[namespace tail $child]
if {![namespace exists $newchild]} {
move $child $newchild
}
}
foreach {command config} $ensembles {
dict set config -command ${new}::[namespace tail $command]
set namespace [dict get $config -namespace]
if {[string first ${new}:: $namespace] < 0} {
set ensns [namespace current]::[info cmdcount]_ns
move $namespace $ensns
dict set config -namespace $ensns
}
dict unset config -map
dict unset config -subcommands
dict unset config -namespace
namespace eval $namespace [
list namespace ensemble create {*}$config]
}
namespace eval $new [list ::namespace path [
uplevel 1 [list ::namespace eval $old {namespace path}]]]
set exports [uplevel 1 [list ::namespace eval $old {namespace export}]]
namespace eval $new [list namespace export -clear $exports]
uplevel 1 [list namespace delete $old]
return $new
}
variable doc::new {
description {
create a new namespace
}
args {
of {
description {
what to create a new instance of
}
process {
uplevel 1 [list [namespace current]::normalize $of]
}
}
name {
description {
optional
name of the new namespace
}
process {
uplevel 1 [list [namespace current]::normalize $name]
}
default {
set upns [uplevel {namespace current}]
while {[::info exists ${upns}::[incr name]]} {}
lindex ${upns}::$name
}
}
prune {
description {
optional
name of a procedure that specifies whether to prune a namespace
when duplicating
}
process {
lappend dupargs prune $prune
}
default {}
}
}
}
proc new args {
set dupargs {}
checkargs $doc::new {*}$args
ensemble duplicate $of $name {*}$dupargs
}
# Mind the case of namespaces named ":" !
proc normalize {name args} {
if {[llength $args] > 1} {
return -code error [list {wrong # args} {should be} {name ?namespace?}]
}
if {$name eq {}} {
return ::
}
if {![string match ::* $name]} {
if {[llength $args] == 0} {
set name [uplevel {namespace current}]::$name
} else {
set name [lindex $args 0]::$name
}
}
while {$name ne {}} {
lappend path [namespace tail $name]
set name [namespace qualifiers $name]
}
lappend path {}
set path [lreverse $path[set path {}]]
set res [::join $path[set path {}] ::]
return $res
}
variable doc::disposal {
description {
Arrange for a namespace to be deleted when one of its namespace
ensemble commands is deleted .
Register a teardown method for an object. The teardown method is
called just prior to the deletion of the object.
"object" means an ensemble commmand where the name of the object
command name itself is automatically inserted as the first argument.
}
}
proc disposal {objname ns args} {
if {[llength $args]} {
set cmd [lindex $args 0]
set trace [list ::apply [list {cmd oldname newname ops} {
#this catch is a hack
#todo: fix trace so that trace errors don't disappear
if {[catch {
if {$cmd ne {}} {
$oldname $cmd
}
#the namespace may already be deleted, causing this command to be
#deleted
catch {namespace delete $oldname}
if {[namespace which $oldname] ne {}} {
rename $oldname {}
}
} eres eopts]} {
puts stderr [dict get $eopts -errorinfo]
puts stderr [dict get $eopts -errorstack]
#this currently gets swallowed by Tcl trace machinery
return -options $eopts $eres
}
} $ns] $cmd]
trace add command $objname delete $trace
}
return $trace
}
variable doc::object {
description
create
a command
the new object
a new namespace
to store variables of the new object
make commands in $ns
first argument
name of the command for the new object
available as subcommands of the new command
}
proc object {ns args} {
if {![llength $args]} {
set objns [namespace current]::[info cmdcount]
} else {
set args [lassign $args[set args {}] name]
set name [uplevel 1 [namespace which normalize] $name[set name {}]]
if {[llength $args]} {
lassign $args objns
} else {
set objns $name
}
}
set ns [uplevel 1 [namespace which normalize] $ns[set ns {}]]
set objns [uplevel 1 [list namespace eval $objns {
namespace export *
proc .namespace _ {
namespace current
}
namespace current
}]]
namespace eval $objns [list ::namespace path [list $ns {*}[
namespace eval $objns {namespace path}]]]
if {![::info exists name]} {
set name $objns
}
uplevel 1 [list ::interp alias {} $name {} ::apply [list {name args} {
tailcall [lindex $args 0] $name {*}[lrange $args 1 end]
} $objns] $name]
return $name
}
variable doc::powerimport {
description {
Like [namespace import], but temporarily exports all names in that
namespace first.
}
}
proc powerimport {args} {
foreach arg $args {
set ns [namespace qualifiers $arg]
if {$ns eq {}} {
set ns ::
}
set prevexports [::uplevel 1 [list namespace eval $ns {namespace export}]]
uplevel 1 [list ::namespace eval $ns {namespace export *}]
uplevel 1 [list ::namespace import $arg]
namespace eval $ns [list namespace export -clear {*}$prevexports]
}
}
variable doc::prune {
description {
Indicates whether or not to prune some child namespace while
duplicating a namespace .
}
args {
ns {
description {
the name of the namespace to test
}
}
}
}
proc prune ns {
set first [lindex [namespace tail $ns] 0]
expr {$first eq {$} || [string is digit $first]}
}
proc split path {
set path [::split $path[set path {}] :]
lappend res [lindex $path 0]
lappend res {*}[lmap x [lrange $path[set path {}] 1 end] {
if {$x eq {}} {
continue
} else {
lindex $x
}
}]
return $res
}
variable doc::unique {
description {
generate unique namespace names
incremements ${prefix}::${in}::$Id
}
args {
prefix {
description {
namespace prefix for $in
}
default {
set prefix {}
}
}
in {
description {
namespace relative to prefix to create the unique namespace in
}
default {}
}
}
value {
a namespace which currently doesn't exist, and which this function will never return again
}
}
proc unique args {
variable UNIQUE_IN
variable Id
checkargs $doc::unique {*}$args
if {$prefix eq {}} {
set prefix [namespace current]
}
if {![::info exists in]} {
set in $UNIQUE_IN
}
set id [::join [::struct::list filter [list ${prefix} ${in} [incr Id]] {!= {}}] ::]
return $id
}
proc vars args {
set args [lassign $args[set args {}] namespace]
if {$namespace eq {}} {
set namespace [uplevel 1 {namespace current}]
}
if {![llength $args]} {
# the local [info info vars]
set args [info vars]
}
foreach var $args {
if {![string is list $var]} {
set var [list $var]
}
if {[llength $var] == 1} {
lappend vars [lindex $var 0] [lindex $var 0]
} else {
lappend vars {*}$var
}
}
uplevel 1 [list namespace upvar $namespace {*}$vars]
return
}