#! /bin/env tclsh
# Currently requires Tcl checkin [edf6105464] or later, and also that the
# "semantic check" in TclOODefineClassObjCmd be commented out.
package require {ycl ns}
namespace import [yclprefix]::ns::absolute?
namespace import [yclprefix]::ns::normalize
namespace import [yclprefix]::ns::which
package require {ycl list}
[yclprefix] ns powerimport [yclprefix]::list::add
rename add ladd
package require {ycl shelf tcloo state}
::oo::objdefine ::oo::object {
export unknown
}
::oo::define ::oo::class {export createWithNamespace}
namespace path [list {*}[namespace path] [namespace current]]
::oo::define [namespace current] {
namespace eval [::info object namespace [uplevel 1 {::namespace current}]] {
package require {ycl shelf tclooutil}
package require {ycl shelf util}
namespace import [yclprefix]::shelf::util::.apply
namespace import [yclprefix]::shelf::util::.attribute
namespace import [yclprefix]::shelf::util::.plugin
package require {ycl proc}
namespace import [yclprefix]::proc::checkargs
namespace import [yclprefix]::proc::import
namespace eval doc {}
}
self mixin [uplevel 1 {::namespace current}]
method .~ args {
}
method $ {name args} {
if {[llength $args]} {
if {[string match ::* $name]} {
set newname $name
} else {
set newname [self]::$name
}
return [set $newname {*}$args]
}
set [my $.locate $name]
}
method $.exists name {
catch my $.locate $name
}
method $.locate name {
::if {[::string match ::* $name]} {
set newname $name
} else {
::set newname [self namespace]::$name
}
if {[info exists $newname]} {
return $newname
}
set basis [self]
while 1 {
while 1 {
::set basis [$basis .basis]
::if {$basis eq {}} {
# We've reached the root object.
break
}
# Use the .state method here because the .configure method uses
# $.locate.
::if {![$basis .state get .conf injected]} break
}
set newname ${basis}::$name
if {[info exists $newname]} {
return $newname
}
::if {$basis eq {}} {
# We've reached the root object.
break
}
}
try {::set $newname} on error {tres topts} {
::return -code error -errorcode [
::list VIAVAR LOOKUP VARNAME $name] \
[::list {can't read} $name {no such variable}]
}
}
method <cloned> source {
set mode [$source .state get .lastcopy]
# Don't use the built-in TclOO <cloned> command . It's too limited for
# our purposes. Doesn't clone child namespaces or commands that aren't
# procs.
#next $source
if {$mode eq {clone}} {
my .util ns duplicate $source [self namespace] cmd_filter [
list ::apply [list {name type} {
expr {[namespace tail $name] ni {my myclass}}
} [namespace current]]]
}
}
method .bases {} {
set basis [my .basis]
if {$basis eq {}} {
return
}
list $basis {*}[$basis .bases]
}
method .basis args {
if {[llength $args] == 1} {
lassign $args new
set old [my .basis]
if {![string match ::* $new]} {
set new_orig $new
set new [uplevel 1 [list ::namespace which $new]]
if {$new eq {}} {
error [list {no such shelf} $new_orig]
}
}
::oo::define [self] superclass $new
my .basischanged $old $new
return [my .basis]
} elseif {[llength $args]} {
return -code error [list {wrong # args}]
} else {
set basis [lindex [info class superclasses [self]] 0]
# {to do} make this robust against renaming of ::oo::object
if {$basis eq {::oo::object}} {
set basis {}
}
return $basis
}
}
method .basischanged {old new} {
if {[my .basis] eq $old} return
set changed 0
foreach routine [$new .routines] {
# {to do} give routines an epoch and only modify if changed
$new .rdup $self [$new .routines]
}
set methods [$new .methods]
if {[my .configure injected]} {
set classes [info class superclasses [self]]
set class0 [lindex $classes 0]
if {$new eq $class0} {
# the basis of the injected tree is changed injected methods
# override methods in the new basis
set bases [my .bases]
set methods [lmap method $methods[set methods {}] {
set mname [$new .methodname $new $method]
if {[my .methodexists $method]} {
set mname [my .methodname [self] $method]
if {[namespace which $mname] ne {}} {
set site [$mname .site]
if {$site ni $bases} {
# this is an injected method
continue
}
}
}
set method
}]
}
}
foreach method $methods {
# {to do} make it possible to use .methodexists here
if {[$new .state exists methods $method]} {
if {[my .methodexists $method]} {
set epocha [[$new .methodname $new $method] .epoch]
set epochb [[my .methodname [self] $method] .epoch]
if {$epocha eq $epochb} continue
my .methoddelete $method
} elseif {[my .routineexists $method]} {
my .routinedelete $method
}
$new .methodduplicate $method [self]
foreach spawn [my .spawnedlist] {
$spawn .basismodifiedmethod [self] $method
}
}
}
}
method .basismodifiedmethod {basis name} {
$basis .methodduplicate $name [self]
}
namespace eval [::info object namespace [uplevel 1 {::namespace current}]] {
variable doc::.configure {
description {
Configure this object. Arguments are taken as a dictionary . If there
is an odd number of arguments and the first argument is "!"
(exclamation) , admin mode is activated , which permits configuring
items that are normally read-only .
}
args {
_ {}
injected {
default {lindex 0}
}
}
}
}
method .configure args [string map [list \
@checkargs@ [yclprefix]::shelf::util::checkargs \
@doc@ {my $ doc::.configure} \
@get@ {my .state get .conf $name} \
@exists@ {my .state exists .conf $name} \
@self@ {[self]} \
@set@ {my .state set .conf $name $value}] [
[yclprefix] shelf util configure_template
] \
]
method configure args [string map [list \
@checkargs@ [yclprefix]::shelf::util::checkargs \
@doc@ {my $ doc::configure} \
@get@ {my .state get conf $name} \
@exists@ {my .state exists conf $name} \
@self@ {[self]} \
@set@ {my .state set conf $name $value}] [
[yclprefix] shelf util configure_template
] \
]
method .clone to {
if {$to eq {}} {
::set to [::namespace current]::[::info cmdcount]
}
set existing [uplevel 1 [namespace which $to]]
if {$existing ne {} && [namespace qualifiers $existing eq [
uplevel 1 {::namespace current}]]} {
uplevel 1 [list ::rename $to {}]
}
if {[uplevel 1 [list ::namespace exists $to]]} {
uplevel 1 [list ::namespace delete $to]
}
my .state set .lastcopy clone
::set newto [::uplevel 1 [list ::oo::copy [self] $to $to]]
set mixins [lmap mixin [info object mixins $newto] {
# Invariant {A {ycl shelf} object is always mixed into itself}
if {$mixin eq [self]} {
lindex $newto
} else {
lindex $mixin
}
}]
::oo::objdefine $newto mixin $mixins
# This is the trick that makes ycl shelf work. A class becomes an
# instance of itself by mixing itself into itself.
# For proper operation, this must happen before any methods are invoked
# on the new object.
::oo::objdefine $newto mixin $newto
namespace eval [info object namespace $newto] [list my .reset]
set methods [my .state get methods]
set tons [info object namespace $newto]
foreach {method minfo} $methods {
set mname [my .methodname $tons $method]
dict update minfo indices indices {}
lassign $indices index
set map [namespace ensemble configure $mname -map]
set map [dict merge $map[set map {}] [
dict create \
_ [list ::lindex $newto] \
. [list $newto] \
.epoch [list ::lindex [info cmdcount]]
]]
namespace ensemble configure $mname -map $map
set forward [info class forward $newto $method]
set forward [lreplace $forward[
set forward {}] $index $index $mname]
oo::define $newto [list forward $method {*}$forward]
oo::define $newto [list export $method]
}
my .dupdisposal $newto
$newto .cloned [self]
return $newto
}
method .cloned _ {
return $_
}
method .copied to {
set methods [my .methods]
foreach method $methods {
if {$method eq {.state}} {
continue
}
if {[my .state exists methods $method]} {
set minfo [my .state get methods $method]
my .methodduplicate $method $to
}
}
}
method .disposal args {
if {[::llength $args] == 1} {
::set trace [::lindex $args 0]
set oldtrace [my .state get disposal]
if {$oldtrace ne {}} {
trace remove command [self] delete $oldtrace
}
# $args eats up the standard trace arguments
set tracecmd [list ::apply [list {_ trace args} {
::tailcall $_ {*}$trace
} [my .namespace]] [self] $trace]
trace add command [self] delete $tracecmd
my .state set disposal $tracecmd
return
} elseif {[::llength $args]} {
::error [::list {wrong # args}]
} else {
lindex [my .state get disposal] 3
}
}
method .dupdisposal to {
::set disposal [my .disposal]
::if {$disposal ne {}} {
$to .disposal $disposal
}
}
method .eject shelf {
if {![string match ::* $shelf]} {
set shelf_orig $shelf
set shelf [uplevel 1 [list namespace which $shelf]]
if {$shelf eq {}} {
error [list {no such shelf} $shelf_orig]
}
}
set current [self]
set mixins [::info object mixins [self]]
set mixins [lmap mixin $mixins[set mixins {}] {
if {$mixin eq $shelf} continue
lindex $mixin
}]
set eject 0
while {[set candidate [$current .basis]] ne $current} {
if {$candidate eq $shelf} {
$current .basis [$shelf .basis]
uplevel 1 [list oo::define [self] self mixin -set {*}$mixins]
set eject 1
break
}
set current $candidate
}
if {!$eject} {
error [list {not in the hierarchy} $shelf]
}
}
method .inject shelf {
::if {![absolute? $shelf]} {
::set shelf [::uplevel 1 [::list [namespace which which] $shelf]]
}
set basis [my .basis]
set shelfbasis [$shelf .basis]
my .state set ignorebasischanges 1
try {
# change my basis first so that events trickle down when $shelf
# basis changes
my .basis $shelf
} finally {
my .state set ignorebasischanges 0
}
$shelf .configure injected true
$shelf .basis $basis
# add the old basis back so that $shelf gets notified of any changes
oo::define $shelf [list superclass -append $shelfbasis]
my .basischanged $basis $shelf
return
}
method .invoke args {
::tailcall ::namespace eval [self namespace] $args
}
namespace eval [::info object namespace [uplevel 1 {namespace current}]] {
::variable doc::methodduplicate {
description {
duplicates a method
caller must delete any existing method first
}
}
}
method .methodduplicate {name to} {
set minfo [my .state get methods $name]
dict update minfo indices indices {}
lassign $indices index
set forward [info class forward [self] $name]
set mname [lindex $forward $index]
#args args args1 args1 resolved resolved {}
set mname [my .methodname [self] $name]
set site [$mname .site]
set epoch [$mname .epoch]
set resolved [lindex $forward 0]
set args1 [lrange $forward 1 $index-1]
set args [lrange $forward $index+1 end]
$to .methodmake $name $site $epoch $resolved $args1 {*}$args
}
method .method {name args} {
::if {[::llength $args] == 0} {
::set args1 {}
::set cmdname $name
::set name [::namespace tail $name]
} else {
set args [::lassign $args[set args {}] cmdname]
set args1 [lassign $cmdname[set cmdname {}] cmdname]
}
set resolved [uplevel 1 [list [namespace which my] .resolve $cmdname]]
my .methodmake $name [self] [info cmdcount] $resolved $args1 {*}$args
}
method .methoddelete name {
rename [my .methodname [self] $name] {}
::oo::define [self] [list deletemethod $name]
}
method .methodexists name {
if {$name in [info class methods [self]]} {
if {![my .state exists routine $name]} {
return 1
}
}
return 0
}
method .methodmake {name site epoch resolved args1 args} {
if {$resolved eq {}} {
error [list {can not resolve} $name]
}
if {[my .methodexists $name]} {
my .methoddelete $name
}
my .state set methods $name indices [expr {[llength $args1]+1}]
set mname [my .methodname [self] $name]
set mname [namespace ensemble create -command $mname -map [
dict create \
_ [list ::lindex [self]] \
. [list [self]] \
.action [list ::lindex $name] \
.site [list ::lindex $site] \
.epoch [list ::lindex $epoch]
]]
::oo::define [self] forward $name $resolved {*}$args1 $mname \
{*}$args
::oo::define [self] export $name
my .notifymethodmodified $name
}
method .methodname {shelf name} {
set name [my .pathencode $name]
return [info object namespace $shelf]::.shelfmethod_$name
}
method .methods {} {
set res [info class methods [self]]
lappend seen [self]
set superclasses [info class superclasses [self]]
while {[llength $superclasses]} {
set superclasses [lassign $superclasses[set superclasses {}] class]
lappend superclasses {*}[info class superclasses $class]
set methods [info class methods $class]
if {{.methods} ni $methods} {
continue
}
if {$class in $seen} continue
foreach method [$class .methods] {
if {$method ni $res} {
lappend res $method
}
}
}
return $res
}
method .methodwhich name {
set routine [my .methodname [self] $name]
namespace which $routine
}
method .namespace {} {
self namespace
}
method .next name {
set calls [info class call [self] $name]
set idx 0
foreach call $calls {
incr idx
lassign $call type name site mtype
if {[self] eq $site} {
break
}
}
if {$idx >= [llength $calls]} {
error [list {no next action}]
}
lassign [lindex $calls $idx] type name site mtype
set forward [info class forward $site $name]
set args1 [lassign $forward routine method]
list $site $routine $method $args1
}
method .notifymethodmodified name {
foreach class [info class subclasses [self]] {
$class .basismodifiedmethod [self] $name
}
}
method .pathencode path {
string map {{;} {;;} : {;} } $path
}
method .plug {shelf args} {
::tailcall [namespace parent [namespace parent]]::util .tcloo_plug [self] [
list [yclprefix] shelf tcloo shelf] $shelf {*}$args
}
method .rdup {name to} {
set rinfo [my .state get routines $name]
if {[$to .methodexists $name]} {
$to .methoddelete $name
} elseif {[$to .routineexists]} {
$to .routinedelete $name
}
$to .routinemake $name {*}$forwarded
}
method .renamed {oldname newname ops} {
}
method .routine {name args} {
set name0 [namespace tail $name]
if {![llength $args]} {
set target $name
} else {
set args [lassign $args[set args {}] target]
}
set resolved [uplevel 1 [list [self] .resolve $target]]
if {$resolved eq {}} {
error [list {no such routine} $target]
}
if {[my .methodexists $name]} {
my .methoddelete $name
}
my .routinemake $name $resolved {*}$args
}
method .routinedelete name {
oo::define [self] [list deletemethod $name]
my .state unset routine $name
}
method .routineexists name {
my .state exists routines $name
}
method .routinemake {name target args} {
# coordinate the number of arguments with .rdup
::oo::define [self] forward $name $target {*}$args
my .state set routine $name {}
::oo::define [self] export $name
}
method .resolve name {
if {[string match ::* $name]} {
return $name
}
set normalized [normalize $name [
uplevel 1 {::namespace current}]]
set found [namespace which $normalized]
if {$found ne {}} {
return $found
}
return
}
method .routines {} {
if {[my .state exists routine]} {
dict keys [my .state get routine]
} else {
return {}
}
}
method .self {} self
method .setup to {
namespace eval [info object namespace $to] [
list my .reset]
# {to do} maybe make state a namespace ensemble
::set state [[yclprefix] shelf tcloo state new]
::oo::define $to [list forward .state $state]
::oo::define $to {export .state}
$to .eval my .state_initialize
my .dupdisposal $to
return
}
method .reset {} {
namespace eval [self namespace] {
catch {::rename [namespace current]::.my {}}
interp alias {} [namespace current]::.my {} [namespace current]::my
}
trace add command [self] rename [::list [self] renamed]
}
method .spawn to {
if {$to eq {}} {
::set to [namespace current]::[info cmdcount]
}
set existing [uplevel 1 [namespace which $to]]
if {$existing ne {} && [namespace qualifiers $existing eq [
uplevel 1 {::namespace current}]]} {
uplevel 1 [list ::rename $to {}]
}
if {[uplevel 1 [list ::namespace exists $to]]} {
uplevel 1 [list ::namespace delete $to]
}
my .state set .lastcopy spawn
::set newto [uplevel 1 [list ::oo::class createWithNamespace $to $to]]
::oo::define $newto [list superclass [self]]
# This is the trick that makes ycl shelf work. A class becomes an
# instance of itself by mixing itself into itself.
# For proper operation, this must happen before any methods are invoked
# on the new object.
::oo::objdefine $newto mixin $newto
my .setup $newto
my .copied $newto
ladd path {*}[
namespace eval $newto {namespace path}] [self namespace] {*}[namespace eval [
::info object namespace [self]] {namespace path}]
namespace eval $newto [list namespace path $path]
namespace eval $newto [list namespace eval doc {}]
return [$newto .spawned]
}
method .spawnedlist {} {
info class subclasses [self]
}
method .state_initialize {} {
my .state init {
.conf {
injected 0
}
disposal {}
}
}
method .switch {m args} {
set site [$m .site]
set action [$m .action]
if {$site eq {}} {
set site [$_ _]
}
set forward [$site .next $action]
if {![llength $forward]} {
error [list {could not find routine} $action]
}
lassign [$site .next $action] site routine method args1
set newname [my .pathencode $routine]
# {to do} cache previously created methods
# taking into account that an upstream method may be changed
if {[namespace which $newname] ne {}} {
rename $newname {}
}
my .methodmake $newname [$method .site] [info cmdcount] $routine \
{} {*}$args1
puts [list flack $args]
tailcall my $newname {*}$args
}
method .unknown {self name args} {
error [list {unknown action} $name for $self {should be one of} [
lsort -dictionary [list {*}[$self .routines] {*}[$self .methods]]]]
}
method .vars args {
set 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 [self namespace] {*}$vars]
}
return
}
method .wrap {shelf args} {
if {![string match ::* $shelf]} {
set shelf [uplevel 1 [list [namespace which normalize] $shelf]]
}
my .method .unknown [list ::apply [list {_ args} {
::tailcall {*}[$_ . .wrapped] {*}$args
}]]
my .routine .wrapped ::lindex $shelf
}
method unknown args {
my .unknown [self] {*}$args
}
forward .eval my eval
forward .util [yclprefix]::shelf::tclooutil
export {*}{
.~ $ $.exists $.locate .bases .basis .basischanged .basismodifiedmethod
.clone .cloned .configure .disposal .eject .eval .inject .invoke
.methodduplicate .method .methodmake .methoddelete .methodexists
.methodname .methods .methodwhich .namespace .next .plug .plugin
.renamed .resolve .routine .routineexists .routines .site .spawn
.spawned .spawnedlist .state .switch .unknown .vars .wrap .wrapped
}
unexport destroy
}
proc init {_ args} {
checkargs [$_ . $ doc::init] {*}$args
return [$_ _]
}
proc .spawned {_ args} {
return [$_ _]
}
variable .configure {}
# bootstrap
my .setup [namespace current]
my .method .apply
my .method .attribute
my .method .plugin
my .method .spawned
my .method init
my .disposal .~