[Xotcl] Help with singleton design pattern
Created by hypermail2xowiki importer, last modified by Stefan Sobernig 02 Jan 2017, at 11:15 PM
From: Michael A. Cleverly <michael_at_cleverly.com>
Date: Fri, 18 Apr 2003 23:40:46 -0600 (MDT)
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+"$_at_"}
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
Date: Fri, 18 Apr 2003 23:40:46 -0600 (MDT)
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+"$_at_"}
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
