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].

***Example 1***

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.

***Example 2***

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 https://developer.apple.com/library/ios/documentation/Swift/Conceptual/Swift_Programming_Language/AutomaticReferenceCounting.html%|%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.

***Example 3***

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: 
======

***Sources***

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.

======c
//
// 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;
}
======

<<categories>>Enter Category Here