archie/tcl-dp/library/oo.tcl
2024-05-27 16:13:40 +02:00

201 lines
4.1 KiB
Tcl

# oo.tcl --
#
# Simple object oriented extension to Tcl, in the spirit of the Tk
# widget "objects". Like the GUI widgets in Tk, objects in
# this extension are procedures.
#
# Copyright 1992 Regents of the University of California
# Permission to use, copy, modify, and distribute this
# software and its documentation for any purpose and without
# fee is hereby granted, provided that this copyright
# notice appears in all copies. The University of California
# makes no representations about the suitability of this
# software for any purpose. It is provided "as is" without
# express or implied warranty.
#
################################################################
#
# dp_objectCreateProc
#
# creates a procedure <object> to represent an
# object of given <class>.
#
# methods on <class> should be defined using
# the form <class>.method1, ..., <class>.methodn.
#
proc dp_objectCreateProc {class object} {
set methodName "$class.\$name"
set body "";
append body {if [string length [info procs}
append body " $methodName";
append body {]] }
append body "{eval $methodName";
append body " $object ";
append body {$args};
append body "} else {"
append body "error "
append body {"}
append body "bad option "
append body {\"$name\"};
append body {"}
append body "}"
proc $object {name args} $body;
return $object;
}
################################################################
#
# dp_objectExists
#
proc dp_objectExists {object} {
if {[lsearch [info procs] $object] < 0} {
return 0;
}
return 1;
}
################################################################
#
# objectFree
#
proc dp_objectFree {object} {
global _objects;
if [dp_objectExists $object] {
foreach slot [dp_objectSlots $object] {
dp_objectSlotFree $object $slot;
}
rename $object "";
}
}
################################################################
#
# dp_objectSlot
# dp_objectSlotSet
# dp_objectSlotAppend
#
# dp_objectSlotFree
#
# object slot abstraction implemented
# using associative arrays.
#
#------------------------------------------------------------
set _objects(null) {};
#------------------------------------------------------------
proc dp_objectSlotFree {object slot} {
global _objects;
catch {unset _objects($object,$slot)};
}
proc dp_objectSlot {object slot} {
global _objects;
return [set _objects($object,$slot)];
}
proc dp_objectSlotSet {object slot value} {
global _objects;
return [set _objects($object,$slot) $value];
}
proc dp_objectSlotAppend {object slot value} {
global _objects;
return [lappend _objects($object,$slot) $value];
}
proc dp_objectSlots {object} {
global _objects;
set objectSlots {};
set slots [array names _objects];
set length [string length $object,];
while {1} {
set index [lsearch $slots $object,*];
if {$index < 0} {
return $objectSlots;
}
lappend objectSlots \
[string range [lindex $slots $index] $length end];
set slots [lrange $slots [incr index] end];
}
}
################################################################
#
# dp_objectConfigure - configure the slots of an object.
#
proc dp_objectConfigure {class object args} {
set argc [llength $args];
if {$argc < 1} {
# Zero args;
#
# Return a list of all the slotnames and values of the object;
#
set configs {};
foreach slot [dp_objectSlots $object] {
lappend configs [list -$slot {} [dp_objectSlot $object $slot]];
}
return $configs;
}
if {$argc == 1} {
# One arg (slotname);
#
# Return the slotname and value for the given slotname in the object;
#
set slot [string trimleft [lindex $args 0] \-];
if {[string length $slot] > 0} {
return [list -$slot {} [dp_objectSlot $object $slot]];
}
}
if {$argc > 1} {
# More than one args (slotname and value pairs);
#
# Recursively set the value of each of the given slots in the object
# to the given values;
#
set slot [string trimleft [lindex $args 0] \-];
eval $class.configure $object [lrange $args 2 end];
dp_objectSlotSet $object $slot [lindex $args 1];
return $object;
}
}