#! /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::normalize
package require {ycl list}
[yclprefix] ns powerimport [yclprefix]::list::add
rename add ladd
package require {ycl shelf util}
[yclprefix] ns powerimport [yclprefix]::shelf::util::.disposal
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 eval doc {}
}
self mixin [uplevel 1 {namespace current}]
method .~ args {
}
method $ {name args} {
puts [list huga $name]
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 {
puts [list wrok [self] [self namespace] $name]
::if {[::string match ::* $name]} {
set newname $name
} else {
::set newname [self namespace]::$name
}
puts [list bladn $newname]
if {[info exists $newname]} {
return $newname
}
set basis [self]
while 1 {
while 1 {
::set basis [$basis .basis]
::if {[::info class superclass $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 {[::info class superclass $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 .basis args {
if {[llength $args] == 1} {
lassign $args new
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
} elseif {[llength $args]} {
return -code error [list {wrong # args}]
}
lindex [info class superclasses [self]] 0
}
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}]]} {
puts [list bloop $to]
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 .copied [self]]
$newto .cloned [self]
return $newto
}
method .cloned _ {
return $_
}
method .copied from {
::set state [[yclprefix] shelf tcloo state new]
::oo::define [self] [list forward .state $state]
::oo::define [self] {export .state}
my .state_initialize
::set disposal [$from .disposal]
::if {$disposal ne {}} {
my .disposal $disposal
}
interp alias {} [self namespace]::.my {} [self]
trace add command [self] rename [::list [self] renamed]
}
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 .doroutine {class name args} {
::tailcall ::apply [list {name args} {
::tailcall $name {*}$args
} [info object namespace $class]] $name {*}$args
}
method .domethod {shelf args1 args2 args} {
set args1 [lassign $args1[set args1 {}] cmd]
::tailcall my .doinvoke $shelf [self] $cmd $args1 {*}$args2 {*}$args
}
method .doinvoke {shelf self cmd args1 args} {
set ns [info object namespace $shelf]
::tailcall apply [list {cmd args1 self args} {
::tailcall $cmd {*}$args1 $self {*}$args
} $ns] $cmd $args1 $self {*}$args
}
method .doswitch {shelf cmd args} {
lassign [lindex [::info object call [self] $cmd] 0] type0 cmd0 shelf0 imp0
::tailcall my .doinvoke $shelf0 $shelf $cmd {} {*}$args
}
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 {![::string match ::* $shelf]} {
::set shelf [::uplevel 1 [::list namespace which $shelf]]
}
set superclasses [info class superclasse [self]]
::oo::define $shelf [list superclass {*}$superclasses]
::oo::define [self] [list superclass $shelf]
$shelf .configure injected true
}
method .invoke args {
::tailcall ::namespace eval [self namespace] $args
}
method .method {name args} {
::if {[::llength $args] == 0} {
::set args1 [::list $name]
::set args2 {}
::set name [::namespace tail $name]
} elseif {[::llength $args] < 3} {
::lassign $args args1 args2
} else {
error [::list {wrong # args}]
}
::oo::define [self] method $name args [string map [
list @class@ [list [self]] @args1@ [list $args1] @args2@ [
list $args2]] {
lassign [self call] chain index
lassign [lindex $chain $index] type name shelf imptype
set stack [my .state get stack]
lappend stack [self call]
my .state set stack $stack
catch [list uplevel 1 [list [namespace which my] .domethod $shelf @args1@ @args2@ {*}$args ]] cres copts
set stack [lreplace [my .state get stack] end end]
my .state set stack $stack
dict incr copts -level
return -options $copts $cres
}]
::oo::define [self] export $name
}
method .namespace {} {
self namespace
}
method .plug {shelf args} {
::tailcall [namespace parent [namespace parent]]::util .tcloo_plug [self] [
list [yclprefix] shelf tcloo shelf] $shelf {*}$args
}
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]
}
::oo::define [self] forward $name0 my .doroutine [self] $resolved {*}$args
::oo::define [self] export $name0
}
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
}
set basis [my .basis]
return {}
}
method .routines {} {
lmap name [info class methods [self] -all] {
if {$name eq {unknown}} continue
lindex $name
}
}
method .self {} self
method .site {} {
lassign [lindex [my .state get stack] end] chain idx
lassign [lindex $chain $idx] type name shelf imptype
return $shelf
}
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
namespace eval [::info object namespace $newto] [list my .copied [self]]
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 .state_initialize {} {
my .state init {
.conf {
injected 0
}
disposal {}
stack {}
}
}
method .switch {cmd args} {
if {$cmd eq {shelf}} {
set args [lassign $args[set args {}] mshelf mname]
set chain [info object call $mshelf $mname]
set idx 0
} else {
lassign [lindex [my .state get stack] end] chain idx
incr idx
}
lassign [lindex $chain $idx] mtype mname mshelf mimp
if {$mtype eq {}} {
error [list {nothing to switch to} for $mname]
}
set stack [my .state get stack]
lappend stack [list $chain $idx]
my .state set stack $stack
catch [list ::uplevel 1 [list $mshelf .eval [list my .doswitch [
self] $mname {*}$args]]] cres copts
set stack [lreplace [my .state get stack] end end]
my .state set stack $stack
return -options $copts $cres
}
method .unknown args {
::oo::object unknown {*}$args
}
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
}
forward .eval my eval
forward .util [yclprefix]::shelf::tclooutil
method unknown args {
my .unknown {*}$args
}
export {*}{
.~ $ $.exists $.locate .basis .clone .cloned .configure .disposal
.eject .eval .inject .invoke .method .namespace .plug .plugin .renamed
.resolve .routine .routines .site .spawn .spawned .state .switch
.unknown .vars .wrap .wrapped
}
unexport destroy
}
variable .configure {}
my .method .apply
my .method .attribute
my .method .plugin
my .method .spawned
my .method init
proc init {_ args} {
checkargs [$_ $ doc::init] {*}$args
return $_
}
proc .spawned _ {
return $_
}
# bootstrap
my .copied [namespace current]
my .disposal .~