# $Id: testo.xotcl,v 1.9 2007/08/14 16:38:27 neumann Exp $ # # Copyright 1993 Massachusetts Institute of Technology # # Permission to use, copy, modify, distribute, and sell this software and its # documentation for any purpose is hereby granted without fee, provided that # the above copyright notice appear in all copies and that both that # copyright notice and this permission notice appear in supporting # documentation, and that the name of M.I.T. not be used in advertising or # publicity pertaining to distribution of the software without specific, # written prior permission. M.I.T. makes no representations about the # suitability of this software for any purpose. It is provided "as is" # without express or implied warranty. # package require XOTcl 1 namespace import -force xotcl::* @ @File {description { This is a class which provides regression test objects for the OTcl derived features of the XOTcl - Language. This script is based upon the test.tcl script of the OTcl distribution and adopted for XOTcl. } } # # a meta-class for test objects, and a class for test suites # Class TestSuite @ Class TestSuite Class TestClass -superclass Class @ Class TestClass { description { A meta-class for test objects. } } # # check basic argument dispatch and unknown # TestSuite objectdispatch objectdispatch proc run {{n 50}} { Object adispatch adispatch proc unknown {m args} {eval list [list $m] $args} adispatch proc cycle {l n args} { if {$l>=$n} then {return ok} set i [llength $args] foreach a $args { if {$a != $i} then { error "wrong order in arguments: $l $n $args" } incr i -1 } incr l set ukn [eval [list [self]] $args] if {$ukn != $args} then { error "wrong order in unknown: $ukns" } eval [list [self]] [list [self proc]] [list $l] [list $n] [list $l] $args } if {[catch {adispatch cycle 1 $n 1} msg]} then { error "FAILED [self]: cycle: $msg" } return "PASSED [self]" } # # examples from the workshop paper # TestSuite paperexamples paperexamples proc example1 {} { Object astack astack set things {} astack proc put {thing} { my instvar things set things [concat [list $thing] $things] return $thing } astack proc get {} { my instvar things set top [lindex $things 0] set things [lrange $things 1 end] return $top } astack put bagel astack get astack destroy } paperexamples proc example2 {} { Class Safety Safety instproc init {} { next my set count 0 } Safety instproc put {thing} { my instvar count incr count next } Safety instproc get {} { my instvar count if {$count == 0} then { return {empty!} } incr count -1 next } Class Stack Stack instproc init {} { next my set things {} } Stack instproc put {thing} { my instvar things set things [concat [list $thing] $things] return $thing } Stack instproc get {} { my instvar things set top [lindex $things 0] set things [lrange $things 1 end] return $top } Class SafeStack -superclass {Safety Stack} SafeStack s s put bagel s get s get s destroy SafeStack destroy Stack destroy Safety destroy } paperexamples proc run {} { set msg {} if {[catch {my example1; my example2} msg] == "0"} then { return "PASSED [self]" } else { error "FAILED [self]: $msg" } } # # create a graph of classes # TestSuite classcreate classcreate proc factorgraph {{n 3600}} { TestClass $n for {set i [expr {$n/2}]} {$i>1} {incr i -1} { if {($n % $i) == 0} then { # # factors become subclasses, direct or indirect # if {[TestClass info instances $i] eq ""} then { my factorgraph $i $i superclass $n } elseif {[$i info superclass $n] == 0} then { $i superclass [concat [$i info superclass] $n] } } } } classcreate proc run {} { set msg {} if {[catch {my factorgraph} msg] == "0"} then { return "PASSED [self]" } else { error "FAILED [self]: $msg" } } # # lookup superclasses and combine inherited methods # TestSuite inheritance inheritance proc meshes {s l} { set p -1 foreach j $s { set n [lsearch -exact $l $j] if {$n == -1} then { error "FAILED [self] - missing superclass" } if {$n <= $p} then { error "FAILED [self] - misordered heritage: $s : $l" } set p $n } } inheritance proc superclass {} { foreach i [TestClass info instances] { set s [$i info superclass] set h [$i info heritage] # # superclasses should mesh with heritage # my meshes $s $h } } inheritance proc combination {} { foreach i [lsort [TestClass info instances]] { # # combination should mesh with heritage # $i anumber set obj [lrange [anumber combineforobj] 1 end] set h [$i info heritage] my meshes $obj $h anumber destroy if {[$i info procs combineforclass] ne ""} then { set cls [lrange [$i combineforclass] 1 end] my meshes $cls $h } } } inheritance proc run {} { # # add combine methods to "random" half of the graph # set t [TestClass info instances] for {set i 0} {$i < [llength $t]} {incr i 2} { set o [lindex $t $i] $o instproc combineforobj {} { return [concat [list [self class]] [next]] } $o proc combineforclass {} { return [concat [list [self class]] [next]] } } # # and to Object as a fallback # Object instproc combineforobj {} { return [concat [list [self class]] [next]] } Object proc combineforclass {} { return [concat [list [self class]] [next]] } my superclass my combination return "PASSED [self]" } # # destroy graph of classes # TestSuite classdestroy classdestroy proc run {} { # # remove half of the graph at a time # TestClass instproc destroy {} { global TCdestroy set TCdestroy [self] next } while {[TestClass info instances] ne ""} { set t [TestClass info instances] for {set i 0} {$i < [llength $t]} {incr i} { set o [lindex $t $i] # # quarter dies directly, quarter indirectly, quarter renamed # if {($i % 2) == 0} then { global TCdestroy set sb [$o info subclass] if {[info tclversion] >= 7.4 && ($i % 4) == 0} then { $o move "" } else { $o destroy } if {[catch {set TCdestroy}] || $TCdestroy != $o} then { error "FAILED [self] - destroy instproc not run for $o" } if {[info commands $o] ne ""} then { error "FAILED [self] - $o not removed from interpreter" } unset TCdestroy # # but everyone must still have a superclass # foreach j $sb { if {[$j info superclass] eq ""} then { $j superclass Object } } } elseif {[info tclversion] >= 7.4 && ($i % 3) == 0} then { $o move $o.$i } } inheritance superclass inheritance combination } return "PASSED [self]" } TestSuite objectinits objectinits proc prepare {n} { # # head of a chain of classes that do add inits # TestClass 0 0 instproc init {args} { next my set order {} } # # and the rest # for {set i 1} {$i < $n} {incr i} { TestClass $i -superclass [expr {$i-1}] # # record the reverse order of inits # $i instproc init {args} { eval next $args my instvar order lappend order [namespace tail [self class]] } # # add instproc for init options # $i instproc m$i.set {val} { my instvar [namespace tail [self class]] set [namespace tail [self class]] [self proc].$val } } } objectinits proc run {{n 15}} { my prepare $n set il {} for {set i 1} {$i < $n} {incr i} { lappend il $i set al {} set args {} for {set j $i} {$j > 0} {incr j -1} { lappend al $j lappend args -m$j.set $j # # create obj of increasing class with increasing options # if {[catch {eval $i m$i.$j $args} msg] != 0} then { error "FAILED [self] - $msg" } if {[m$i.$j set order] != $il} then { error "FAILED [self] - inited order was wrong" } set vl [lsort -decreasing -integer [m$i.$j info vars {[0-9]*}]] if {$vl != $al} then { error "FAILED [self] - wrong instvar names: $vl : $al" } foreach k $vl { if {[m$i.$j set $k] != "m$k.set.$k"} then { error "FAILED [self] - wrong instvar values" } } } } return "PASSED [self]" } TestSuite objectvariables objectvariables proc run {{n 100}} { TestClass Variables Variables avar foreach obj {avar Variables TestClass xotcl::Class xotcl::Object} { # # set up some variables # $obj set scalar 0 $obj set array() {} $obj unset array() $obj set unset.$n {} # # mess with them recursively # $obj proc recurse {n} { my instvar scalar array incr scalar set array($n) $n my instvar unset.$n unset unset.$n incr n -1 my instvar unset.$n set unset.$n [array names array] if {$n > 0} then { my recurse $n } } $obj recurse $n # # check the result and clean up # if {[$obj set scalar] != $n} then { error "FAILED [self] - scalar" } $obj unset scalar for {set i $n} {$i > 0} {incr i -1} { if {[$obj set array($i)] != $i} then { error "FAILED [self] - array" } } $obj unset array if {[$obj info vars "unset.0"] eq ""} then { error "FAILED [self] - unset: [$obj info vars]" } } # # trace variables # Variables avar2 avar2 proc trace {var ops} { my instvar $var ::trace variable $var $ops "avar2 traceproc" } avar2 proc traceproc {maj min op} { set majTmp [namespace tail "$maj"] global trail; lappend trail [list $majTmp $min $op] } avar2 proc killSelf {} { my destroy } global guide trail set trail {} set guide {} avar2 trace array wu for {set i 0} {$i < $n} {incr i} { avar2 trace scalar$i wu avar2 set scalar$i $i lappend guide [list scalar$i {} w] avar2 set array($i) [avar2 set scalar$i] lappend guide [list array $i w] } if {$guide != $trail} then { error "FAILED [self] - trace: expected $guide, got $trail" } # # destroy must trigger unset traces # set trail {} set guide {} lappend guide [list array {} u] for {set i 0} {$i < $n} {incr i} { lappend guide [list scalar$i {} u] } avar2 killSelf if {[lsort $guide] != [lsort $trail]} then { error "FAILED [self] - trace: expected $guide, got $trail" } Variables destroy return "PASSED [self]" } # # c api, if compiled with -DTESTCAPI # TestSuite capi capi proc run {{n 50}} { set start [dawnoftime read] for {set i 0} {$i < $n} {incr i} { Timer atime$i if {$i % 3} {atime$i stop} if {$i % 7} {atime$i read} if {$i % 2} {atime$i start} if {$i % 5} {atime$i stop} } set end [dawnoftime read] if {$end < $start} { error "FAILED [self]: timer doesn't work" } foreach i [Timer info instances] {$i destroy} Timer destroy return "PASSED [self]" } TestSuite proc run {} { # # run individual tests in needed order # puts [objectdispatch run] puts [paperexamples run] puts [classcreate run] puts [inheritance run] puts [classdestroy run] puts [objectinits run] puts [objectvariables run] if {[info commands Timer] ne ""} then { puts [capi run] } # puts [autoload run] } puts [time {TestSuite run} 1] #exit # Local Variables: # mode: tcl # tcl-indent-level: 2 # End: