Posted to tcl by hypnotoad at Tue Jun 13 14:20:50 GMT 2017view raw

  1. ###
  2. # Facilities for standardizing object transformations during TclTest
  3. ###
  4. package require tcltest
  5. oo::class create ::tcltest::object {
  6.  
  7. # An independant constructor that tcltest can control
  8. constructor args {
  9. my variable tcltest
  10. set tcltest(mixinmap) {}
  11. my tcltest_configure {*}$args
  12. }
  13.  
  14. destructor {
  15. my variable tcltest
  16. if {[info exists tcltest(destructor)]} {
  17. eval $tcltest(destructor)
  18. } else {
  19. next
  20. }
  21. }
  22.  
  23. method tcltest_destructor body {
  24. my variable tcltest
  25. set tcltest(destructor) $body
  26. }
  27.  
  28. # A means of controlling the tcltest framework class
  29. # Note the method names are designed to minimize conflict
  30. # with existing classes
  31. method tcltest_configure args {
  32. foreach {key value} $args {
  33. switch [string trimleft $key -] {
  34. class {
  35. set tcltest(class) $value
  36. my tcltest_morph $value
  37. }
  38. eval {
  39. eval $value
  40. }
  41. destructor {
  42. my tcltest_destructor $value
  43. }
  44. }
  45. }
  46. }
  47.  
  48. method tcltest_set args {
  49. my variable tcltest
  50. array set tcltest $args
  51. }
  52.  
  53. method tcltest_morph classname {
  54. my variable tcltest
  55. if {[info commands ::tcltest::hybrid::$classname] eq {}} {
  56. oo::class create ::tcltest::hybrid::$classname [list superclass ::tcltest::object $classname]
  57. }
  58. set tcltest(class) $classname
  59. ::oo::objdefine [self] class ::tcltest::hybrid::$classname
  60. if {[info exists tcltest(mixinmap)]} {
  61. my Tcltest_mixin_apply $tcltest(mixinmap)
  62. }
  63. }
  64.  
  65. # A method to allow tcltest to invoke code internally to
  66. # objects. Including access to private methods and variables
  67. method tcltest_eval script {
  68. eval $script
  69. }
  70.  
  71. method Tcltest_mixin_apply {map} {
  72. set mixlist {}
  73. foreach {s c} $map {
  74. if {$c eq {}} continue
  75. lappend mixlist $c
  76. }
  77. ::oo::objdefine [self] mixin {*}$mixlist
  78. }
  79.  
  80. # A formalized slot-based mechanism for managing mixins. Because we
  81. # break the space up into slots, individual aspects of behavior
  82. # can be added, removed, and combined with other mixins.
  83. # We use a dict internally for storage to allow the order in which mixins
  84. # were applied to be preserved. Not the difference between:
  85. # tcltest_mixin map FOO {}
  86. # and
  87. # tcltest_mixin unmap FOO
  88. #
  89. # A blank mapping will removed the effect, but preserve FOO's place in line
  90. # Unmap removes the concept completely.
  91. #
  92. method tcltest_mixin {command args} {
  93. my variable tcltest
  94. switch $command {
  95. dump {
  96. return $tcltest(mixinmap)
  97. }
  98. map {
  99. if {[llength $args]!=2} {
  100. error "Usage: [self method] map STUB CLASS"
  101. }
  102. lassign $args stub class
  103. # Placed here as a safety in case the before or after did not actually exist
  104. # And it's a handy place to make the call even if we didn't use before/after
  105. dict set tcltest(mixinmap) $stub $class
  106. # Build the list of classes to mixin, in the order proscribed by the dict
  107. my Tcltest_mixin_apply $tcltest(mixinmap)
  108. }
  109. replace {
  110. # Allows users to specify the order of mixins
  111. # Note we always include ::tcltest::object
  112. set tcltest(mixinmap) $args
  113. my Tcltest_mixin_apply $tcltest(mixinmap)
  114. }
  115. unmap {
  116. if {[llength $args]!=1} {
  117. error "Usage: mixinmap map STUB"
  118. }
  119. lassign $args stub
  120. if {[dict exists $tcltest(mixinmap) $stub]} {
  121. dict unset tcltest(mixinmap) $stub
  122. }
  123. my Tcltest_mixin_apply $tcltest(mixinmap)
  124. }
  125. default {
  126. error "Valid commands are: dump, map, replace, unmap"
  127. }
  128. }
  129. }
  130. }
  131.  
  132. oo::objdefine ::tcltest::object {
  133. method hijack object {
  134. set classname [info object class $object]
  135. if {[info commands ::tcltest::hybrid::$classname] eq {}} {
  136. oo::class create ::tcltest::hybrid::$classname [list superclass ::tcltest::object $classname]
  137. }
  138. ::oo::objdefine $object class ::tcltest::hybrid::$classname
  139. $object tcltest_set class $classname
  140. }
  141. }
  142.  
  143. ###
  144. # Example Usage
  145. ###
  146. oo::class create ::whatzit {
  147. constructor {foo bar baz} {
  148. my variable parameters
  149. set parameters(foo) $foo
  150. set parameters(bar) $bar
  151. set parameters(baz) $baz
  152. my Startup
  153. }
  154. destructor {
  155. set ::goodbye_world([self]) 1
  156. }
  157. method Startup {} {
  158. my variable parameters
  159. set parameters(combined) [lsort -stride 2 -dictionary [array get parameters]]
  160. }
  161. method get field {
  162. my variable parameters
  163. return $parameters($field)
  164. }
  165. method set {field value} {
  166. my variable parameters
  167. set parameters($field) $value
  168. set parameters(combined) [lsort -stride 2 -dictionary [array get parameters]]
  169. }
  170. }
  171.  
  172. # Note we run the
  173. set OBJA [tcltest::object new -class whatzit -destructor {
  174. set ::goodbye_world([self]) 2
  175. set ::i_really_ran_destructor([self]) 1
  176. }]
  177.  
  178. # We ran the tcltest::object contructor, not the constructor
  179. # for whatzit
  180. tcltest::test constructor-001 "Test that are using the tcltest::object constructor" -body {
  181. $OBJA get foo
  182.  
  183. } -returnCodes 1 -result {can't read "parameters(foo)": no such variable}
  184.  
  185. # Option 1: we re-create the effect of the constructor
  186. $OBJA tcltest_eval {
  187. lassign {A B C} foo bar baz
  188. my variable parameters
  189. array set parameters {
  190. foo A
  191. bar B
  192. baz C
  193. }
  194. my Startup
  195. }
  196.  
  197. # Option 2: we use the normal constructor and hijack the object later
  198. set OBJB [::whatzit new A B C]
  199. ::tcltest::object hijack $OBJB
  200. # equivilent to: oo::objdefine $OBJB mixin ::tcltest::object
  201.  
  202. tcltest::test constructor-002 "Test that we get the proper effect from our constructor" -body {
  203. $OBJA get combined
  204. } -result {bar B baz C foo A}
  205.  
  206. tcltest::test constructor-003 "Test that we get the proper effect from our constructor" -body {
  207. $OBJA get combined
  208. } -result [$OBJB get combined]
  209.  
  210. set testnum 0
  211. foreach obj [list $OBJA $OBJB] {
  212. foreach field {foo bar baz} {
  213. set testid parameters-[incr testnum]
  214. tcltest::test $testid "Test internal $field for $obj" \
  215. -body [list $obj tcltest_eval "my variable parameters \; set parameters($field)"] \
  216. -result [$obj get $field]
  217. }
  218. }
  219.  
  220. tcltest::test mixin-001 "Test we have our classes mixed in properly" -body {
  221. info object mixins $OBJA
  222. } -result {}
  223.  
  224. tcltest::test mixin-002 "Test we have our classes mixed in properly" -body {
  225. info object class $OBJA
  226. } -result {::tcltest::hybrid::whatzit}
  227.  
  228. tcltest::test mixin-003 "Test we have our classes mixed in properly" -body {
  229. info object mixins $OBJB
  230. } -result {}
  231.  
  232. tcltest::test mixin-004 "Test we have our classes mixed in properly" -body {
  233. info object class $OBJB
  234. } -result {::tcltest::hybrid::whatzit}
  235. # Test destructor
  236.  
  237. tcltest::test destructor-001 "Test that we get the proper effect from our" -body {
  238. $OBJA destroy
  239. set ::goodbye_world($OBJA)
  240. } -result 2
  241. tcltest::test destructor-001 "Test that we get the proper effect from our" -body {
  242. set ::i_really_ran_destructor($OBJA)
  243. } -result 1
  244. tcltest::test destructor-003 "Test that we get the proper effect from our" -body {
  245. $OBJB destroy
  246. set ::goodbye_world($OBJB)
  247. } -result 1
  248. tcltest::test destructor-004 "Test that we get the proper effect from our" -body {
  249. set ::i_really_ran_destructor($OBJB)
  250. } -returnCodes 1 -result "can't read \"::i_really_ran_destructor($OBJB)\": no such element in array"