Posted to tcl by hypnotoad at Tue Jun 13 14:20:50 GMT 2017view raw
- ###
- # Facilities for standardizing object transformations during TclTest
- ###
- package require tcltest
- oo::class create ::tcltest::object {
- # An independant constructor that tcltest can control
- constructor args {
- my variable tcltest
- set tcltest(mixinmap) {}
- my tcltest_configure {*}$args
- }
- destructor {
- my variable tcltest
- if {[info exists tcltest(destructor)]} {
- eval $tcltest(destructor)
- } else {
- next
- }
- }
- method tcltest_destructor body {
- my variable tcltest
- set tcltest(destructor) $body
- }
- # A means of controlling the tcltest framework class
- # Note the method names are designed to minimize conflict
- # with existing classes
- method tcltest_configure args {
- foreach {key value} $args {
- switch [string trimleft $key -] {
- class {
- set tcltest(class) $value
- my tcltest_morph $value
- }
- eval {
- eval $value
- }
- destructor {
- my tcltest_destructor $value
- }
- }
- }
- }
- method tcltest_set args {
- my variable tcltest
- array set tcltest $args
- }
- method tcltest_morph classname {
- my variable tcltest
- if {[info commands ::tcltest::hybrid::$classname] eq {}} {
- oo::class create ::tcltest::hybrid::$classname [list superclass ::tcltest::object $classname]
- }
- set tcltest(class) $classname
- ::oo::objdefine [self] class ::tcltest::hybrid::$classname
- if {[info exists tcltest(mixinmap)]} {
- my Tcltest_mixin_apply $tcltest(mixinmap)
- }
- }
- # A method to allow tcltest to invoke code internally to
- # objects. Including access to private methods and variables
- method tcltest_eval script {
- eval $script
- }
- method Tcltest_mixin_apply {map} {
- set mixlist {}
- foreach {s c} $map {
- if {$c eq {}} continue
- lappend mixlist $c
- }
- ::oo::objdefine [self] mixin {*}$mixlist
- }
- # A formalized slot-based mechanism for managing mixins. Because we
- # break the space up into slots, individual aspects of behavior
- # can be added, removed, and combined with other mixins.
- # We use a dict internally for storage to allow the order in which mixins
- # were applied to be preserved. Not the difference between:
- # tcltest_mixin map FOO {}
- # and
- # tcltest_mixin unmap FOO
- #
- # A blank mapping will removed the effect, but preserve FOO's place in line
- # Unmap removes the concept completely.
- #
- method tcltest_mixin {command args} {
- my variable tcltest
- switch $command {
- dump {
- return $tcltest(mixinmap)
- }
- map {
- if {[llength $args]!=2} {
- error "Usage: [self method] map STUB CLASS"
- }
- lassign $args stub class
- # Placed here as a safety in case the before or after did not actually exist
- # And it's a handy place to make the call even if we didn't use before/after
- dict set tcltest(mixinmap) $stub $class
- # Build the list of classes to mixin, in the order proscribed by the dict
- my Tcltest_mixin_apply $tcltest(mixinmap)
- }
- replace {
- # Allows users to specify the order of mixins
- # Note we always include ::tcltest::object
- set tcltest(mixinmap) $args
- my Tcltest_mixin_apply $tcltest(mixinmap)
- }
- unmap {
- if {[llength $args]!=1} {
- error "Usage: mixinmap map STUB"
- }
- lassign $args stub
- if {[dict exists $tcltest(mixinmap) $stub]} {
- dict unset tcltest(mixinmap) $stub
- }
- my Tcltest_mixin_apply $tcltest(mixinmap)
- }
- default {
- error "Valid commands are: dump, map, replace, unmap"
- }
- }
- }
- }
- oo::objdefine ::tcltest::object {
- method hijack object {
- set classname [info object class $object]
- if {[info commands ::tcltest::hybrid::$classname] eq {}} {
- oo::class create ::tcltest::hybrid::$classname [list superclass ::tcltest::object $classname]
- }
- ::oo::objdefine $object class ::tcltest::hybrid::$classname
- $object tcltest_set class $classname
- }
- }
- ###
- # Example Usage
- ###
- oo::class create ::whatzit {
- constructor {foo bar baz} {
- my variable parameters
- set parameters(foo) $foo
- set parameters(bar) $bar
- set parameters(baz) $baz
- my Startup
- }
- destructor {
- set ::goodbye_world([self]) 1
- }
- method Startup {} {
- my variable parameters
- set parameters(combined) [lsort -stride 2 -dictionary [array get parameters]]
- }
- method get field {
- my variable parameters
- return $parameters($field)
- }
- method set {field value} {
- my variable parameters
- set parameters($field) $value
- set parameters(combined) [lsort -stride 2 -dictionary [array get parameters]]
- }
- }
- # Note we run the
- set OBJA [tcltest::object new -class whatzit -destructor {
- set ::goodbye_world([self]) 2
- set ::i_really_ran_destructor([self]) 1
- }]
- # We ran the tcltest::object contructor, not the constructor
- # for whatzit
- tcltest::test constructor-001 "Test that are using the tcltest::object constructor" -body {
- $OBJA get foo
- } -returnCodes 1 -result {can't read "parameters(foo)": no such variable}
- # Option 1: we re-create the effect of the constructor
- $OBJA tcltest_eval {
- lassign {A B C} foo bar baz
- my variable parameters
- array set parameters {
- foo A
- bar B
- baz C
- }
- my Startup
- }
- # Option 2: we use the normal constructor and hijack the object later
- set OBJB [::whatzit new A B C]
- ::tcltest::object hijack $OBJB
- # equivilent to: oo::objdefine $OBJB mixin ::tcltest::object
- tcltest::test constructor-002 "Test that we get the proper effect from our constructor" -body {
- $OBJA get combined
- } -result {bar B baz C foo A}
- tcltest::test constructor-003 "Test that we get the proper effect from our constructor" -body {
- $OBJA get combined
- } -result [$OBJB get combined]
- set testnum 0
- foreach obj [list $OBJA $OBJB] {
- foreach field {foo bar baz} {
- set testid parameters-[incr testnum]
- tcltest::test $testid "Test internal $field for $obj" \
- -body [list $obj tcltest_eval "my variable parameters \; set parameters($field)"] \
- -result [$obj get $field]
- }
- }
- tcltest::test mixin-001 "Test we have our classes mixed in properly" -body {
- info object mixins $OBJA
- } -result {}
- tcltest::test mixin-002 "Test we have our classes mixed in properly" -body {
- info object class $OBJA
- } -result {::tcltest::hybrid::whatzit}
- tcltest::test mixin-003 "Test we have our classes mixed in properly" -body {
- info object mixins $OBJB
- } -result {}
- tcltest::test mixin-004 "Test we have our classes mixed in properly" -body {
- info object class $OBJB
- } -result {::tcltest::hybrid::whatzit}
- # Test destructor
- tcltest::test destructor-001 "Test that we get the proper effect from our" -body {
- $OBJA destroy
- set ::goodbye_world($OBJA)
- } -result 2
- tcltest::test destructor-001 "Test that we get the proper effect from our" -body {
- set ::i_really_ran_destructor($OBJA)
- } -result 1
- tcltest::test destructor-003 "Test that we get the proper effect from our" -body {
- $OBJB destroy
- set ::goodbye_world($OBJB)
- } -result 1
- tcltest::test destructor-004 "Test that we get the proper effect from our" -body {
- set ::i_really_ran_destructor($OBJB)
- } -returnCodes 1 -result "can't read \"::i_really_ran_destructor($OBJB)\": no such element in array"