[Xotcl] Help with singleton design pattern

[Michael A. Cleverly]

As I'm starting to learn XOTcl, I decided to try and implement a singleton 
design pattern as an educational exercise.  

Here is what I've come up with see below). I'd appreciate help
understanding why my filterguard registration does not work as I'd expect
it to.  (I'd also appreciate feedback on style, or if my comments 
indicate a misunderstanding of what the code actually does, etc.)

Thanks again for all the help.

Michael

#!/bin/sh
# -*- tcl -*- \
exec tclsh $0 ${1+"$@"}

package require Tcl 8.4
package require XOTcl 1.0
namespace import -force xotcl::*

Class Singleton
Singleton instproc singletonCreateFilter args {
    # Despite adding a filterguard (see below) for some reason
    # the "C foo" below would fail because a singleton instance of 
    # class C exists ("::singletonCreateFilter" ?!??) if we don't also
    # check to make sure [self calledproc] == create here.
    #
    # I don't understand why ...
    if {[self calledproc] != "create"} {
        return [next]
    }

    [self class] instvar singletons
    set obj   [lindex $args 0]
    set class [self]

    # if the object name isn't a fully qualified name make it so
    if {![string match ::* $obj]} {
        set obj [namespace parent]::$obj
    }

    # don't throw an error if we're recreating the same object
    if {[info exists singletons($class)] && 
        [string equal $singletons($class) $obj] == 0} {
        error "Can't instantiate \"$obj\" of singleton class\
            \"$class\"; \"$singletons($class)\" already instantiated"
    }

    set singletons($class) $obj
    next
}

Singleton instproc singletonDestroyFilter args {
    [self class] instvar singletons

    set class [my info class] ;# equiv of [self] info class

    # if other objects existed before Singleton registerClass
    # was called, and those objects are deleted, we don't care
    if {$singletons($class) == [self]} {
        unset singletons($class)
    }

    next
}

Singleton proc registerClass class {
    my instvar singletons
    my instvar registered

    # make sure we're dealing with a class
    if {[my isclass $class] == 0} {
        error "\"$class\" isn't a class;\
            hence, can't make it a singleton class."

    }

    # Don't "double register" a class 
    if {[info exists registered] &&
        [lsearch -exact $registered $class] != -1} then return


    # We need to mixin to the object to filter the obj creation
    # We need to mixin to the class to filter obj destruction
    $class mixinappend [self]
    $class instmixinappend [self]

    $class filterappend singletonCreateFilter 
    $class filterguard singletonCreateFilter \
            {[self calledproc] == "create"}

    $class instfilterappend singletonDestroyFilter 
    $class instfilterguard singletonDestroyFilter \
        {[self calledproc] == "destroy"}

    lappend registered $class
}

Singleton proc create args {
    # doesn't make sense to instantiate objects of the singleton class
    error "Can't instantiate an object of \"[self]\";\
        use \"[self] registerClass className\" instead."
}

Class C

# just a quick sanity check to make sure our filter doesn't 
# keep us from defining instance procs or using them
C instproc datetime {} {
    clock format [clock seconds]
}

Singleton registerClass C

# don't expect/don't want [C foo] to fail
C foo
puts [foo datetime]

# We expect/want [C bar] to fail
C bar