Koen Van Damme -- Oblets are yet another very simple object system for Tcl. Object data is stored in global arrays. Attributes and methods can be inherited from base classes (multiple inheritance is supported). If present, a method called 'ctor' is invoked after object creation, and 'dtor' before object destruction.
Due to the proliferation of object systems for Tcl, this one is mainly for educational purposes, for people who want to see the guts of simple array-based objects. Many other excellent (and simpler) examples can be found on this wiki, such as Gadgets, LOST, Toot, etc. You can also check the Category Object Orientation for a long list.
Here is an example of oblets in use:
oblet_class Animal {
set age 0
proc birthday {} {
# Note that you have to pull the 'age' member into a local variable called 'age',
# alter it, and then set the oblet's member back to the new value.
# The oblet mechanism does not allow you to alter members directly.
$this members age
incr age
$this set -age $age
puts "Abstract animal ages by 1 year. I am now $age years old."
return $age
}
proc sound {times} {
puts "Abstract animal making $times sounds."
}
}
oblet_class Dog : Animal {
set tail 55
proc sound {times} {
for {set i 0} {$i < $times} {incr i} {
puts "WOOF"
}
}
}
# Create a dog called Fido.
Dog Fido -age 5 -tail 2
# Call some methods on Fido and print their results.
puts "Birthday: [Fido birthday]"
puts "Birthday: [Fido birthday]"
Fido sound 5
# Clean up.
oblet_delete FidoFor another example, have a look at GenTemplate which is a simple oblet class for text processing.
And here is the code itself:
proc oblet_class {cls_nam args} {
if { [info commands $cls_nam] != "" } {
panic "Cannot create oblet class; '$cls_nam' already exists."
}
#######
# Class members.
# Fill an array with default values for member variables.
upvar #0 oblet_v_$cls_nam cls_arr
set cls_arr(name) $cls_nam
# Inherit attributes and methods from base classes.
if { [lindex $args 0] == ":" } {
foreach base [lrange $args 1 [expr [llength $args] - 1]] {
# Attributes are fetched from the base class array,
# so you also inherit new attributes injected after the base class was declared.
upvar #0 oblet_v_$base base_arr
foreach a [array names base_arr "-*"] {
# Only copy attrs with a leading dash, to avoid copying special attrs like 'class'.
set cls_arr($a) $base_arr($a)
}
# Methods are fetched using 'info procs',
# so you also inherit new methods defined after the base class was declared.
# You can always override the default body we install here.
foreach m [info procs $base:*] {
regsub {^[^:]+:} $m "" m2
proc ${cls_nam}:${m2} {args} "return \[uplevel ${m} \$args\]"
}
}
}
# Define new local member variables using 'set',
# and new member functions using 'proc', possibly overriding base class functions.
rename proc oblet_tmp_proc
rename set oblet_tmp_set
oblet_tmp_proc set {var_nam val} {
upvar cls_arr cls_arr
oblet_tmp_set cls_arr(-$var_nam) $val
}
oblet_tmp_proc proc {proc_nam arglist body} {
upvar cls_nam cls_nam
oblet_tmp_proc ${cls_nam}:${proc_nam} [linsert $arglist 0 this] $body
}
# Evaluate the class body which contains 'proc' and 'set' commands.
eval [lindex $args end]
rename proc ""
rename set ""
rename oblet_tmp_proc proc
rename oblet_tmp_set set
#######
# Create the instance array and instance command.
# To avoid backslash hell, we use the '@' trick.
set ctor_template {
if { [info commands $obj_nam] != "" } {
panic "Cannot create oblet; '$obj_nam' already exists."
}
upvar #0 oblet_v_@cls_nam@ cls_arr
upvar #0 oblet_v_$obj_nam obj_arr
set obj_arr(class) @cls_nam@
# Copy members from class.
foreach a [array names cls_arr "-*"] {
set obj_arr($a) $cls_arr($a)
}
# Override defaults from ctor args.
foreach {a v} $args {
set obj_arr($a) $v
}
###
# Instance command
set obj_template {
if { [info procs @obj_nam@:$cmd] != "" } {
# Instance-specific method.
return [uplevel @obj_nam@:$cmd @obj_nam@ $args]
} else {
# Class-wide method.
upvar #0 oblet_v_@obj_nam@ obj_arr
return [uplevel $obj_arr(class):$cmd @obj_nam@ $args]
}
}
regsub -all {@obj_nam@} $obj_template "$obj_nam" obj_template
proc ${obj_nam} {cmd args} $obj_template
# Call constructor if it exists.
if { [info procs "@cls_nam@:ctor"] != "" } {
uplevel "@cls_nam@:ctor" $obj_nam
}
}
regsub -all {@cls_nam@} $ctor_template "$cls_nam" ctor_template
proc ${cls_nam} {obj_nam args} $ctor_template
#######
# Some standard methods.
# Give new values to one or more attrs.
proc ${cls_nam}:set {this args} {
upvar #0 oblet_v_$this obj_arr
# Note that class-static attrs are not supported.
# All attrs go into the obj-specific array.
foreach {a v} $args {
set obj_arr($a) $v
}
}
# Get the value of an attr.
proc ${cls_nam}:get {this a} {
upvar #0 oblet_v_$this obj_arr
return $obj_arr($a)
}
# Get a number of attr values into local variables with the same name.
proc ${cls_nam}:members {this args} {
upvar #0 oblet_v_$this obj_arr
foreach arg $args {
upvar $arg my_arg
# We have to go only 1 level up: the instance command does 'uplevel'!
set my_arg $obj_arr(-$arg)
}
}
}
# Delete one or more oblets.
# If they don't exist, ignore (no error).
proc oblet_delete {args} {
foreach obj_nam $args {
upvar #0 oblet_v_$obj_nam obj_arr
if { [info exists obj_arr] } {
set cls_nam $obj_arr(class)
# Call the destructor before deleting any of the members.
if { [info procs "${obj_nam}:dtor"] != "" } {
# Instance-specific destructor.
uplevel "${obj_nam}:dtor" ${obj_nam}
} elseif { [info procs "${cls_nam}:dtor"] != "" } {
# Class destructor.
uplevel "${cls_nam}:dtor" ${obj_nam}
}
unset obj_arr
# Delete the attributes array.
foreach p [info procs "${obj_nam}:"] {
# Delete all instance-specific methods.
rename $p {}
}
rename $obj_nam {}
# Delete the instance command itself.
}
}
}