test.tcl
上传用户:rrhhcc
上传日期:2015-12-11
资源大小:54129k
文件大小:13k
源码类别:

通讯编程

开发平台:

Visual C++

  1. #
  2. # $Id: test.tcl,v 1.2 2003/07/29 18:13:37 xuanc Exp $
  3. # Copyright 1993 Massachusetts Institute of Technology
  4. #
  5. # Permission to use, copy, modify, distribute, and sell this software and its
  6. # documentation for any purpose is hereby granted without fee, provided that
  7. # the above copyright notice appear in all copies and that both that
  8. # copyright notice and this permission notice appear in supporting
  9. # documentation, and that the name of M.I.T. not be used in advertising or
  10. # publicity pertaining to distribution of the software without specific,
  11. # written prior permission.  M.I.T. makes no representations about the
  12. # suitability of this software for any purpose.  It is provided "as is"
  13. # without express or implied warranty.
  14. #
  15. #
  16. #
  17. # a meta-class for test objects, and a class for test suites
  18. #
  19. Class TestClass -superclass Class
  20. Class TestSuite
  21. #
  22. # check basic argument dispatch and unknown
  23. #
  24. TestSuite objectdispatch
  25. objectdispatch proc run {{n 50}} {
  26.   Object adispatch
  27.   adispatch proc unknown {m args} {eval list [list $m] $args}
  28.   adispatch proc cycle {l n args} {
  29.     if {$l>=$n} then {return ok}
  30.     set i [llength $args]
  31.     foreach a $args {
  32.       if {$a != $i} then {
  33. error "wrong order in arguments: $l $n $args"
  34.       }
  35.       incr i -1
  36.     }
  37.     incr l
  38.     
  39.     set ukn [eval [list $self] $args]
  40.     if {$ukn != $args} then {
  41.       error "wrong order in unknown: $ukns"
  42.     }
  43.     eval [list $self] [list $proc] [list $l] [list $n] [list $l] $args
  44.   }
  45.   if {[catch {adispatch cycle 1 $n 1} msg]} then {
  46.     error "FAILED $self: cycle: $msg"
  47.   }
  48.   return "PASSED $self"
  49. }
  50. #
  51. # examples from the workshop paper
  52. #
  53. TestSuite paperexamples
  54. paperexamples proc example1 {} {
  55.   Object astack
  56.   
  57.   astack set things {}
  58.   
  59.   astack proc put {thing} {
  60.     $self instvar things
  61.     set things [concat [list $thing] $things]
  62.     return $thing
  63.   }
  64.   
  65.   astack proc get {} {
  66.     $self instvar things
  67.     set top [lindex $things 0]
  68.     set things [lrange $things 1 end]
  69.     return $top
  70.   }
  71.   
  72.   astack put bagel
  73.   astack get
  74.   astack destroy
  75. }
  76. paperexamples proc example2 {} {
  77.   Class Safety
  78.   
  79.   Safety instproc init {} {
  80.     $self next
  81.     $self set count 0
  82.   }
  83.   
  84.   Safety instproc put {thing} {
  85.     $self instvar count
  86.     incr count
  87.     $self next $thing
  88.   }
  89.   
  90.   Safety instproc get {} {
  91.     $self instvar count
  92.     if {$count == 0} then { return {empty!} }
  93.     incr count -1
  94.     $self next
  95.   }
  96.   
  97.   Class Stack
  98.   
  99.   Stack instproc init {} {
  100.     $self next
  101.     $self set things {}
  102.   }
  103.   
  104.   Stack instproc put {thing} {
  105.     $self instvar things
  106.     set things [concat [list $thing] $things]
  107.     return $thing
  108.   }
  109.   
  110.   Stack instproc get {} {
  111.     $self instvar things
  112.     set top [lindex $things 0]
  113.     set things [lrange $things 1 end]
  114.     return $top
  115.   }
  116.   
  117.   Class SafeStack -superclass {Safety Stack}
  118.   
  119.   SafeStack s
  120.   s put bagel
  121.   s get
  122.   s get
  123.   s destroy
  124.   SafeStack destroy
  125.   Stack destroy
  126.   Safety destroy
  127. }
  128. paperexamples proc run {} {
  129.   set msg {}
  130.   if {[catch {$self example1; $self example2} msg] == "0"} then {
  131.     return "PASSED $self"
  132.   } else {
  133.     error "FAILED $self: $msg"
  134.   }
  135. }
  136. #
  137. # create a graph of classes
  138. #
  139. TestSuite classcreate
  140. classcreate proc factorgraph {{n 3600}} {
  141.   TestClass $n
  142.   for {set i [expr {$n/2}]} {$i>1} {incr i -1} {
  143.     if {($n % $i) == 0} then {
  144.       
  145.       #
  146.       # factors become subclasses, direct or indirect
  147.       #
  148.       if {[TestClass info instances $i] == {}} then {
  149. $self factorgraph $i
  150. $i superclass $n
  151.       } elseif {[$i info superclass $n] == 0} then {
  152. $i superclass [concat [$i info superclass] $n]
  153.       }
  154.     }
  155.   }
  156. }
  157. classcreate proc run {} {
  158.   set msg {}
  159.   if {[catch {$self factorgraph} msg] == "0"} then {
  160.     return "PASSED $self"
  161.   } else {
  162.     error "FAILED $self: $msg"
  163.   }
  164. }
  165. #
  166. # lookup superclasses and combine inherited methods
  167. #
  168. TestSuite inheritance
  169. inheritance proc meshes {s l} {
  170.   set p -1
  171.   foreach j $s {
  172.     set n [lsearch -exact $l $j]
  173.     if {$n == -1} then {
  174.       error "FAILED $self - missing superclass"
  175.     }
  176.     if {$n <= $p} then {
  177.       error "FAILED $self - misordered heritage: $s : $l"
  178.     }
  179.     set p $n
  180.   }
  181. }
  182. inheritance proc superclass {} {
  183.   foreach i [TestClass info instances] {
  184.     set s [$i info superclass]
  185.     set h [$i info heritage]
  186.     
  187.     #
  188.     # superclasses should mesh with heritage
  189.     #
  190.     
  191.     $self meshes $s $h
  192.   }
  193. }
  194. inheritance proc combination {} {
  195.   foreach i [TestClass info instances] {
  196.     
  197.     #
  198.     # combination should mesh with heritage
  199.     #
  200.     
  201.     $i anumber
  202.     set obj [lrange [anumber combineforobj] 1 end]
  203.     set h [$i info heritage]
  204.     $self meshes $obj $h
  205.     anumber destroy
  206.     
  207.     if {[$i info procs combineforclass] != {}} then {
  208.       set cls [lrange [$i combineforclass] 1 end]
  209.       $self meshes $cls $h
  210.     }
  211.   }
  212. }
  213. inheritance proc run {} {
  214.   #
  215.   # add combine methods to "random" half of the graph
  216.   #
  217.   set t [TestClass info instances]
  218.   for {set i 0} {$i < [llength $t]} {incr i 2} {
  219.     set o [lindex $t $i]
  220.     $o instproc combineforobj {} {
  221.       return [concat [list $class] [$self next]]
  222.     }
  223.     $o proc combineforclass {} {
  224.       return [concat [list $class] [$self next]]
  225.     }
  226.   }
  227.   
  228.   #
  229.   # and to Object as a fallback
  230.   #
  231.   Object instproc combineforobj {} {
  232.     return [concat [list $class] [$self next]]
  233.   }
  234.   Object proc combineforclass {} {
  235.     return [concat [list $class] [$self next]]
  236.   }
  237.   $self superclass
  238.   $self combination
  239.   return "PASSED $self"
  240. }
  241. #
  242. # destroy graph of classes
  243. #
  244. TestSuite classdestroy
  245. classdestroy proc run {} {
  246.   
  247.   #
  248.   # remove half of the graph at a time
  249.   #
  250.   TestClass instproc destroy {} {
  251.     global TCdestroy
  252.     set TCdestroy $self
  253.     $self next
  254.   }
  255.   while {[TestClass info instances] != {}} {
  256.     set t [TestClass info instances]
  257.     for {set i 0} {$i < [llength $t]} {incr i} {
  258.       set o [lindex $t $i]
  259.       #
  260.       # quarter dies directly, quarter indirectly, quarter renamed
  261.       #
  262.     
  263.       if {($i % 2) == 0} then {
  264. global TCdestroy
  265. set sb [$o info subclass]
  266. if {[info tclversion] >= 7.4 && ($i % 4) == 0} then {
  267.   rename $o {}
  268. } else {
  269.   $o destroy
  270. }
  271. if {[catch {set TCdestroy}] || $TCdestroy != $o} then {
  272.   error "FAILED $self - destroy instproc not run for $o"
  273. }
  274. if {[info commands $o] != {}} then {
  275.   error "FAILED $self - $o not removed from interpreter"
  276. }
  277. unset TCdestroy
  278. #
  279. # but everyone must still have a superclass
  280. #
  281. foreach j $sb {
  282.   if {[$j info superclass] == {}} then {
  283.     $j superclass Object
  284.   }
  285. }
  286.       } elseif {[info tclversion] >= 7.4 && ($i % 3) == 0} then {
  287.         rename $o $o.$i
  288.       }
  289.     }
  290.     
  291.     inheritance superclass
  292.     inheritance combination
  293.   }
  294.   return "PASSED $self"
  295. }
  296. TestSuite objectinits
  297. objectinits proc prepare {n} {
  298.   #
  299.   # head of a chain of classes that do add inits
  300.   #
  301.   TestClass 0
  302.   0 instproc init {args} {
  303.     eval $self next $args
  304.     $self set order {}
  305.   }
  306.   #
  307.   # and the rest
  308.   #
  309.   for {set i 1} {$i < $n} {incr i} {
  310.     TestClass $i -superclass [expr {$i-1}]
  311.     
  312.     #
  313.     # record the reverse order of inits
  314.     #
  315.     $i instproc init {args} {
  316.       eval $self next $args
  317.       $self instvar order
  318.       lappend order $class
  319.     }
  320.     #
  321.     # add instproc for init options
  322.     #
  323.     $i instproc $i.set {val} {
  324.       $self instvar $class
  325.       set $class $proc.$val
  326.     }
  327.   }
  328. }
  329.   
  330. objectinits proc run {{n 15}} {
  331.   $self prepare $n
  332.   set il {}
  333.   for {set i 1} {$i < $n} {incr i} {
  334.     lappend il $i
  335.     set al {}
  336.     set args {}
  337.     for {set j $i} {$j > 0} {incr j -1} {
  338.       lappend al $j
  339.       lappend args -$j.set $j
  340.       #
  341.       # create obj of increasing class with increasing options
  342.       #
  343.       if {[catch {eval $i $i.$j $args} msg] != 0} then {
  344. error "FAILED $self - $msg"
  345.       }
  346.       if {[$i.$j set order] != $il} then {
  347. error "FAILED $self - inited order was wrong"
  348.       }
  349.       set vl [lsort -decreasing -integer [$i.$j info vars {[0-9]*}]]
  350.       if {$vl != $al} then {
  351. error "FAILED $self - wrong instvar names: $vl : $al"
  352.       }
  353.       foreach k $vl {
  354. set val $k.set.$k
  355. if {[$i.$j set $k] != $val} then {
  356.   error "FAILED $self - wrong instvar values"
  357. }
  358.       }
  359.     }
  360.   }
  361.   return "PASSED $self"
  362. }
  363. TestSuite objectvariables
  364. objectvariables proc run {{n 100}} {
  365.   TestClass Variables
  366.   Variables avar
  367.   foreach obj {avar Variables TestClass Class Object} {
  368.     
  369.     #
  370.     # set up some variables
  371.     #
  372.     
  373.     $obj set scalar 0
  374.     $obj set array() {}
  375.     $obj unset array()
  376.     $obj set unset.$n {}
  377.     
  378.     #
  379.     # mess with them recursively
  380.     #
  381.     
  382.     $obj proc recurse {n} {
  383.       $self instvar scalar array
  384.       incr scalar
  385.       set array($n) $n
  386.       $self instvar unset.$n
  387.       unset unset.$n
  388.       incr n -1
  389.       $self instvar unset.$n
  390.       set unset.$n [array names array]
  391.       if {$n > 0} then { 
  392. $self recurse $n
  393.       }
  394.     }
  395.     
  396.     
  397.     $obj recurse $n
  398.     #
  399.     # check the result and clean up
  400.     #
  401.     
  402.     if {[$obj set scalar] != $n} then {
  403.       error "FAILED $self - scalar"
  404.     }
  405.     $obj unset scalar
  406.     for {set i $n} {$i > 0} {incr i -1} {
  407.       if {[$obj set array($i)] != $i} then {
  408. error "FAILED $self - array"
  409.       }
  410.     }    
  411.     $obj unset array
  412.     if {[$obj info vars] != "unset.0"} then {
  413.       error "FAILED $self - unset: [$obj info vars]"
  414.     }
  415.   }
  416.   #
  417.   # trace variables
  418.   #
  419.   Variables avar2
  420.   avar2 proc trace {var ops} {
  421.     $self instvar $var
  422.     trace variable $var $ops "avar2 traceproc"
  423.   }
  424.   avar2 proc traceproc {maj min op} {
  425.     global trail; lappend trail [list $maj $min $op]
  426.   }
  427.   global guide trail
  428.   avar2 trace array wu
  429.   for {set i 0} {$i < $n} {incr i} {
  430.     avar2 trace scalar$i wu
  431.     avar2 set scalar$i $i
  432.     lappend guide [list scalar$i {} w]
  433.     avar2 set array($i) [avar2 set scalar$i]
  434.     lappend guide [list array $i w]
  435.   }
  436.   if {$guide != $trail} then {
  437.     error "FAILED $self - trace: expected $guide, got $trail"
  438.   }
  439.   #
  440.   # destroy must trigger unset traces
  441.   #
  442.   set trail {}
  443.   set guide {}
  444.   lappend guide [list array {} u]
  445.   for {set i 0} {$i < $n} {incr i} {
  446.     lappend guide [list scalar$i {} u]
  447.   }
  448.   avar2 destroy
  449.   if {[lsort $guide] != [lsort $trail]} then {
  450.     error "FAILED $self - trace: expected $guide, got $trail"
  451.   }
  452.   Variables destroy
  453.   
  454.   return "PASSED $self"
  455. }
  456. #
  457. # c api, if compiled with -DTESTCAPI
  458. #
  459. TestSuite capi
  460. capi proc run {{n 50}} {
  461.   set start [dawnoftime read]
  462.   for {set i 0} {$i < $n} {incr i} {
  463.     Timer atime$i
  464.     if {$i % 3} {atime$i stop}
  465.     if {$i % 7} {atime$i read}
  466.     if {$i % 2} {atime$i start}
  467.     if {$i % 5} {atime$i stop}
  468.   }
  469.   set end [dawnoftime read]
  470.   if {$end < $start} {
  471.     error "FAILED $self: timer doesn't work"
  472.   }
  473.   foreach i [Timer info instances] {$i destroy}
  474.   Timer destroy
  475.   return "PASSED $self"
  476. }
  477. #
  478. # high and low level autoload
  479. #
  480. TestSuite autoload
  481. autoload proc atest {} {
  482. }
  483. autoload proc run {{n 10}} {
  484.   global auto_path
  485.   foreach i [glob -nocomplain tmpld*.tcl] {exec rm -f $i}
  486.   set prev Object
  487.   for {set i 0} {$i <= $n} {incr i} {
  488.     set fid [open "tmpld$i.tcl" w]
  489.     puts $fid "Class AutoTest$i -superclass $prev"
  490.     puts $fid "AutoTest0 instproc $i {args} {return 1}"
  491.     set prev AutoTest$i
  492.     close $fid
  493.   }
  494.   catch {exec mv -f tclIndex tclIndex.saved}
  495.   otcl_mkindex Class . tmpld*.tcl
  496.   lappend auto_path .
  497.   auto_reset
  498.   # why use AutoTest5?
  499.   # fine for 0, but not others
  500.   # if enable print out in otcl.c, seg fault
  501.   # xuanc, 7/29/03
  502.   set m [expr {$n/2}]
  503.   if {[catch {AutoTest$m atest} msg]} then {
  504.     error "FAILED $self - $msg"
  505.   }
  506.   for {set i $n} {$i > $m} {incr i -1} {
  507.     if {[AutoTest0 info instprocs $i] == {}} then {
  508.       error "FAILED $self - missing loader stub"
  509.     }
  510.     if {![catch {AutoTest0 info instbody $i}]} then {
  511.       error "FAILED $self - premature load"
  512.     }
  513.   }
  514.   for {set i 0} {$i <= $m} {incr i} {
  515.     if {[AutoTest0 info instprocs $i] == {}} then {
  516.       error "FAILED $self - missing instproc"
  517.     }
  518.     if {[catch {AutoTest0 info instbody 0}]} then {
  519.       error "FAILED $self - failed load"
  520.     }
  521.   }
  522.   # why 0-10? AutoTest5 can only load procs 0-5
  523.   # hangs when i = 6
  524.   # need to fix, xuanc, 7/29/2003
  525.   for {set i 0} {$i <= $n} {incr i} {
  526.     if {![atest $i]} then {
  527.       error "FAILED $self - wrong proc result"
  528.     }
  529.   }   
  530.   puts "after atest"
  531.   
  532.   exec rm -f tclIndex
  533.   foreach i [glob -nocomplain tmpld*.tcl] {exec rm -f $i}
  534.   catch {exec mv -f tclIndex.saved tclIndex}
  535.   return "PASSED $self"
  536. }
  537. TestSuite proc run {} {
  538.   
  539.   #
  540.   # run individual tests in needed order
  541.   #
  542.   puts [objectdispatch run]
  543.   puts [paperexamples run]
  544.   puts [classcreate run]
  545.   puts [inheritance run]
  546.   puts [classdestroy run]
  547.   puts [objectinits run]
  548.   puts [objectvariables run]
  549.   if {[info commands Timer] != {}} then {
  550.     puts [capi run]
  551.   }
  552.   # autoload hangs---xuanc, 7/29/03
  553.   puts [autoload run]
  554. }
  555. TestSuite run
  556. exit
  557. # Local Variables:
  558. # mode: tcl
  559. # tcl-indent-level: 2
  560. # End: