#! /bin/env tclsh
package require ycl::proc
namespace import [yclprefix]::proc::checkargs
namespace import [yclprefix]::proc::checkspec
namespace import [yclprefix]::proc::upmethod
package require ycl::var::upmethods
interp alias {} [namespace current]::copyproc {} [yclprefix]::proc::copy
variable proc [yclprefix]::proc
package require ycl::var
namespace import [yclprefix]::var::$
namespace eval doc {}
variable UNIQUE_IN #
namespace eval niladate {}
variable doc::niladate {
description {
enable calling a namespace ensemble with no args
}
args {
cmd {
description {
the namespace ensemble command to adjust
}
}
move {
description {
where to move the current namespace ensemble command
}
default {
set move niladate::[uplevel [list namespace which $cmd]]
}
}
target {
description {
the command to execute when the namespace is invoked without arguments
}
}
}
}
proc niladate args {
checkargs doc::niladate
uplevel [list rename $cmd $move]
set body {
if {![llength $args]} {
return [$target]
} else {
return [$move {*}$args]
}
}
set body [string map [list \$target [uplevel [list namespace code $target]] \
\$move [list $move]] $body]
uplevel [list proc $cmd args $body]
}
proc copyvars {from to} {
foreach var [info vars ${from}::*] {
set newname [namespace tail $var]
if {[array exists $var ]} {
namespace eval $to [list array set $newname [array get $var]]
} else {
namespace eval $to [list variable $newname [set $var]]
}
}
}
#value: name of new ensemble
proc ensemble {callingspace {id {}} } {
if {$id eq {}} {
set id [unique prefix $callingspace]
} else {
set id [normalize $id $callingspace]
}
if {[namespace exists $id]} {
rename $id {}
#return -code error "namespace already exists: $id"
}
namespace eval $id namespace ensemble create
return $id
}
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 [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
}
proc normalize {name args} {
if {[llength $args] > 1} {
return -code error "wrong #args: should be \[normalize name ?namespace?]"
}
switch -glob $name {
{} {
return ::
}
::* {
return $name
} default {
if {[llength $args] == 0} {
set namespace [uplevel namespace current]
} else {
set namespace [lindex $args 0]
}
if {$namespace ne {} && ![string match *:: $namespace]} {
append namespace ::
}
append namespace $name
return $namespace
}
}
}
variable doc::die {
description {
how to die
}
}
upmethod die {cmd} {} {} {
trace add command $_ delete [list apply [list {cmd args} {
lassign $args name
#this catch is a hack
#todo: fix trace so that trace errors don't disappear
if {[catch {
if {$cmd ne {}} {
$name {*}$cmd
}
#the namespace may already be deleted, causing this command to be
#deleted
catch {namespace delete $name}
if {[info exists $name]} {
rename $name {}
}
} 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
}
} $_] $cmd]
}
variable doc::object {
description {
create a new object, i.e., a namespace with behaviours described below.
Calling [namespace ensemble create] in an already existing object will
cause that object to be deleted. Don't do that if you don't want to do
that.
}
args {
name {
description {
name of the new object, i.e., the ns that underlies the object.
It will be created as namespace ensemble
}
process {
if {$name eq {}} {
set name [lindex [
{{unique}} prefix [namespace current]]]
}
{{normalize}} $name [uplevel namespace current]
}
}
cmd {
description {
a list of a command to represent the object, and any extra
arguments (often a particular subcommand) to pass to ${ns} when
the alias is invoked.
This cmd will be deleted when the object is deleted, and vice
versa.
}
default {}
}
import {
description {
commands to import
}
default {lindex {}}
}
export {
description {
names of commands to export in this namespace. Like [namespace
export], except that the argument is a list of names instead of
patterns, and before being exported, each name is resolved in
the scope of the caller of this proc, exported from its actual
namespace, and imported.
Subcommands can figure out which namespace they are a
subcommand of by inspecting the first argument of [info level
0]. ycl::proc::method is provided as a convenience procedure
for creating commands that act like "methods", i.e., that are
aware of $ns and use it to store state and call sibling
subcommands.
there is also ycl::proc::upmethod, which only works when the
command is *not* exported
}
default {lindex {}}
}
die {
description {
how to die. Name of a command to invoke to die, i.e., when the
namespace is deleted
}
default {}
}
}
}
dict set doc::object args name process [string map [
list {{{normalize}}} [list [namespace current]::normalize] \
{{{unique}}} [list [namespace current]::unique]
] [dict get $doc::object args name process]]
proc object {{name {}} args} {
if {[llength $args] % 2} {
set args [linsert $args 0 0 $name]
set name {}
}
checkargs doc::object
#weird things can happen if a proc that already exists gets deleted by
#[namespace ensemble create], like deleting the namespace creating
#the ensemble, so preemptively remove any exising proc
if {[namespace which $name] eq $name} {
rename $name {}
}
namespace eval $name {
namespace eval doc {}
#upmethods only work when not exported, so let the user
#decide what to export
#namespace export {[a-z]*}
namespace ensemble create -prefixes off
}
layer $name
set traceargs {}
if {[info exists cmd]} {
lassign $cmd cmd targs
interp alias {} $cmd {} $name {*}$targs
lappend traceargs cmd $cmd
trace add command $cmd delete [list apply [list {name args} {
namespace delete $name
}] $name]
}
foreach export $export {
set exportpath [uplevel [list namespace which $export]]
if {$exportpath eq {}} {
return -code error -errorcode [list [namespace current] [
lindex [info level 0] 0] export unknown $export] \
"[lindex [info level 0] 0]: can not find export: $export"
}
set exportns [namespace qualifiers $exportpath]
if {$exportns eq {}} {
set exportns ::
}
namespace eval $exportns [
list namespace export [namespace tail $exportpath]]
namespace eval $name [list namespace import $exportpath]
namespace eval $name [list namespace export $export]
}
foreach import $import {
set importpath [uplevel [list namespace which $import]]
if {$importpath eq {}} {
return -code error -errorcode [list [namespace current] \
[lindex [info level 0] 0] import unknown $import] \
"[lindex [info level 0] 0]: can not find import: $import"
}
$name import $importpath
}
if {[info exists die]} {
set die [uplevel [list [namespace current]::normalize $die]]
} else {
set die {}
}
$name die $die
return $name
}
variable doc::layer {
description {
adds the magic that makes upmethods work: an -unknown entry to the
ensemble evaluates the command in the namespace, thus giving upmethod a
way to find the current object: [uplevel 1 namespace current].
This also "magically" provides commands like [$ns eval] using the
standard ::eval
}
}
proc layer {ns} {
namespace ensemble configure $ns -unknown [list apply [list {args} {
list apply [list args {
uplevel [list namespace eval [namespace current] $args]
} [namespace current]] [lindex $args 1]
} $ns]]
namespace eval $ns [list namespace path [list [namespace current]::. {*}[namespace eval $ns namespace path]]]
}
variable doc::parent {
description {
adds parent (and its parents) to the path of the current object, but
does not import the parent's exported commands. This design allows
upmethods of the parents to be called on the current object.
}
}
upmethod parent {args} {} {} {
#uplevel 2 because uplevel 1 is the current object
foreach parent $args {
set parent [uplevel 2 [list [namespace current]::normalize $parent]]
lappend path $parent
set paths [namespace eval $parent namespace path]
while {[llength $paths]} {
set path1 {}
set paths [lassign $paths path1]
foreach path2 [namespace eval $path1 namespace path] {
if {$path2 ne $path1} {
lappend paths $path2
}
}
if {$path1 ni $path} {
lappend path $path1
}
}
}
foreach path1 [namespace eval $_ namespace path] {
if {$path1 ni $path} {
lappend path $path1
}
}
namespace eval $_ [list namespace path $path]
}
upmethod unparent {parent} {} {} {
parentc
}
variable doc::type {
description {
adds parent to the path of the current object, and also imports
currently-exported commands of the object. This design allows methods
(not upmethods) of parents to be called on the current object.
}
}
upmethod type {parent} {} {} {
#uplevel 2 because uplevel 1 is the current object
set parent [uplevel 2 [list [namespace current]::normalize $parent]]
namespace eval $_ [list namespace path [
list $parent {*}[namespace eval $_ namespace path]]]
foreach pattern [namespace eval $parent namespace export] {
if {[namespace which ${_}::$pattern] eq {}} {
catch {
namespace eval $_ [list namespace import ${parent}::$pattern]
}
namespace eval $_ [list namespace export $pattern]
}
}
}
upmethod import args {} {} {
foreach cmd $args {
set target [uplevel 2 [list namespace which $cmd]]
set tail [namespace tail $target]
set targetns [namespace qualifiers $target]
if {$targetns eq {}} {
return -code error -errorcode [list [namespace current] [
lindex [info level 0] 0] target notfound $target] \
"can't find command: $cmd"
}
namespace eval $targetns [list namespace export $tail]
if {[namespace which ${_}::$tail] ne {}} {
rename ${_}::$tail {}
}
uplevel [list namespace eval $_ [list namespace import $target]]
#objects should export nothing so that [namespace enemble configure -unknown]
#can make sure the uplevel for all subcommands is the namespace
#uplevel [list namespace eval $ns [list namespace export [namespace tail $target]]]
}
}
#SYNOPSIS
# upcmd ARGS
#DESCRIPTION
# Creates a new namespace ensemble in the caller's parent namespace. The new
# command has the same name as the tail of the caller's namespace. The target command prefix
# is set by ARGS
proc upcmd {args} {
set parent [uplevel namespace parent]
set name [uplevel namespace current]
if {[llength $args]} {
set args [lassign $args target]
} else {
set target $name
}
set target [normalize $target $name]
set name [namespace tail $name]
uplevel [namespace current]::map $parent $name $target {*}$args
}
#copy all procs from namespace $from to namespace $to
proc copyprocs {from to} {
foreach proc [info proc ${from}::*] {
copyproc $proc ${to}::[namespace tail $proc]
}
}
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 {
set in {}
}
}
}
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
if {$prefix eq {}} {
set prefix [namespace current]
}
if {$in eq {}} {
set in $UNIQUE_IN
}
set id ${prefix}::${in}::[incr Id]
}
#this is the "toplevel" object. Bootstrap it
namespace eval . {
foreach upmethod {die import method parent type upmethod checkargs checkspec} {
namespace import [namespace parent]::$upmethod
}
namespace import [yclprefix]::var::upmethods::$
namespace import [yclprefix]::var::upmethods::$?
#can't export because that would mess upmethod up
#namespace export *
}
object .
#[object] adds [namespace current]::. to the path of an object
namespace eval . [list namespace path {}]