#! /bin/env tclsh
package require {ycl ns}
namespace import [yclprefix]::ns::normalize
namespace import [yclprefix]::ns::ondeath
namespace import [yclprefix]::ns::unique
package require {ycl proc}
namespace import [yclprefix]::proc::checkargs
namespace import [yclprefix]::proc::upmethod
package require {ycl var upmethods}
if 0 {
upobj (formerly ns::object) is an object system in which, in a method
call, [uplevel 1] is the object, and [uplevel 2] is the caller of the
object.
It turned out not to work very well, because although its convenient to be
able to invoke a method just by naming it, it also means that methods
having the same name as global commands will conflict. The purpose of the
design is almost completely defeted, however, by the fact that calling a
command just by naming it means that the [uplevel] strategy described above
doesn't work anyway. A method must be called through the namespace
ensemble in order for [uplevel 2] to be the caller.
Additionally, changing the semantics such that [uplevel 2] is the caller is
a fairly intrusive change.
}
variable 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]]]
}
}}
upmethod import {*}$import
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 cmd {
namespace ensemble configure $cmd -unknown [list apply [list args {
list apply [list args {
uplevel [list namespace eval [namespace current] $args]
} [namespace current]] [lindex $args 1]
} [namespace ensemble configure $cmd -namespace]]]
namespace eval [namespace ensemble configure $cmd -namespace] [
list namespace path [list [namespace current]::. {*}[
namespace eval [namespace ensemble configure $cmd -namespace] namespace path]]]
}
variable doc::new {
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 {
switch $name {
{} {
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.
}
process {
{{normalize}} $cmd [uplevel namespace current]
}
default {set cmd $name}
}
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 {}}
}
ondeath {
description {
how to die. Name of a command to invoke to die, i.e., when the
namespace is deleted
}
default {}
}
}
}
dict set doc::new args name process [string map [
list {{{normalize}}} [list [namespace current]::normalize] \
{{{unique}}} [list [namespace current]::unique]
] [dict get $doc::new args name process]]
dict set doc::new args cmd process [string map [
list {{{normalize}}} [list [namespace current]::normalize] \
{{{unique}}} [list [namespace current]::unique]
] [dict get $doc::new args cmd process]]
proc new {{name {}} args} {
if {[llength $args] % 2} {
set args [linsert $args 0 0 $name]
set name {}
}
checkargs doc::new
set traceargs {}
#weird things can happen if a proc that already exists gets deleted by
#[namespace ensemble create], like deleting the namespace creating
#the ensemble, so don't do anything if $cmd is already an ensemble command for $name
if {![namespace ensemble exists $cmd] ||
[namespace ensemble configure $cmd -namespace] ne $name} {
#upmethods only work when not exported, so let the user
#decide what to export
#namespace eval $name {
# namespace export {[a-z]*}
#}
namespace eval $name [list namespace ensemble create -prefixes off -command $cmd]
lappend traceargs cmd $cmd
trace add command $cmd delete [list apply [list {name args} {
namespace delete $name
}] $name]
}
namespace eval $name {
namespace eval doc {}
}
layer $cmd
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"
}
$cmd import $importpath
}
if {[info exists ondeath]} {
set ondeath [uplevel [list [namespace current]::normalize $ondeath]]
$cmd ondeath $ondeath
}
return $name
}
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.
Intended for use in object systems where [uplevel 1] is the current
object, and [uplevel 2] is the caller of the method.
}
}
variable 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 parent {*}$parent
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.
}
}
variable 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 type {*}$type
#this is the "toplevel" object. Bootstrap it
namespace eval . {
foreach upmethod {ondeath import method parent type upmethod checkargs checkspec} {
namespace import [namespace parent]::$upmethod
}
namespace import [yclprefix]::var::upmethods::$
namespace import [yclprefix]::var::upmethods::$.exists
namespace import [yclprefix]::var::upmethods::$.locate
#can't export because that would mess upmethod up
#namespace export *
}
new .
#[object] adds [namespace current]::. to the path of an object
namespace eval . [list namespace path {}]