#! /bin/env tclsh
[yclprefix] proc alias alias [yclprefix] proc alias
alias aliases [yclprefix] proc aliases
aliases {
{ycl list} {
take
}
{ycl eval} {
upcall
}
{ycl ns} {
absolute?
nsjoin join
object
unique
which
}
{ycl proc} {
checkargs
}
}
#warning: any specified instance variables get linked to the variable by the
#same name in the instance namespace. Therefore, higher shelfs won't be
#searched for their value.
proc asmethod {spec {selfvar _}} {
lassign $spec[set spec {}] pargs objvars nsvars body
set pargs [linsert $pargs[set pargs {}] 0 $selfvar]
set script {}
foreach varname $nsvars {
append script [list variable $varname]\n
}
foreach varname $objvars {
if {[llength $varname] == 2} {
lassign $varname[set varname {}] othername localname
} else {
lassign $varname[set varname {}] othername localname
set localname $othername
}
append script [string map [
list {{{selfvar}}} [list $selfvar] {{{localname}}} [
list $localname] {{{othername}}} [list $othername]] {
namespace upvar [
[set {{selfvar}}] .namespace] {{othername}} {{localname}}
}]
}
return [list $pargs $script\n$body]
}
proc configure_template {} {
return {
set doc [@doc@]
set internal 0
if {[llength $args] == 1} {
set name [lindex $args 0]
if {[dict exists $doc args $name]} {
if {[dict exists $doc args $name name]} {
set name [dict get $doc args $name name]
}
return [@get@]
}
return -code error [list {} {unknown configuration item} $name]
} elseif {[llength $args] > 1} {
if {[llength $args] % 2} {
if {[lindex $args 0] eq {!}} {
set internal 1
set args [lrange $args[set args {}] 1 end]
} else {
error "wrong # arguments. Should be <name> <value> ..."
}
}
set res {}
foreach {name value} [apply [list {_ args} {
@checkargs@ [uplevel 1 {set doc}] {*}$args
apply {locals {
# The purpose of this proc is to have a safe place to set a
# variable named x
concat {*}[lmap x $locals {
if {$x in {_ args}} {
continue
}
list $x [uplevel 1 [list set $x]]}]
}} [info locals]
} [namespace current]] @self@ {*}$args] {
if {!$internal && [dict exists $doc args $name automatic]
&& [dict get $doc args $name automatic]} {
return -code error [
list {attempt to configure automatic setting} $name]
}
dict set res $name [@set@]
}
if {[dict size $res] == 1} {
set res [lindex [dict values $res[set res {}]] end]
}
return $res
} else {
set res {}
foreach arg [dict keys [dict get $doc args]] {
if {[dict exists $doc args $arg name]} {
set name [dict get $doc args $arg name]
} else {
set name $arg
}
if {[@exists@]} {
dict set res $arg [@get@]
}
}
return $res
}
}
}
proc doplugin {_ shelf target args} {
::tailcall $shelf {*}$target $_ [$_ .site] {*}$args
}
apply [list {} {
set template {
if {![string match ::* $shelf]} {
set shelf_orig $shelf
set shelf [uplevel 1 [list namespace which $shelf[set shelf {}]]]
if {$shelf eq {}} {
error [list {shelf does not exist} $shelf_orig]
}
}
if {![llength $args]} {
if {[$shelf .state exists plugins]} {
set args [$shelf .state get plugins]
}
}
set name [{*}$base .spawn [info cmdcount]]
@plug@
foreach method $args {
lassign $method mname target
if {[llength $method] == 1} {
set target $mname
set mname [lindex $target 0]
} elseif {[llength $method] == 2} {
} elseif {[llength $method] == 0} {
error [list {wrong # args}]
}
$name .method $mname [list [namespace which doplugin]] [list $shelf $target]
}
trace add command [$_ _] delete [list rename $name {}]
$_ . .inject $name
return $name
}
proc .nsshelf_plug {_ base shelf args} [string map [list @plug@ {
$name .state set plugged $shelf
}] $template]
proc .tcloo_plug {_ base shelf args} [string map [list @plug@ {
# This is a little tricky. $name acts as an instantiated object when
# called directly, but also acts as a superclass of $_.
# Requires a pyk-TclOO
oo::objdefine $name class $shelf
}] $template]
} [namespace current]]
proc .new args {
variable shelfns
if {[llength $args]} {
take args name
set ns $name
} else {
set ns [nsjoin [namespace current] objects [info cmdcount]]
set name $ns
}
set object [upcall 1 object $name]
$object .nscall namespace eval doc {}
set adminns [$object .adminns]
set [nsjoin $adminns up] {}
.state::.new $object
$object .extend $shelfns
$object .setup
return $object
}
namespace eval .state {}
alias [nsjoin .state nsjoin] nsjoin
namespace eval .state {
proc dodict {_ op args} {
set ensemble [nsjoin [$_ .namespace] .state .state]
set map [namespace ensemble configure $ensemble -map]
dict update map .state state {
set info [lindex $state 1]
dict $op info {*}$args
set state [lreplace $state[set state {}] 1 1 $info]
}
namespace ensemble configure $ensemble -map $map
get $_ {*}[lrange $args 0 end-1]
}
proc .new _ {
set ns [namespace eval [nsjoin [$_ .namespace] .state] {
namespace current
}]
set routine [nsjoin $ns .state]
namespace ensemble create -command $routine \
-parameters _\
-map {lappend .lappend lreplace .lreplace set .set .state {dummy1 {}}} \
-subcommands {
exists
get
lappend
lreplace
set
}
$_ .extend $ns
}
proc .set {_ args} {
dodict $_ set {*}$args
}
proc exists {_ args} {
set ensemble [nsjoin [$_ .namespace] .state .state]
set map [namespace ensemble configure $ensemble -map]
set state [dict get $map .state]
set info [lindex $state 1]
return [dict exists $info {*}$args]
}
proc get {_ args} {
set ensemble [nsjoin [$_ .namespace] .state .state]
set map [namespace ensemble configure $ensemble -map]
set state [dict get $map .state]
set info [lindex $state 1]
if {[llength $args]} {
return [dict get $info {*}$args]
} else {
return $info
}
}
proc .lappend {_ path args} {
set ensemble [nsjoin [$_ .namespace] .state .state]
set map [namespace ensemble configure $ensemble -map]
dict update map .state state {
set info [lindex $state 1]
set list [dict get $info {*}$path]
if {[llength $args]} {
::lappend list {*}$args
dict set info {*}$path $list
set state [lreplace $state[set state {}] 1 1 $info]
}
}
namespace ensemble configure $namespace -map $map
return $list
}
proc .lreplace {_ path args} {
set ensemble [nsjoin [$_ .namespace] .state .state]
set map [namespace ensemble configure $ensemble -map]
dict update map .state state {
set info [lindex $state 1]
set list [dict get $info {*}$path]
if {[llength $args]} {
set list [::lreplace list[set list {}] {*}$args]
dict set info {*}$path $list
set state [lreplace $state[set state {}] 1 1 $info]
}
}
namespace ensemble configure $namespace -map $map
return $list
}
proc replace {_ value} {
set ensemble [nsjoin [$_ .namespace] .state]
set map [namespace ensemble configure $ensemble -map]
dict update map .state state {
set state [lreplace $state[set state {}] 1 1 $value]
}
namespace ensemble configure $ensemble -map $map
return $value
}
proc unset {_ args} {
dodict $_ unset {*}$args
}
}
#proc .vars {_ args} {
# set vars {}
# set ns [$_ .namespace]
# 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 $ns {*}$vars]
# }
# return
#}
namespace eval objects {}
variable shelfns [nsjoin [namespace parent] shelf]
namespace export *