my oh my is a response to a question by jbr in Ask, and it shall be given # 11
Specifically I'd like to create a "method" declaration adjective, similar to "public" and "private" from JBR's tcloo.tcl. The adjective I'm thinking of is "linked" that will perform the function of the "procs" procedure in tcloo.tcl, and is called "link" in some other code (forgot where (PYK: probably in ooutil)). It links procs in an object's namespace to the class methods such that they can be called as commands.
The current implementations require the set of linked methods to be mentioned twice, once in their method declarations and once in the link/procs call in the class constructor. I'd like something like:
linked method name { args } { body }The linked method would add the method name to the classes linked slot and then at constructor time (maybe automatically) the links would be made using the "linked" slot list. Is it possible to override or filter the class constructor to handle this automatic at constructor time part? Without subclassing??
Ideas??
Thanks - JBR
PYK 2014-06-11: I put together a mixin class that tries to do what you've described. The purpose of string map here is to find a nice private location for the bookkeeping that is done to track the my methods. It's a little ugly, but hey, it works.
Using namespace unknown as the redirector was the only way I could find at the script level to get this job done.
Overloading the word my for this purpose leads to a heaping helping of my, but other ideas such as my! and nomy seemed even more forced. Better ideas are welcome, and anyone wants to improve this code, please just dig in!
PYK 2014-06-18: modified to work for subclasses as well
oo::class create my
{*}[string map [list {{{my}}} [list [
info object namespace [::oo::object new]]]] {apply {{} {
oo::define my constructor args {
namespace eval [self namespace] [string map [list {{{self}}} [self]] {
namespace unknown [list ::apply [list args {
lassign $args methodname
set callinfo [lindex [info object call {{self}} $methodname] 0]
lassign $callinfo mmeth mname mclass mtype
set clsns [info object namespace $mclass]
if {[info exists {{my}}::${clsns}::my]
&& [lindex $args 0] in [set {{my}}::${clsns}::my]} {
#the first tailcall replaces [unknown]
#the second replaces the original method call
tailcall tailcall my {*}$args
}
return -code error [list {invalid command name} $args]
}]]
}]
}
proc oo::define::my {method name margs body} {
uplevel [list method $name $margs $body]
set clsname [lindex [info level -1] 1]
set ns [uplevel [list info object namespace $clsname]]
namespace eval {{my}}::$ns {}
lappend {{my}}::${ns}::my $name
}
}}}]example:
oo::class create class1
oo::define class1 {
mixin -append my
my method method1 args {
return {hi from method1}
}
method method2 args {
method1 arg1 arg2
}
}
class1 create inst1
puts [inst1 method2]
oo::class create class2
oo::define class2 {
superclass class1
method method3 args {
method1
}
}
class2 create inst2
puts [inst2 method3]JBR: OK Building on PYK's answer above I'll propose this chain of mixin constructors:
oo::class create __linked {
constructor { args } {
# Don't know if the class has a constructor, catch a bad call
#
catch { next {*}$args }
# Create the links
#
foreach link [set [[info object class [self]] varname __linked]] {
proc [namespace current]::$link args [subst { tailcall my $link {*}\$args }]
}
}
}
oo::class create _linked {
variable __linked
constructor { args } {
set __linked {}
next {*}$args
oo::define [self] { mixin -append __linked }
}
}
oo::define oo::class {
mixin -append _linked
}
proc oo::define::linked { args } {
set class [lindex [info level -1] 1]
oo::define $class { self export varname }
if { [lindex $args 0] ne "method" } {
set method [lindex $args 2] ; # Skip over public / private
} else {
set method [lindex $args 1]
}
lappend [$class varname __linked] $method ; # remember linked methods
uplevel 1 $args
}
oo::class create foo {
linked method method2 { y } { puts $y }
method method1 { y } {
method2 $y
}
}
foo create inst
inst method1 1PYK 2014-06-18: Neither my original code (since improved) nor JBR's followup was robust enough to handle subclasses. Here's a further evolution of JBR's code that has that ability. JBR (or anyone else), feel free to jump in and directly modiify in this code to taste:
oo::class create __linked {
constructor args {
# Don't know if the class has a constructor, catch a bad call
catch {next {*}$args}
foreach methodname [info object methods [self] -all] {
#namespace eval [info object namespace my varname __linked
foreach call [info object call [self] $methodname] {
lassign $call mmeth mname mclass mtype
if {[info object isa object $mclass] &&
[info object isa class $mclass]} {
set varname [namespace eval [
info object namespace $mclass] my varname __linked]
if {[info exists $varname]} {
if {$methodname in [set $varname]} {
# Create the links
proc [namespace current]::$methodname args "
tailcall my [list $methodname] {*}\$args"
}
}
}
}
}
}
}
oo::class create _linked {
variable __linked
constructor args {
set __linked {}
next {*}$args
oo::define [self] {mixin -append __linked}
}
}
oo::define oo::class {
mixin -append _linked
}
proc oo::define::linked args {
set class [lindex [info level -1] 1]
# Skip over public / private
set method [lindex $args [lsearch -exact $args method]+1]
# remember linked methods
lappend [namespace eval [
info object namespace $class] my varname __linked] $method
uplevel 1 $args
}Example:
oo::class create class1
oo::define class1 {
linked method method2 y {return $y}
method method1 y {
method2 $y
}
}
class1 create inst1
puts [inst1 method1 1]
oo::class create class2 {
superclass class1
method method3 {} {
method2 3
}
}
class2 create inst2
puts [inst2 method3]