With IncrTcl and TclOO, objects must be destroyed manually. If possible, I'd like objects to be cleaned up automatically, for example when a variable holding an object reference goes out of scope at the end of a procedure, or when a variable holding an object reference is set to say "", etc. I also want strong/weak references, to simplify management of objects in certain circumstances.
I've been experimenting with a very simple OO system (owc - objects without classes) to see if I could achieve this, and what I've done so far looks like it works.
Below are three examples, and at the bottom of the page are my sources - a Tcl script that implements owc, and some C code that provides support for strong/weak references.
For more on strong/weak references, see Garbage Collection and Strong/Weak References.
This example is a variation on Playing with TclOO.
proc ::account::account {{ownerName undisclosed}} {
set this [ocreate {deposit withdraw transfer} cleanup {
variables total overdrawLimit owner
}]
oset $this total 0 overdrawLimit 10 owner $ownerName
return $this
}
proc ::account::deposit {amount} {
ocontext total
set total [expr {$total + $amount}]
}
proc ::account::withdraw {amount} {
ocontext total overdrawLimit owner
if {($amount - $total) > $overdrawLimit} {
error "Can't overdraw - total: $total, limit: $overdrawLimit"
}
set total [expr {$total - $amount}]
}
proc ::account::transfer {amount targetAccount} {
ocontext total
withdraw $amount
ocmd $targetAccount deposit $amount
return $total
}
proc ::account::cleanup {} {
ocontext total
if {$total} {
puts "remaining $total will be given to charity"
}
}
# ------------------------------------------------------------------------------
set a [::account::account "John Doe"]
ocmd $a deposit 200
ocmd $a withdraw 15
puts "a = [oget $a total]"
set b [::account::account]
ocmd $a transfer 65 $b
puts "a = [oget $a total], b = [oget $b total]"
puts "Objects: [ocurrent]"
set a ""
puts "Objects: [ocurrent]"
set b ""
puts "Objects: [ocurrent]"The ocurrent command returns counts of objects by namespace. The output of this script is:
a = 185 a = 120, b = 65 Objects: ::account 2 remaining 120 will be given to charity Objects: ::account 1 remaining 65 will be given to charity Objects:
As can be seen, setting variables that hold object references to "" result in the objects being cleaned.
An object will only be cleaned up once all strong references to that object have been lost. In example 1, each object reference was held by only one variable, so only one variable needed to lose its reference for each object to be cleaned. This second example shows a good example of circular references which can stop objects being cleaned. Example 3 shows how this problem is fixed using weak references. These two examples are based on examples here .
proc person {name} {
set this [ocreate {} person_clean {
variables name apartment
}]
oimport $this name
return $this
}
proc person_clean {} {
ocontext name
puts "$name is being deinitialized"
}
proc apartment {number} {
set this [ocreate {} apartment_clean {
variables number tenant
}]
oimport $this number
return $this
}
proc apartment_clean {} {
ocontext number
puts "$number is being deinitialized"
}
# ------------------------------------------------------------------------------
set john [person "John Tcler"]
set number42 [apartment 42]
oset $john apartment $number42
oset $number42 tenant $john
puts "Objects: [ocurrent]"
set john ""
set number42 ""
puts "Objects: [ocurrent]"The output of this script is:
Objects: :: 2 Objects: :: 2
Here, although the john and number42 variables are set to "", the second puts is still showing two objects. This is because the person and apartment objects are referring to each other.
For example 2 to work, the bottom part of that script needs to be replaced with:
set john [person "John Tcler"] set number42 [apartment 42] oset $john apartment [weak $number42] oset $number42 tenant [weak $john] puts "Objects: [ocurrent]" set john "" set number42 "" puts "Objects: [ocurrent]"
This time each object gets a weak reference through the weak command. So they still have a reference to each other's object enabling them to access state, but weak references do not affect object lifetime.
The output of this example is:
Objects: :: 2 John Tcler is being deinitialized 42 is being deinitialized Objects:
This is the script that provides the owc functionality:
#
# owc.tcl
#
# Objects without classes.
#
namespace eval ::owc {
variable idCount 0
variable objCounts [dict create]
namespace export ocreate ocontext oget oset ocmd oassign oimport oexists \
ocurrent weak
}
# create object context with object command and optional clean command,
# returning object namespace
proc ::owc::ocreate {args} {
variable idCount
variable objCounts
clean
set cleanup ""
if {[llength $args] == 2} {
lassign $args cmds codeBlock
} elseif {[llength $args] == 3} {
lassign $args cmds cleanup codeBlock
} else {
error "ocreate args should be: commands ?clean-up? code-block"
}
set ns [uplevel {namespace current}]
if {$ns eq "::"} {
set objNs ::owc_obj#$idCount
set cmdPrefix ::
} else {
set objNs ${ns}::owc_obj#$idCount
set cmdPrefix ${ns}::
}
incr idCount
dict incr objCounts $ns
namespace eval $objNs $codeBlock
set body [format {
set this %s
if {$cmd ni {%s}} {
error "unknown command '$cmd'"
}
%s$cmd {*}$args
} $objNs $cmds $cmdPrefix]
proc ${objNs}::owc_obj_cmd {cmd args} $body
if {$cleanup ne ""} {
set body [format {
set this %s
%s::%s %s
} $objNs $ns [lindex $cleanup 0] [lrange $cleanup 1 end]]
proc ${objNs}::owc_obj_clean_cmd {} $body
}
return [swr::strong $objNs]
}
# procedure context command
proc ::owc::ocontext {args} {
clean
uplevel upvar this this
if {[llength $args] != 0} {
foreach arg $args {
lappend vars $arg $arg
}
uplevel [format {namespace upvar $this %s} $vars]
}
}
# returns values from object
proc ::owc::oget {ref args} {
if {![oexists $ref]} {
error "object '$ref' doesn't exist"
}
set rv [list]
foreach arg $args {
lappend rv [set ${ref}::$arg]
}
return $rv
}
# sets object variables
proc ::owc::oset {ref args} {
if {![oexists $ref]} {
error "object '$ref' doesn't exist"
}
foreach {var val} $args {
set ${ref}::$var $val
}
clean
}
# runs object command
proc ::owc::ocmd {ref cmd args} {
if {![oexists $ref]} {
error "object '$ref' doesn't exist"
}
uplevel [list ${ref}::owc_obj_cmd $cmd {*}$args]
clean
}
# sets variables from object variables of the same name
proc ::owc::oassign {ref args} {
if {![oexists $ref]} {
error "object '$ref' doesn't exist"
}
foreach var $args {
set val [set ${ref}::$var]
uplevel [list set $var $val]
}
}
# sets object variables from variables of the same name
proc ::owc::oimport {ref args} {
if {![oexists $ref]} {
error "object '$ref' doesn't exist"
}
foreach var $args {
set val [uplevel [list set $var]]
set ${ref}::$var $val
}
clean
}
# returns true if ref object exists
proc ::owc::oexists {ref} {
clean
return [namespace exists [weak $ref]]
}
# returns weak version of ref
proc ::owc::weak {ref} {
clean
set wr [swr::weak $ref]
clean
return $wr
}
# cleans pending objects and returns current object counts by namespace
proc ::owc::ocurrent {} {
variable objCounts
clean
return $objCounts
}
# clean pending objects
proc ::owc::clean {} {
variable objCounts
while {1} {
set pending [swr::pending]
if {[llength $pending] == 0} {
break
}
foreach ns $pending {
if {[llength [info procs ${ns}::owc_obj_clean_cmd]] != 0} {
${ns}::owc_obj_clean_cmd
}
set nsParent [namespace parent $ns]
namespace delete $ns
dict incr objCounts $nsParent -1
if {[dict get $objCounts $nsParent] == 0} {
dict unset objCounts $nsParent
}
}
}
}And this is the code that provides strong/weak references.
//
// swr.c
//
// Strong/weak references for owc.
//
#include "tcl.h"
static Tcl_HashTable pendingTable;
static Tcl_ObjType swrType;
// frees strong reference, saving object namespace to pending table
static void swrFreeIntRepProc(Tcl_Obj *ref) {
Tcl_HashEntry *e = Tcl_FindHashEntry(&pendingTable,
ref->internalRep.twoPtrValue.ptr1);
Tcl_ListObjAppendElement(NULL, Tcl_GetHashValue(e),
(Tcl_Obj *) ref->internalRep.twoPtrValue.ptr2);
Tcl_DecrRefCount((Tcl_Obj *) ref->internalRep.twoPtrValue.ptr2);
ref->internalRep.twoPtrValue.ptr1 = NULL;
ref->internalRep.twoPtrValue.ptr2 = NULL;
}
// don't allow strong references to be duplicated
static void swrDupIntRepProc(Tcl_Obj *src, Tcl_Obj *dup) {
dup->internalRep.twoPtrValue.ptr1 = NULL;
dup->internalRep.twoPtrValue.ptr2 = NULL;
}
// returns a strong reference for a object
static int strong(ClientData ClientData, Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]) {
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "object-reference");
return TCL_ERROR;
}
Tcl_Obj *ref = objv[1];
if (ref->bytes == NULL || ref->typePtr != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"error creating reference", -1));
return TCL_ERROR;
}
Tcl_Obj *rv = Tcl_DuplicateObj(ref);
rv->typePtr = &swrType;
rv->internalRep.twoPtrValue.ptr1 = interp;
rv->internalRep.twoPtrValue.ptr2 = Tcl_NewStringObj(ref->bytes, -1);
Tcl_IncrRefCount((Tcl_Obj *) rv->internalRep.twoPtrValue.ptr2);
Tcl_SetObjResult(interp, rv);
return TCL_OK;
}
// returns duplicate reference, with stong references converted to weak
static int weak(ClientData ClientData, Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]) {
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "object-reference");
return TCL_ERROR;
}
Tcl_Obj *rv = Tcl_DuplicateObj(objv[1]);
Tcl_SetObjResult(interp, rv);
return TCL_OK;
}
// returns pending list for interp and starts a new one
static int pending(ClientData ClientData, Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]) {
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_HashEntry *e = Tcl_FindHashEntry(&pendingTable, interp);
Tcl_Obj *pendingList = Tcl_GetHashValue(e);
Tcl_SetObjResult(interp, pendingList);
Tcl_DecrRefCount(pendingList);
pendingList = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(pendingList);
Tcl_SetHashValue(e, pendingList);
return TCL_OK;
}
// extension init function
int Swr_Init(Tcl_Interp *interp) {
if (Tcl_InitStubs(interp, "8.6", 0) == NULL)
return TCL_ERROR;
int rv;
Tcl_InitHashTable(&pendingTable, TCL_ONE_WORD_KEYS);
Tcl_HashEntry *e = Tcl_CreateHashEntry(&pendingTable, interp, &rv);
Tcl_Obj *pendingList = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(pendingList);
Tcl_SetHashValue(e, pendingList);
swrType = (Tcl_ObjType) {"swr", swrFreeIntRepProc, swrDupIntRepProc, NULL,
NULL};
Tcl_CreateObjCommand(interp, "owc::swr::strong", strong, (ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "owc::swr::weak", weak, (ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "owc::swr::pending", pending,
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}APN Doesn't the implementation of swrDupIntRepProc break Tcl semantics as
set a $b
no longer works for these Tcl_Objs.
pdt 'set a $b' will work as expected.
As Tcl uses copy-on-write for Tcl_Objs, if variable b contains a strong reference, after 'set a $b', variable a now has the same Tcl_Obj for a value as variable b. You could now do 'set b ""', and the object wouldn't be cleaned up, because there is still a reference in variable a due to 'set a $b'. If a and b were the only two variables to hold the strong reference, 'set a ""' would then cause the object to be cleaned.
Note that the swr code doesn't do any reference counting itself, instead it just makes use of the reference counting in the Tcl_Obj to determine when an object is finished with.