#! /usr/local/bin/tclsh8.3
namespace eval ::cobj {}
namespace eval ::cobj::obj {}
proc ::cobj::obj {type args} {
variable _cobj_methods
set methods {}
set alength [llength $args]
if {$alength >= 2} {
for {set i 0} {$i < [expr {$alength - 1}]} {incr i} {
append methods "\n$_cobj_methods([lindex $args $i])"
}
append methods "\n[lindex $args [expr {$alength - 1}]]" ;#(1)
}
if {$alength == 1} {
set methods [lindex $args 0]
}
set _cobj_methods($type) $methods
namespace eval ::$type {}
proc ::$type {args} "
#puts \$args
switch -- \$args {
$methods
}
"
namespace export obj
}To use it do something like this:
cobj::obj toys::ball {
fun {return "This is fun!"}
testing {return "This is only a test!"}
}
puts [toys::ball fun]
puts [toys::ball testing]
#toys::bat inherits toys::ball
cobj::obj toys::bat toys::ball {
homerun {return "You won the game!"}
}
puts [toys::bat homerun]
puts [toys::bat fun]RS: Really nice. If you discount blank lines and comments, the whole system fits in 24 lines of code. The point marked ;#(1) above seems to be equally expressed with lindex $argv end, isn't it?What seems to be missing is arguments for methods. Maybe by changing the object proc template like this (The name type in the above source would be clearer if called instance, I suppose):
proc ::$instance {{method {}} args} {
switch -- \$method {
$methods
}Another note: in the for loop, expr is redundant. The second arg to for will be evaluated by expr anyway, so make that for {set i 0} {$i < ($alength - 1)} {incr i} {GPS: Thanks. I wish that I had known about expr being redundant in a for loop.MS: a system with similar properties is
namespace eval ::cobj2 {
proc obj2 {type args} {
set type [uplevel namespace current]::$type
if {[llength $args] >= 2} {
foreach parent [lrange $args 0 end-1] {
set imports [uplevel namespace parent $parent]::[namespace tail $parent]::*
append toEval "catch {namespace import $imports}\n"
}
}
foreach {procName argLst body} [lindex $args end] {
append toEval "proc $procName \{$argLst\} \{$body\}\n"
}
namespace eval ::$type [append toEval {namespace export *}]
}
namespace export obj2
}Remark: there is a slight change in syntax: you now calltoys::ball::funinstead of
toys::ball funProperties:
- Method inheritance, just like cobj - remark that only methods defined at creation time are inherited (wouldn't it be nice to have a dynamic way to import commands from other namespaces? "namespace inherit" or similar ...)
- Updatable methods: if you change a method, it is automatically changed in all classes/objects that inherit from it - cobj does not have this property.
- Objects are created in the "correct" namespaces, i.e., in the scope of the caller.
cobj2::obj2 toys::ball {
fun {} {return "This is fun"}
testing {} {return "This is only a test!"}
}
puts [toys::ball::fun]
puts [toys::ball::testing]
#toys::bat inherits toys::ball
cobj2::obj2 toys::bat toys::ball {
homerun {} {return "You won the game!"}
}
puts [toys::bat::homerun]
puts [toys::bat::fun]
cobj2::obj2 toys::new ::toys::bat {
scream {} {return "I'm screaming!"}
}
puts [toys::new::scream]
puts [toys::new::fun]
puts [toys::new::homerun]GPS: Here is a complete rewrite of cobj:
#! /usr/local/bin/tclsh8.3
namespace eval ::cobj3::obj {}
proc ::cobj3::obj {type inherits args} {
namespace eval ::$type {}
proc ::$type {args} {
set com [lindex $args 0]
set args [lindex $args 1]
switch $com {
children {
return [namespace children [lindex [info level 0] 0]]
}
destroy {
foreach m $args {
catch {namespace delete "[lindex [info level 0] 0]::$m"}
catch {[rename "[lindex [info level 0] 0]::$m" ""]}
}
}
help {
return "Valid messages are destroy, and children."
}
}
}
set methods [lindex $args 0]
set methlen [llength $methods]
for {set i 0} {$i < $methlen} {incr i 3} {
set subproc ":: $type :: [lindex $methods 0]"
regsub -all { } $subproc "" subproc
namespace eval $subproc {}
proc $subproc "[lindex $methods 1]" "
[lindex $methods 2]
"
set methods [lrange $methods 3 end]
}
if {[llength $inherits] != 0} {
foreach im $inherits {
set ns ":: $type :: [namespace tail ::$im]"
regsub -all { } $ns {} ns
interp alias {} $ns {} $im
set nschildren [namespace children ::$im]
#puts $nschildren
foreach child $nschildren {
set nschild ":: $type :: [namespace tail $child]"
regsub -all { } $nschild {} nschild
interp alias {} $nschild {} $child
}
}
}
namespace export obj
}Example usage:
cobj3::obj toys::kazoo {} {
hello {} {return kazoo}
}
cobj3::obj toys::frisbee {toys::kazoo} {
throw {rate} {return "throw $rate"}
catch {} {return "catch"}
sweat {amount} {return $amount}
}
puts [::toys::frisbee::throw fast]
puts [::toys::frisbee::catch]
puts [::toys::frisbee::sweat "I'm sweating like a pig! Well, not really, just for effect."]
puts [::toys::kazoo::hello]
#The toys::kazoo::hello proc has been inherited upon creation of toys::frisbee.
puts [::toys::frisbee::hello]
#puts [info body ::toys::frisbee::sweat]
::toys::frisbee destroy hello
#This shouldn't work if the above worked:
#puts [::toys::frisbee::hello]
puts [::toys::frisbee children]
#puts [::toys::frisbee help]George Peter Staplin - Well, I've been at it again. I wrote a new version that works like Itcl's class command, has instance variables, and supports class level inheritance. It's interesting to me looking back at how this has progressed.
#! /usr/local/bin/tclsh8.3
namespace eval ::cobj {
variable _cobj_methods
variable _cobj_vars
proc obj {type vars methods} {
variable _cobj_methods
variable _cobj_vars
set _cobj_methods($type) $methods
set _cobj_vars($type) $vars
set _variables {}
foreach v $vars {
append _variables "variable $v;"
}
namespace eval ::$type {}
proc ::$type {object} "
namespace eval ::\$object {
$_variables
}
proc ::\$object {args} {
$_variables
set self \[namespace current\]
while {1} {
set flag \[lindex \$args 0\]
set value \[lindex \$args 1\]
switch -- \$flag {
$methods
}
set args \[lrange \$args 2 end\]
if {\[llength \$args\] == 0} {
break
}
}
}
"
}
proc inherit {type type2} {
variable _cobj_methods
variable _cobj_vars
set new_methods $_cobj_methods($type2)
set existing_methods $_cobj_methods($type)
set methods "$new_methods \n $existing_methods"
set new_vars $_cobj_vars($type2)
set existing_vars $_cobj_vars($type)
set vars "$new_vars $existing_vars"
set _variables {}
foreach v $vars {
append _variables "variable $v;"
}
namespace eval ::$type {}
proc ::$type {object} "
namespace eval ::\$object {
$_variables
}
proc ::\$object {args} {
$_variables
set self \[namespace current\]
while {1} {
set flag \[lindex \$args 0\]
set value \[lindex \$args 1\]
switch -- \$flag {
$methods
}
set args \[lrange \$args 2 end\]
if {\[llength \$args\] == 0} {
break
}
}
}
"
}
namespace export obj
namespace export inherit
}
cobj::obj toys::ball {brand intensity} {
brand: {set brand $value}
kick: {set intensity $value}
what {return "kick $brand $intensity"}
}
toys::ball fun
fun brand: ballo kick: hard
puts [fun what]
toys::ball moderate::fun
moderate::fun brand: {smallo ballo}
moderate::fun kick: softly
puts [moderate::fun what]
cobj::obj toys::football {color} {
color {set color $value}
}
cobj::inherit toys::football toys::ball
toys::football tfootb
tfootb brand: {shino ballo}
puts [tfootb what]
tfootb color: red
puts [tfootb what_color]George Peter Staplin - I decided to make a simpler object system that just supports instance variables and messages.
proc cobj {cname vars messages} {
regsub -all {(\$)} $messages {\\\1} messages
set strSelf "set self \\\[lindex \\\[info level 0\\\] 0\\\]"
append messages " default {return -code error {unknown message}}"
proc $cname {iname} "
foreach v {$vars} {
append varList \"variable ::\${iname}::\$v; \"
}
namespace eval \$iname {}
proc \$iname {mesg args} \"
\$varList
$strSelf
switch -- \\\$mesg {
$messages
}
\"
"
}
#Test code:
cobj cWorkers {age position} {setAge {set age [lindex $args 0]} age {return $age} setPosition {set position [lindex $args 0]} position {return $position}}
cWorkers joe
joe setAge 31
joe setPosition chemist
cWorkers bob
bob setAge 22
bob setPosition drifter
puts "Bob is [bob age] years old and works as a [bob position]. Joe is [joe age] years old and works as a [joe position]."Sat Sep 29 22:15:04 MDT 2001I've decided that the code was getting too messy. So, I've tried to keep this version really simple. It supports instance variables, methods, and that's about it. I've decided that inheritance isn't very useful for my game, and I don't like the ways that I've implemented it in the past. Anyway, enjoy -GPS
#!/usr/local/bin/tclsh8.3
#cobj10
proc cobj {obj vars methods} {
set init_vars "\n"
set init_procs "\n"
foreach var $vars {
append init_vars "variable $var;\n"
}
for {set i 0} {$i < [llength $methods]} {incr i} {
set meth [lindex $methods $i]
incr i
append init_procs "proc $meth args {$init_vars\nset arg \[lindex \$args 0\]\n[lindex $methods $i]\n}\n"
}
proc $obj newObj "namespace eval ::\$newObj {$init_vars $init_procs}"
}
cobj person {age height weight} {
setAge {set age $arg}
setHeight {set height $arg}
setWeight {set weight $arg}
getInfo {return [list $age $height $weight]}
}
proc main {} {
person George
George::setAge 20
George::setHeight "6' 2\""
George::setWeight 302
person Thomas
Thomas::setAge 21
Thomas::setHeight "5' 9\""
Thomas::setWeight 170
puts [George::getInfo]
puts [Thomas::getInfo]
}
main