[Xotcl] Help with singleton design pattern

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