diff options
Diffstat (limited to 'itcl/itcl/tests/old')
24 files changed, 2164 insertions, 0 deletions
diff --git a/itcl/itcl/tests/old/AAA.test b/itcl/itcl/tests/old/AAA.test new file mode 100644 index 00000000000..d3cda41d121 --- /dev/null +++ b/itcl/itcl/tests/old/AAA.test @@ -0,0 +1,82 @@ +# +# AAA - first test executed in test suite +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ---------------------------------------------------------------------- +# SHOULD HAVE A CLEAN SLATE +# ---------------------------------------------------------------------- +test {No object info (no classes)} { + itcl_info classes +} { + $result == "" +} + +test {No object info (no objects)} { + itcl_info objects +} { + $result == "" +} + +# ---------------------------------------------------------------------- +# TEST CLASS AUTO-LOADING +# ---------------------------------------------------------------------- +test {Force auto-loading through inheritance} { + FooBar x +} { + $result == "x" +} + +test {Info: all classes} { + itcl_info classes +} { + [test_cmp_lists $result {Foo Bar FooBar}] +} + +test {Info: all classes matching a pattern} { + itcl_info classes *oo* +} { + [test_cmp_lists $result {Foo FooBar}] +} + +# ---------------------------------------------------------------------- +# OBJECT AUTO-NUMBERING +# ---------------------------------------------------------------------- +test {Create object with auto-naming} { + FooBar #auto -blit x +} { + $result == "fooBar0" && [fooBar0 info public blit -value] == "x" +} + +test {Create object with auto-naming} { + FooBar #auto -blit y +} { + $result == "fooBar1" && [fooBar1 info public blit -value] == "y" +} + +test {Auto-naming should avoid names already in use} { + FooBar fooBar2 + FooBar fooBar3 + FooBar fooBar4 + FooBar #auto +} { + $result == "fooBar5" +} + +test {Destroy all outstanding objects} { + foreach obj [itcl_info objects] { + $obj delete + } +} { + $result == "" +} diff --git a/itcl/itcl/tests/old/Bar.tcl b/itcl/itcl/tests/old/Bar.tcl new file mode 100644 index 00000000000..4ab50f0c7a1 --- /dev/null +++ b/itcl/itcl/tests/old/Bar.tcl @@ -0,0 +1,39 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +itcl_class Bar { + # + # Constructor/destructor add their name to a global var for + # tracking implicit constructors/destructors + # + constructor {config} { + global WATCH + lappend WATCH [namespace current] + } + destructor { + global WATCH + lappend WATCH [namespace current] + } + + method config {config} { + return $config + } + + # + # Define variables that will be shadowed by another class. + # + public blit + protected _blit +} diff --git a/itcl/itcl/tests/old/BarFoo.tcl b/itcl/itcl/tests/old/BarFoo.tcl new file mode 100644 index 00000000000..1854eaf34a1 --- /dev/null +++ b/itcl/itcl/tests/old/BarFoo.tcl @@ -0,0 +1,31 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +itcl_class BarFoo { + inherit Bar Foo + + # + # Constructor/destructor add their name to a global var for + # tracking implicit constructors/destructors + # + constructor {config} { + global WATCH + lappend WATCH [namespace current] + } + destructor { + global WATCH + lappend WATCH [namespace current] + } +} diff --git a/itcl/itcl/tests/old/Baz.tcl b/itcl/itcl/tests/old/Baz.tcl new file mode 100644 index 00000000000..725a1d0ed9e --- /dev/null +++ b/itcl/itcl/tests/old/Baz.tcl @@ -0,0 +1,27 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +itcl_class Baz { + # + # Avoid defining constructor/destructor + # + + # + # Generic method for doing something in "Baz" interp + # + method do {cmds} { + return "Baz says '[eval $cmds]'" + } +} diff --git a/itcl/itcl/tests/old/Foo.tcl b/itcl/itcl/tests/old/Foo.tcl new file mode 100644 index 00000000000..e73846edeed --- /dev/null +++ b/itcl/itcl/tests/old/Foo.tcl @@ -0,0 +1,99 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +itcl_class Foo { + # + # Constructor/destructor add their name to a global var for + # tracking implicit constructors/destructors + # + constructor {config} { + global WATCH + lappend WATCH [namespace current] + set foos([namespace tail $this]) $this + incr nfoo + } + destructor { + global WATCH + lappend WATCH [namespace current] + unset foos([namespace tail $this]) + } + + method nothing {} {} + + method do {cmds} { + return "Foo says '[eval $cmds]'" + } + + # + # Test formal arguments for methods/procs + # (formal args should not clobber data members) + # + method testMethodArgs {blit _blit args} { + return "$blit, $_blit, and [llength $args] other args" + } + proc testProcArgs {nfoo args} { + return "$nfoo, and [llength $args] other args" + } + + # + # Test methods using the "config" argument + # + method config {{config "-blit auto -blat matic"}} { + return $config + } + method xconfig {x config} { + return "$x|$config" + } + method configx {config x} { + return "$config|$x" + } + method xecho {x args} { + return "$x | [llength $args]: $args" + } + + # + # Test procs and access to common vars + # + proc echo {x args} { + return "$x | [llength $args]: $args" + } + proc foos {{pattern *}} { + set retn {} + foreach i [array names foos] { + if {$i != "_ignore_" && [string match $pattern $i]} { + lappend retn $i + } + } + return $retn + } + proc nfoos {} { + return $nfoo + } + + # + # Test public/protected/common variable definitions + # + public blit + public blat 0 + public blot 1 {global WATCH; set WATCH "blot=$blot"} + + protected _blit + protected _blat 0 + + common foos + set foos(_ignore_) "foos-is-now-an-array" + + common nfoo 0 +} diff --git a/itcl/itcl/tests/old/FooBar.tcl b/itcl/itcl/tests/old/FooBar.tcl new file mode 100644 index 00000000000..81227a84eda --- /dev/null +++ b/itcl/itcl/tests/old/FooBar.tcl @@ -0,0 +1,31 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +itcl_class FooBar { + inherit Foo Bar + + # + # Constructor/destructor add their name to a global var for + # tracking implicit constructors/destructors + # + constructor {config} { + global WATCH + lappend WATCH [namespace current] + } + destructor { + global WATCH + lappend WATCH [namespace current] + } +} diff --git a/itcl/itcl/tests/old/Geek.tcl b/itcl/itcl/tests/old/Geek.tcl new file mode 100644 index 00000000000..f431f40f10a --- /dev/null +++ b/itcl/itcl/tests/old/Geek.tcl @@ -0,0 +1,44 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +itcl_class Geek { + + # + # Constructor/destructor add their name to a global var for + # tracking implicit constructors/destructors + # + constructor {config} { + global WATCH + lappend WATCH [namespace current] + } + destructor { + global WATCH + lappend WATCH [namespace current] + } + + method do {cmds} { + return "Geek says '[eval $cmds]'" + } + + method config {config} { + return $config + } + + # + # Define variables that will be shadowed by another class. + # + public blat + protected _blat +} diff --git a/itcl/itcl/tests/old/Mongrel.tcl b/itcl/itcl/tests/old/Mongrel.tcl new file mode 100644 index 00000000000..ef48e2968ef --- /dev/null +++ b/itcl/itcl/tests/old/Mongrel.tcl @@ -0,0 +1,34 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +itcl_class Mongrel { + inherit FooBar Geek + + # + # Constructor/destructor add their name to a global var for + # tracking implicit constructors/destructors + # + constructor {config} { + global WATCH + lappend WATCH [namespace current] + } + destructor { + global WATCH + lappend WATCH [namespace current] + } + + public blit nonnull + public tag +} diff --git a/itcl/itcl/tests/old/VirtualErr.tcl b/itcl/itcl/tests/old/VirtualErr.tcl new file mode 100644 index 00000000000..ae09581ae96 --- /dev/null +++ b/itcl/itcl/tests/old/VirtualErr.tcl @@ -0,0 +1,23 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +itcl_class VirtualErr { + # + # The following inherit statement will cause an error, + # since it will find the same base class "Foo" inherited + # from several places. + # + inherit Mongrel Foo BarFoo +} diff --git a/itcl/itcl/tests/old/all b/itcl/itcl/tests/old/all new file mode 100644 index 00000000000..2c40a9c6402 --- /dev/null +++ b/itcl/itcl/tests/old/all @@ -0,0 +1,32 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +variable WATCH + +global TEST_ABS_TOL TEST_REL_TOL +set TEST_ABS_TOL 1.0e-6 +set TEST_REL_TOL 1.0e-5 + +if {![file readable "testlib.tcl"]} { + error "ERROR: execute test suite in \"tests\" directory" +} + +lappend auto_path . + +foreach i [lsort [glob ./*.test]] { + source $i +} +puts stdout "== ALL TESTS SUCCESSFUL ==" +exit diff --git a/itcl/itcl/tests/old/basic.test b/itcl/itcl/tests/old/basic.test new file mode 100644 index 00000000000..c5240073f58 --- /dev/null +++ b/itcl/itcl/tests/old/basic.test @@ -0,0 +1,408 @@ +# +# Basic tests for class definition and method/proc access +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ---------------------------------------------------------------------- +# CLEAN THE SLATE +# ---------------------------------------------------------------------- +foreach obj [itcl_info objects -class Foo] { + $obj delete +} + +# ---------------------------------------------------------------------- +# CREATING OBJECTS +# ---------------------------------------------------------------------- +test {Create a simple object} { + Foo x +} { + $result == "x" +} + +test {Make sure that object names cannot be duplicated} { + catch "Foo x" errmsg +} { + $result == 1 +} + +test {Create another object} { + Foo xx +} { + $result == "xx" +} + +test {Create an object with an automatic name} { + Foo #auto +} { + [string match foo* $result] +} + +test {Get list of objects in a class} { + itcl_info objects -class Foo +} { + [llength $result] == 3 +} + +# ---------------------------------------------------------------------- +# PUBLIC VARIABLES +# ---------------------------------------------------------------------- +test {Info: all public variables} { + x info public +} { + [test_cmp_lists $result {Foo::blit Foo::blat Foo::blot}] +} + +test {Info: public variable initial value} { + x info public blit -init +} { + $result == "" +} + +test {Info: public variable initial value (undefined)} { + x info public blit -value +} { + $result == "<undefined>" +} + +test {Info: public variable initial value} { + x info public blat -init +} { + $result == 0 +} + +test {Info: public variable current value} { + x info public blot -value +} { + $result == 1 +} + +test {Info: public variable config statement} { + x info public blit -config +} { + $result == "" +} + +test {Info: public variable config statement} { + x info public blot -config +} { + $result == {global WATCH; set WATCH "blot=$blot"} +} + +# ---------------------------------------------------------------------- +# CONFIG-ING PUBLIC VARIABLES +# ---------------------------------------------------------------------- +test {Setting public variables via "config"} { + x config -blit 27 -blat xyz +} { + $result == "Foo::blit Foo::blat" +} + +test {Info: public variable init/current value} { + x info public blit -init -value +} { + $result == {{} 27} +} + +test {Info: public variable init/current value} { + x info public blat -init -value +} { + $result == {0 xyz} +} + +test {"config" is ordinary arg if it is not last arg} { + x configx -blit pdq +} { + $result == {-blit|pdq} +} + +test {Public variables with "config" code} { + set WATCH "" + concat [x config -blot abc] / $WATCH +} { + $result == "Foo::blot / blot=abc" +} + +test {Make sure object data is local to objects} { + x config -blit abc + xx config -blit xyz + concat [x info public blit -value] / [xx info public blit -value] +} { + $result == "abc / xyz" +} + +# ---------------------------------------------------------------------- +# PROTECTED VARIABLES +# ---------------------------------------------------------------------- +test {Info: all protected variables} { + x info protected +} { + [test_cmp_lists $result {Foo::_blit Foo::_blat Foo::this}] +} + +test {Info: protected "this" variable} { + x info protected this -value +} { + $result == "::x" +} + +test {Info: protected "this" variable} { + xx info protected this -value +} { + $result == "::xx" +} + +test {Info: protected variable initial value} { + x info protected _blit -init +} { + $result == "" +} + +test {Info: protected variable access/value} { + x do {set _blit rst} +} { + $result == "Foo says 'rst'" && + [x info protected _blit -value] == "rst" +} + +# ---------------------------------------------------------------------- +# COMMON VARIABLES +# ---------------------------------------------------------------------- +test {Info: all protected variables} { + x info common +} { + [test_cmp_lists $result {Foo::foos Foo::nfoo}] +} + +test {Info: common variable initial value} { + x info common foos -init +} { + $result == "" +} + +test {Info: common variable initial value} { + x info common nfoo -init +} { + $result == 0 +} + +test {Info: common variable access/value} { + x do {set nfoo 999} + x info common nfoo -value +} { + $result == 999 +} + +test {Make sure common data is really common} { + x do {set nfoo 0} + x info common nfoo -value +} { + $result == [xx info common nfoo -value] +} + +test {Access common data in proc} { + x do {set nfoo 10} + Foo :: nfoos +} { + $result == 10 +} + +test {Common variables can be initialized within class definition} { + x do {if {[info exists foos(_ignore_)]} {set foos(_ignore_)}} +} { + $result == "Foo says 'foos-is-now-an-array'" +} + +test {Arrays as common data} { + Foo :: foos +} { + [test_cmp_lists $result [itcl_info objects -class Foo]] +} + +# ---------------------------------------------------------------------- +# METHODS +# ---------------------------------------------------------------------- +test {Info: all methods} { + x info method +} { + [test_cmp_lists $result { + Foo::constructor Foo::destructor + Foo::nothing Foo::do Foo::xecho + Foo::config Foo::xconfig Foo::configx + Foo::testMethodArgs + Foo::configure Foo::delete Foo::cget Foo::isa + }] +} + +test {Info: method args} { + x info method nothing -args +} { + $result == "" +} + +test {Info: method args} { + x info method xconfig -args +} { + $result == "x config" +} + +test {Info: method body} { + x info method nothing -body +} { + $result == "" +} + +test {Info: method body} { + x info method xconfig -body +} { + $result == { + return "$x|$config" + } +} + +# ---------------------------------------------------------------------- +# PROCS +# ---------------------------------------------------------------------- +test {Info: all procs} { + x info proc +} { + [test_cmp_lists $result { + Foo::echo Foo::foos Foo::nfoos Foo::testProcArgs + }] +} + +test {Info: proc args} { + x info proc nfoos -args +} { + $result == "" +} + +test {Info: proc args} { + x info proc foos -args +} { + $result == "{pattern *}" +} + +test {Info: proc body} { + x info proc nfoos -body +} { + $result == { + return $nfoo + } +} + +test {Info: proc body} { + x info body nfoos +} { + $result == { + return $nfoo + } +} + +# ---------------------------------------------------------------------- +# ARGUMENT LISTS +# ---------------------------------------------------------------------- +test {Default arguments can get assigned a proper value} { + Foo :: foos x* +} { + [test_cmp_lists $result {x xx}] +} + +test {Default value for "config" argument} { + x config +} { + $result == "Foo::blit Foo::blat" && + [x info public blit -value] == "auto" && + [x info public blat -value] == "matic" +} + +test {"args" formal argument absorbs extra arguments} { + Foo :: echo abc 1 2 3 +} { + $result == "abc | 3: 1 2 3" +} + +test {"args" formal argument absorbs extra arguments} { + Foo :: echo def +} { + $result == "def | 0: " +} + +test {"args" formal argument absorbs extra arguments} { + x xecho abc 1 2 3 +} { + $result == "abc | 3: 1 2 3" +} + +test {"args" formal argument absorbs extra arguments} { + x xecho def +} { + $result == "def | 0: " +} + +test {Extra args cause an error} { + catch "x configx arg arg error" +} { + $result != 0 +} + +test {Extra args cause an error} { + catch "x nothing error" +} { + $result != 0 +} + +test {Formal arguments don't clobber public/protected variables} { + x do { + set blit okay + set _blit no-problem + } + x testMethodArgs yuck puke etc. +} { + $result == "yuck, puke, and 1 other args" && + [x info public blit -value] == "okay" && + [x info protected _blit -value] == "no-problem" +} + +test {Formal arguments don't clobber common variables} { + Foo :: testProcArgs yuck etc. +} { + $result == "yuck, and 1 other args" && + [x info common nfoo -value] != "yuck" +} + +# ---------------------------------------------------------------------- +# DELETING OBJECTS +# ---------------------------------------------------------------------- +test {Delete an object} { + x delete +} { + $result == "" +} + +test {Delete an object} { + xx delete +} { + $result == "" +} + +test {Destructor is properly invoked} { + Foo :: foos +} { + [test_cmp_lists $result [itcl_info objects -class Foo]] +} + +test {Object names are removed as commands} { + expr {[info commands x] == "" && [info commands xx] == ""} +} { + $result == 1 +} diff --git a/itcl/itcl/tests/old/inherit.test b/itcl/itcl/tests/old/inherit.test new file mode 100644 index 00000000000..2e3f0a2c134 --- /dev/null +++ b/itcl/itcl/tests/old/inherit.test @@ -0,0 +1,272 @@ +# +# Tests for inheritance and scope handling +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ---------------------------------------------------------------------- +# MULTIPLE BASE-CLASS ERROR DETECTION +# ---------------------------------------------------------------------- +test {Cannot inherit from the same base class more than once} { + catch "VirtualErr" errmsg + set errmsg +} { + [string match {*class "::VirtualErr" inherits base class "::Foo" more than once: + VirtualErr->Mongrel->FooBar->Foo + VirtualErr->Foo + VirtualErr->BarFoo->Foo} $result] +} + +# ---------------------------------------------------------------------- +# CONSTRUCTION +# ---------------------------------------------------------------------- +test {Constructors should be invoked implicitly} { + set WATCH "" + concat [Mongrel m] / $WATCH +} { + $result == "m / ::Geek ::Bar ::Foo ::FooBar ::Mongrel" +} + +test {Initialization of shadowed variables works properly} { + concat [m info public blit -value] / [m info public Foo::blit -value] +} { + $result == "nonnull / <undefined>" +} + +# ---------------------------------------------------------------------- +# PUBLIC VARIABLES +# ---------------------------------------------------------------------- +test {Inherited "config" method works on derived classes} { + m config -blit xyz -Foo::blit pdq +} { + $result == "Mongrel::blit Foo::blit" +} + +test {Inherited "config" method works on derived classes} { + m config -blit xyz -Foo::blit pdq + concat [m info public blit -value] / [m info public Foo::blit -value] +} { + $result == "xyz / pdq" +} + +test {Inherited "config" method works on derived classes} { + m config -tag #0000 +} { + $result == "Mongrel::tag" +} + +# ---------------------------------------------------------------------- +# INHERITANCE INFO +# ---------------------------------------------------------------------- +test {Info: class} { + m info class +} { + $result == "::Mongrel" +} + +test {Info: inherit} { + m info inherit +} { + $result == "::FooBar ::Geek" +} + +test {Info: heritage} { + m info heritage +} { + $result == "::Mongrel ::FooBar ::Foo ::Bar ::Geek" +} + +test {Built-in "isa" method} { + set status 1 + foreach c [m info heritage] { + set status [expr {$status && [m isa $c]}] + } + set status +} { + $result == 1 +} + +test {Built-in "isa" method} { + itcl_class Watermelon {} + m isa Watermelon +} { + $result == 0 +} + +# ---------------------------------------------------------------------- +# SCOPE MANIPULATION +# ---------------------------------------------------------------------- +test {commands normally execute in the scope of their class} { + m Foo::do {namespace current} +} { + $result == "Foo says '::Foo'" +} + +test {"virtual" command moves scope to most specific class} { + m Foo::do {virtual namespace current} +} { + $result == "Foo says '::Mongrel'" +} + +test {"previous" command moves scope upward in hierarchy} { + m do {virtual previous namespace current} +} { + $result == "Foo says '::FooBar'" +} + +test {"previous" command can be chained} { + m do {virtual previous previous namespace current} +} { + $result == "Foo says '::Foo'" +} + +# ---------------------------------------------------------------------- +# METHOD INVOCATION +# ---------------------------------------------------------------------- +test {Simple method names are assigned based on heritage} { + m do {concat "$this ([virtual info class]) at scope [namespace current]"} +} { + $result == "Foo says '::m (Mongrel) at scope ::Foo'" +} + +test {Explicit scoping can be used to reach shadowed members} { + m Geek::do {concat "$this ([virtual info class]) at scope [namespace current]"} +} { + $result == "Geek says '::m (Mongrel) at scope ::Geek'" +} + +test {Methods execute in local scope of class, e.g., Foo::do} { + m config -blit abc -Foo::blit def + m Foo::do {set blit xyz} + concat [m info public blit -value] / [m info public Foo::blit -value] +} { + $result == "abc / xyz" +} + +# ---------------------------------------------------------------------- +# DESTRUCTION +# ---------------------------------------------------------------------- +test {Destructors should be invoked implicitly} { + set WATCH "" + concat [m delete] / $WATCH +} { + $result == "/ ::Mongrel ::FooBar ::Foo ::Bar ::Geek" +} + +# ---------------------------------------------------------------------- +# OBJECT INFO +# ---------------------------------------------------------------------- +foreach obj [itcl_info objects] { + $obj delete +} +Mongrel m +FooBar fb +Foo f +Geek g + +test {Object queries can be restricted by object name} { + itcl_info objects f* +} { + [test_cmp_lists $result {f fb}] +} + +test {Object queries can be restricted to specific classes} { + itcl_info objects -class Foo +} { + $result == "f" +} + +test {Object queries can be restricted by object heritage} { + itcl_info objects -isa Foo +} { + [test_cmp_lists $result {m f fb}] +} + +test {Object queries can be restricted by object name / specific classes} { + itcl_info objects f* -class Foo +} { + $result == "f" +} + +test {Object queries can be restricted by object name / object heritage} { + itcl_info objects f* -isa Foo +} { + [test_cmp_lists $result {f fb}] +} + +# ---------------------------------------------------------------------- +# ERROR HANDLING ACROSS CLASS BOUNDARIES +# ---------------------------------------------------------------------- +Mongrel m1 +FooBar fb2 + +test {Errors and detected and reported across class boundaries} { + set status [catch {m1 do {fb2 do {error "test"}}} mesg] + format "$mesg $status" +} { + $result == "test 1" +} + +test {Stack trace unwinds properly across class boundaries} { + catch {m1 do {fb2 do {error "test"}}} mesg + format "$errorInfo" +} { + $result == {test + while executing +"error "test"" + ("eval" body line 1) + invoked from within +"eval $cmds" + invoked from within +"return "Foo says '[eval $cmds]..." + (object "::fb2" method "::Foo::do" body line 2) + invoked from within +"fb2 do {error "test"}" + ("eval" body line 1) + invoked from within +"eval $cmds" + invoked from within +"return "Foo says '[eval $cmds]..." + (object "::m1" method "::Foo::do" body line 2) + invoked from within +"m1 do {fb2 do {error "test"}}"} +} + +test {Stack trace unwinds properly across class boundaries} { + catch {m1 do {fb2 do {error "test" "some error"}}} mesg + format "$errorInfo" +} { + $result == {some error + ("eval" body line 1) + invoked from within +"eval $cmds" + invoked from within +"return "Foo says '[eval $cmds]..." + (object "::fb2" method "::Foo::do" body line 2) + invoked from within +"fb2 do {error "test" "some error"}" + ("eval" body line 1) + invoked from within +"eval $cmds" + invoked from within +"return "Foo says '[eval $cmds]..." + (object "::m1" method "::Foo::do" body line 2) + invoked from within +"m1 do {fb2 do {error "test" "some error"}}"} +} + +test {Error codes are preserved across class boundaries} { + catch {m1 do {fb2 do {error "test" "some error" CODE-BLUE}}} mesg + format "$errorCode" +} { + $result == "CODE-BLUE" +} diff --git a/itcl/itcl/tests/old/tclIndex b/itcl/itcl/tests/old/tclIndex new file mode 100644 index 00000000000..85918fe24c6 --- /dev/null +++ b/itcl/itcl/tests/old/tclIndex @@ -0,0 +1,24 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(Bar) "source $dir/Bar.tcl" +set auto_index(Foo) "source $dir/Foo.tcl" +set auto_index(BarFoo) "source $dir/BarFoo.tcl" +set auto_index(FooBar) "source $dir/FooBar.tcl" +set auto_index(Geek) "source $dir/Geek.tcl" +set auto_index(Mongrel) "source $dir/Mongrel.tcl" +set auto_index(VirtualErr) "source $dir/VirtualErr.tcl" +set auto_index(test) "source $dir/testlib.tcl" +set auto_index(test_cmp_nums) "source $dir/testlib.tcl" +set auto_index(test_cmp_vectors) "source $dir/testlib.tcl" +set auto_index(test_cmp_lists) "source $dir/testlib.tcl" +set auto_index(upvarTest_show_var) "source $dir/upvar.test" +set auto_index(upvarTest_upvar_in_procs) "source $dir/upvar.test" +set auto_index(uplevelTest_show_var) "source $dir/uplevel.test" +set auto_index(uplevelTest_do) "source $dir/uplevel.test" +set auto_index(Baz) "source $dir/Baz.tcl" diff --git a/itcl/itcl/tests/old/testlib.tcl b/itcl/itcl/tests/old/testlib.tcl new file mode 100644 index 00000000000..9ba4b31dd0d --- /dev/null +++ b/itcl/itcl/tests/old/testlib.tcl @@ -0,0 +1,131 @@ +# +# Old test suite for [incr Tcl] v1.5 +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ---------------------------------------------------------------------- +# USAGE: test <test-desc> <test-cmd> <check> +# +# Executes the given test, the evaluates the <check> condition to +# see if the test passed. The result from the <test-cmd> is kept +# in the variable $result. If this condition evaluates non-zero, +# the test has passed. Otherwise, the test has failed. A variety +# if checking routines (test_cmp_*) are provided below to make +# the check condition easier to write. +# ---------------------------------------------------------------------- +proc test {desc cmd check} { + set result [uplevel $cmd] + + if {![expr $check]} { + puts stdout "-------------------------------------------------------" + puts stdout ">>>> FAILED TEST <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<" + puts stdout "-------------------------------------------------------" + set lines [split $desc "\n"] + foreach i $lines { + puts stdout $i + } + puts stdout "=======================================================" + set lines [split $cmd "\n"] + set label TEST + foreach i $lines { + puts stdout " $label | $i" + set label " " + } + puts stdout "-------------------------------------------------------" + set lines [split $check "\n"] + set label CHECK + foreach i $lines { + if {$i != ""} { + puts stdout " $label | $i" + set label " " + } + } + puts stdout "-------------------------------------------------------" + set lines [split $result "\n"] + set label RESULT + foreach i $lines { + if {$i != ""} { + puts stdout " $label | \$result => $i" + set label " " + } + } + puts stdout "=======================================================" + error "tests aborted" + } +} + +# ---------------------------------------------------------------------- +# USAGE: test_cmp_nums <num1> <num2> +# +# Compares two numbers to see if they are "equal." Numbers are +# "equal" if they have an absolute value greater than 1.0e-6 and they +# have at least 5 significant figures. Returns 1/0 for true/false. +# ---------------------------------------------------------------------- +proc test_cmp_nums {num1 num2} { + global TEST_ABS_TOL TEST_REL_TOL + + if {[expr abs($num1)] > $TEST_ABS_TOL && + [expr abs($num2)] > $TEST_ABS_TOL} { + set avg [expr 0.5*($num1+$num2)] + set diff [expr abs(($num1-$num2)/$avg)] + + if {$diff > $TEST_REL_TOL} { + return 0 + } + } + return 1 +} + +# ---------------------------------------------------------------------- +# USAGE: test_cmp_vectors <list1> <list2> +# +# Compares two lists of numbers to see if they are "equal." Vectors +# are "equal" if elements are "equal" in the numeric sense. +# Returns 1/0 for true/false. +# ---------------------------------------------------------------------- +proc test_cmp_vectors {list1 list2} { + if {[llength $list1] != [llength $list2]} { + return 0 + } + for {set i 0} {$i < [llength $list1]} {incr i} { + set n1 [lindex $list1 $i] + set n2 [lindex $list2 $i] + + if {![test_cmp_nums $n1 $n2]} { + return 0 + } + } + return 1 +} + +# ---------------------------------------------------------------------- +# USAGE: test_cmp_lists <list1> <list2> +# +# Compares two lists to see if they are "equal." Lists are "equal" +# if they contain exactly the same elements, but perhaps in a +# different order. Returns 1/0 for true/false. +# ---------------------------------------------------------------------- +proc test_cmp_lists {list1 list2} { + if {[llength $list1] != [llength $list2]} { + return 0 + } + foreach elem $list1 { + set i [lsearch $list2 $elem] + if {$i >= 0} { + set list2 [lreplace $list2 $i $i] + } else { + return 0 + } + } + return 1 +} diff --git a/itcl/itcl/tests/old/toaster.test b/itcl/itcl/tests/old/toaster.test new file mode 100644 index 00000000000..593676a648c --- /dev/null +++ b/itcl/itcl/tests/old/toaster.test @@ -0,0 +1,165 @@ +# +# Tests for "toaster" example +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ---------------------------------------------------------------------- +# Get toaster classes from "demos" directory. +# ---------------------------------------------------------------------- +lappend auto_path toasters + +# ---------------------------------------------------------------------- +# Outlets send bills to an e-mail address. Determine this address. +# ---------------------------------------------------------------------- +if {[info exists env(USER)]} { + set Owner $env(USER) +} elseif {[info exists env(LOGNAME)]} { + set Owner $env(LOGNAME) +} else { + set Owner [exec logname] +} + +# ---------------------------------------------------------------------- +# TOASTERS +# ---------------------------------------------------------------------- +test {Create a toaster and plug it in} { + global Owner + Toaster original -heat 1 -outlet [Outlet #auto -owner $Owner] +} { + $result == "original" +} + +test {Turn up the heat setting on the toaster} { + original config -heat 5 +} { + $result == "" +} + +test {Toast a few slices of bread} { + original toast 2 +} { + $result == "crumb tray: 25% full" +} + +test {Clean the toaster} { + original clean +} { + $result == "crumb tray: 0% full" +} + +test {Toast a few slices of bread a few different times} { + original clean + original toast 2 + original toast 1 +} { + $result == "crumb tray: 38% full" +} + +test {Toast too many slices of bread and cause a fire} { + puts stdout ">>> should say \"== FIRE! FIRE! ==\"" + original clean + original toast 2 + original toast 2 + original toast 2 + original toast 2 +} { + $result == "crumb tray: 100% full" +} + +test {Destroy the toaster} { + original clean + original toast 2 + original toast 1 + puts stdout ">>> should say \"15 crumbs ... what a mess!\"" + original delete +} { + $result == "" +} + +# ---------------------------------------------------------------------- +# SMART TOASTERS +# ---------------------------------------------------------------------- +test {Create a toaster and plug it in} { + global Owner + SmartToaster deluxe -heat 4 -outlet [Outlet #auto -owner $Owner] +} { + $result == "deluxe" +} + +test {Toast a few slices of bread} { + deluxe toast 2 +} { + $result == "crumb tray: 20% full" +} + +test {Toast a few slices of bread and look for auto-clean} { + deluxe clean + deluxe toast 2 + deluxe toast 2 + deluxe toast 2 + deluxe toast 2 + deluxe toast 2 +} { + $result == "crumb tray: 20% full" +} + +# ---------------------------------------------------------------------- +# PRODUCT STATISTICS +# ---------------------------------------------------------------------- +test {Check statistics gathered by Hazard base class} { + set tmp [Toaster #auto] + set stats [Hazard :: report ::Toaster] + $tmp delete + set stats +} { + $result == "::Toaster: 2 produced, 1 active, 1 accidents" +} + +test {Check statistics gathered by Hazard base class} { + Hazard :: report ::SmartToaster +} { + $result == "::SmartToaster: 1 produced, 1 active, 0 accidents" +} + +test {Destroy all Toasters} { + foreach toaster [itcl_info objects -isa Toaster] { + $toaster clean + $toaster delete + } +} { + $result == "" +} + +test {SmartToasters should have been destroyed along with Toasters} { + itcl_info objects -class SmartToaster +} { + $result == "" +} + +# ---------------------------------------------------------------------- +# OUTLETS +# ---------------------------------------------------------------------- +test {Bill all customers for outlet charges} { + Outlet :: bill + puts stdout ">>> should send two bills for outlets via e-mail" +} { + $result == "" +} + +test {Destroy all outlets} { + foreach outlet [itcl_info objects -class Outlet] { + $outlet delete + } +} { + $result == "" +} diff --git a/itcl/itcl/tests/old/toasters/Appliance.tcl b/itcl/itcl/tests/old/toasters/Appliance.tcl new file mode 100644 index 00000000000..8cc2de1e8d7 --- /dev/null +++ b/itcl/itcl/tests/old/toasters/Appliance.tcl @@ -0,0 +1,43 @@ +# ---------------------------------------------------------------------- +# PURPOSE: Base class for all electrical appliances that interact +# with Outlets. +# +# AUTHOR: Michael J. McLennan Phone: (610)712-2842 +# AT&T Bell Laboratories E-mail: michael.mclennan@att.com +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993 AT&T Bell Laboratories +# ====================================================================== +# Permission to use, copy, modify, and distribute this software and its +# documentation for any purpose and without fee is hereby granted, +# provided that the above copyright notice appear in all copies and that +# both that the copyright notice and warranty disclaimer appear in +# supporting documentation, and that the names of AT&T Bell Laboratories +# any of their entities not be used in advertising or publicity +# pertaining to distribution of the software without specific, written +# prior permission. +# +# AT&T disclaims all warranties with regard to this software, including +# all implied warranties of merchantability and fitness. In no event +# shall AT&T be liable for any special, indirect or consequential +# damages or any damages whatsoever resulting from loss of use, data or +# profits, whether in an action of contract, negligence or other +# tortuous action, arising out of or in connection with the use or +# performance of this software. +# ====================================================================== + +itcl_class Appliance { + + method power {power} { + if {[itcl_info objects [info which $outlet]] == ""} { + set outlet {} + } + if {$outlet == ""} { + error "cannot use $this: not plugged in" + } + $outlet use $power + } + + public outlet {} +} diff --git a/itcl/itcl/tests/old/toasters/Hazard.tcl b/itcl/itcl/tests/old/toasters/Hazard.tcl new file mode 100644 index 00000000000..7b50552ba3e --- /dev/null +++ b/itcl/itcl/tests/old/toasters/Hazard.tcl @@ -0,0 +1,78 @@ +# ---------------------------------------------------------------------- +# PURPOSE: Tracking for hazardous products manufactured by the +# "toaster" company. +# +# AUTHOR: Michael J. McLennan Phone: (610)712-2842 +# AT&T Bell Laboratories E-mail: michael.mclennan@att.com +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993 AT&T Bell Laboratories +# ====================================================================== +# Permission to use, copy, modify, and distribute this software and its +# documentation for any purpose and without fee is hereby granted, +# provided that the above copyright notice appear in all copies and that +# both that the copyright notice and warranty disclaimer appear in +# supporting documentation, and that the names of AT&T Bell Laboratories +# any of their entities not be used in advertising or publicity +# pertaining to distribution of the software without specific, written +# prior permission. +# +# AT&T disclaims all warranties with regard to this software, including +# all implied warranties of merchantability and fitness. In no event +# shall AT&T be liable for any special, indirect or consequential +# damages or any damages whatsoever resulting from loss of use, data or +# profits, whether in an action of contract, negligence or other +# tortuous action, arising out of or in connection with the use or +# performance of this software. +# ====================================================================== + +itcl_class HazardRec { + constructor {cname} { + set class $cname + } + method change {var inc} { + if {![info exists $var]} { + error "bad field \"$var\"" + } + incr $var $inc + } + method report {} { + return "$class: $total produced, $actives active, $accidents accidents" + } + protected class {} + protected total 0 + protected actives 0 + protected accidents 0 +} + +itcl_class Hazard { + + constructor {} { + set class [virtual info class] + if {![info exists recs($class)]} { + set recs($class) [HazardRec #auto $class] + } + $recs($class) change total +1 + $recs($class) change actives +1 + } + destructor { + set class [virtual info class] + $recs($class) change actives -1 + } + + method accident {mesg} { + set class [virtual info class] + $recs($class) change accidents +1 + puts stderr $mesg + } + + proc report {class} { + if {[info exists recs($class)]} { + return [$recs($class) report] + } else { + error "no information for class \"$class\"" + } + } + common recs +} diff --git a/itcl/itcl/tests/old/toasters/Outlet.tcl b/itcl/itcl/tests/old/toasters/Outlet.tcl new file mode 100644 index 00000000000..27c69f552a5 --- /dev/null +++ b/itcl/itcl/tests/old/toasters/Outlet.tcl @@ -0,0 +1,81 @@ +# ---------------------------------------------------------------------- +# PURPOSE: Electrical outlet supplying power for Appliances. +# +# AUTHOR: Michael J. McLennan Phone: (610)712-2842 +# AT&T Bell Laboratories E-mail: michael.mclennan@att.com +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993 AT&T Bell Laboratories +# ====================================================================== +# Permission to use, copy, modify, and distribute this software and its +# documentation for any purpose and without fee is hereby granted, +# provided that the above copyright notice appear in all copies and that +# both that the copyright notice and warranty disclaimer appear in +# supporting documentation, and that the names of AT&T Bell Laboratories +# any of their entities not be used in advertising or publicity +# pertaining to distribution of the software without specific, written +# prior permission. +# +# AT&T disclaims all warranties with regard to this software, including +# all implied warranties of merchantability and fitness. In no event +# shall AT&T be liable for any special, indirect or consequential +# damages or any damages whatsoever resulting from loss of use, data or +# profits, whether in an action of contract, negligence or other +# tortuous action, arising out of or in connection with the use or +# performance of this software. +# ====================================================================== + +itcl_class Outlet { + constructor {config} {} + method config {config} {} + + destructor { + if {$usage > 0} bill + } + + method use {power} { + set usage [expr $usage+$power] + } + + method sendBill {} { + if {[catch "open /tmp/bill w" fout] != 0} { + error "cannot create bill in /tmp" + } else { + set amount [format "$%.2f" [expr $usage*$rate]] + puts $fout "----------------------------------------" + puts $fout "/////////// MEGA-POWER, INC. ///////////" + puts $fout "----------------------------------------" + puts $fout " Customer: $owner" + puts $fout " Outlet: $this" + puts $fout " Usage: $usage kilowatt-hours" + puts $fout " " + puts $fout " Amount Due: $amount" + puts $fout "----------------------------------------" + close $fout + exec mail $owner < /tmp/bill + set usage 0 + } + } + + proc bill {{customer *}} { + foreach outlet [itcl_info objects -class Outlet] { + set owner [$outlet info public owner -value] + if {[string match $customer $owner]} { + $outlet sendBill + } + } + } + + proc rate {{newval ""}} { + if {$newval == ""} { + return $rate + } + set rate $newval + } + + public owner {} + protected usage 0 + + common rate 0.05 +} diff --git a/itcl/itcl/tests/old/toasters/SmartToaster.tcl b/itcl/itcl/tests/old/toasters/SmartToaster.tcl new file mode 100644 index 00000000000..7a97225319d --- /dev/null +++ b/itcl/itcl/tests/old/toasters/SmartToaster.tcl @@ -0,0 +1,40 @@ +# ---------------------------------------------------------------------- +# PURPOSE: Class definition for handling "smart" toasters via +# [incr Tcl]. A "smart" toaster is a toaster that +# automatically cleans itself when the crumb tray is full. +# +# AUTHOR: Michael J. McLennan Phone: (610)712-2842 +# AT&T Bell Laboratories E-mail: michael.mclennan@att.com +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993 AT&T Bell Laboratories +# ====================================================================== +# Permission to use, copy, modify, and distribute this software and its +# documentation for any purpose and without fee is hereby granted, +# provided that the above copyright notice appear in all copies and that +# both that the copyright notice and warranty disclaimer appear in +# supporting documentation, and that the names of AT&T Bell Laboratories +# any of their entities not be used in advertising or publicity +# pertaining to distribution of the software without specific, written +# prior permission. +# +# AT&T disclaims all warranties with regard to this software, including +# all implied warranties of merchantability and fitness. In no event +# shall AT&T be liable for any special, indirect or consequential +# damages or any damages whatsoever resulting from loss of use, data or +# profits, whether in an action of contract, negligence or other +# tortuous action, arising out of or in connection with the use or +# performance of this software. +# ====================================================================== + +itcl_class SmartToaster { + inherit Toaster + + method toast {nslices} { + if {$crumbs >= [expr $maxcrumbs-10]} { + clean + } + return [Toaster::toast $nslices] + } +} diff --git a/itcl/itcl/tests/old/toasters/Toaster.tcl b/itcl/itcl/tests/old/toasters/Toaster.tcl new file mode 100644 index 00000000000..f844c88d6c8 --- /dev/null +++ b/itcl/itcl/tests/old/toasters/Toaster.tcl @@ -0,0 +1,75 @@ +# ---------------------------------------------------------------------- +# PURPOSE: Class definition for handling toasters via [incr Tcl]. +# +# AUTHOR: Michael J. McLennan Phone: (610)712-2842 +# AT&T Bell Laboratories E-mail: michael.mclennan@att.com +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993 AT&T Bell Laboratories +# ====================================================================== +# Permission to use, copy, modify, and distribute this software and its +# documentation for any purpose and without fee is hereby granted, +# provided that the above copyright notice appear in all copies and that +# both that the copyright notice and warranty disclaimer appear in +# supporting documentation, and that the names of AT&T Bell Laboratories +# any of their entities not be used in advertising or publicity +# pertaining to distribution of the software without specific, written +# prior permission. +# +# AT&T disclaims all warranties with regard to this software, including +# all implied warranties of merchantability and fitness. In no event +# shall AT&T be liable for any special, indirect or consequential +# damages or any damages whatsoever resulting from loss of use, data or +# profits, whether in an action of contract, negligence or other +# tortuous action, arising out of or in connection with the use or +# performance of this software. +# ====================================================================== + +itcl_class Toaster { + inherit Appliance Hazard + + constructor {config} {} + destructor { + if {$crumbs > 0} { + puts stdout "$crumbs crumbs ... what a mess!" + } + } + method config {config} {} + + method toast {nslices} { + power [expr 0.03*$heat] + if {$nslices < 1 || $nslices > 2} { + error "bad number of slices: should be 1 or 2" + } + set crumbs [expr $crumbs+$heat*$nslices] + if {$crumbs >= $maxcrumbs} { + accident "== FIRE! FIRE! ==" + set crumbs $maxcrumbs + } + return [check] + } + + method clean {} { + power 0.5 + set crumbs 0 + return [check] + } + + method check {} { + set level [expr $crumbs*100.0/$maxcrumbs] + return [format "crumb tray: %.0f%% full" $level] + } + + proc resize {newsize} { + set maxcrumbs $newsize + } + + public heat 3 { + if {$heat < 1 || $heat > 5} { + error "invalid setting $heat: should be 1-5" + } + } + protected crumbs 0 + common maxcrumbs 40 +} diff --git a/itcl/itcl/tests/old/toasters/tclIndex b/itcl/itcl/tests/old/toasters/tclIndex new file mode 100644 index 00000000000..01017bc7dae --- /dev/null +++ b/itcl/itcl/tests/old/toasters/tclIndex @@ -0,0 +1,18 @@ +# Tcl autoload index file, version 2.0 +# This file is generated by the "auto_mkindex" command +# and sourced to set up indexing information for one or +# more commands. Typically each line is a command that +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(Appliance) "source $dir/Appliance.tcl" +set auto_index(HazardRec) "source $dir/Hazard.tcl" +set auto_index(Hazard) "source $dir/Hazard.tcl" +set auto_index(Outlet) "source $dir/Outlet.tcl" +set auto_index(SmartToaster) "source $dir/SmartToaster.tcl" +set auto_index(Toaster) "source $dir/Toaster.tcl" +set auto_index(make_toaster) "source $dir/usualway.tcl" +set auto_index(toast_bread) "source $dir/usualway.tcl" +set auto_index(clean_toaster) "source $dir/usualway.tcl" +set auto_index(destroy_toaster) "source $dir/usualway.tcl" diff --git a/itcl/itcl/tests/old/toasters/usualway.tcl b/itcl/itcl/tests/old/toasters/usualway.tcl new file mode 100644 index 00000000000..dad4e15be07 --- /dev/null +++ b/itcl/itcl/tests/old/toasters/usualway.tcl @@ -0,0 +1,122 @@ +# ---------------------------------------------------------------------- +# PURPOSE: Procedures for managing toasters in the usual +# procedure-oriented Tcl programming style. These +# routines illustrate data sharing through global +# variables and naming conventions to logically group +# related procedures. The same programming task can +# be accomplished much more cleanly with [incr Tcl]. +# Inheritance also allows new behavior to be "mixed-in" +# more cleanly (see Appliance and Product base classes). +# +# AUTHOR: Michael J. McLennan Phone: (610)712-2842 +# AT&T Bell Laboratories E-mail: michael.mclennan@att.com +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993 AT&T Bell Laboratories +# ====================================================================== +# Permission to use, copy, modify, and distribute this software and its +# documentation for any purpose and without fee is hereby granted, +# provided that the above copyright notice appear in all copies and that +# both that the copyright notice and warranty disclaimer appear in +# supporting documentation, and that the names of AT&T Bell Laboratories +# any of their entities not be used in advertising or publicity +# pertaining to distribution of the software without specific, written +# prior permission. +# +# AT&T disclaims all warranties with regard to this software, including +# all implied warranties of merchantability and fitness. In no event +# shall AT&T be liable for any special, indirect or consequential +# damages or any damages whatsoever resulting from loss of use, data or +# profits, whether in an action of contract, negligence or other +# tortuous action, arising out of or in connection with the use or +# performance of this software. +# ====================================================================== + +# ---------------------------------------------------------------------- +# COMMAND: make_toaster <name> <heat> +# +# INPUTS +# <name> = name of new toaster +# <heat> = heat setting (1-5) +# +# RETURNS +# name of new toaster +# +# SIDE-EFFECTS +# Creates a record of a new toaster with the given heat setting +# and an empty crumb tray. +# ---------------------------------------------------------------------- +proc make_toaster {name heat} { + global allToasters + + if {$heat < 1 || $heat > 5} { + error "invalid heat setting: should be 1-5" + } + set allToasters($name-heat) $heat + set allToasters($name-crumbs) 0 +} + +# ---------------------------------------------------------------------- +# COMMAND: toast_bread <name> <slices> +# +# INPUTS +# <name> = name of toaster used to toast bread +# <slices> = number of bread slices (1 or 2) +# +# RETURNS +# current crumb count +# +# SIDE-EFFECTS +# Toasts bread and adds crumbs to crumb tray. +# ---------------------------------------------------------------------- +proc toast_bread {name slices} { + global allToasters + + if {[info exists allToasters($name-crumbs)]} { + set c $allToasters($name-crumbs) + set c [expr $c+$allToasters($name-heat)*$slices] + set allToasters($name-crumbs) $c + } else { + error "not a toaster: $name" + } +} + +# ---------------------------------------------------------------------- +# COMMAND: clean_toaster <name> +# +# INPUTS +# <name> = name of toaster to be cleaned +# +# RETURNS +# current crumb count +# +# SIDE-EFFECTS +# Cleans toaster by emptying crumb tray. +# ---------------------------------------------------------------------- +proc clean_toaster {name} { + global allToasters + set allToasters($name-crumbs) 0 +} + +# ---------------------------------------------------------------------- +# COMMAND: destroy_toaster <name> +# +# INPUTS +# <name> = name of toaster to be destroyed +# +# RETURNS +# nothing +# +# SIDE-EFFECTS +# Spills all crumbs in the toaster and then destroys it. +# ---------------------------------------------------------------------- +proc destroy_toaster {name} { + global allToasters + + if {[info exists allToasters($name-crumbs)]} { + puts stdout "$allToasters($name-crumbs) crumbs ... what a mess!" + unset allToasters($name-heat) + unset allToasters($name-crumbs) + } +} diff --git a/itcl/itcl/tests/old/uplevel.test b/itcl/itcl/tests/old/uplevel.test new file mode 100644 index 00000000000..527cb2cf200 --- /dev/null +++ b/itcl/itcl/tests/old/uplevel.test @@ -0,0 +1,155 @@ +# +# Tests for "uplevel" across interpreter boundaries +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ---------------------------------------------------------------------- +# DEFINE SOME USEFUL ROUTINES +# ---------------------------------------------------------------------- +proc uplevelTest_show_var {level var} { + return "$var>>[uplevel $level set $var]" +} + +proc uplevelTest_do {cmd} { + eval $cmd +} + +# ---------------------------------------------------------------------- +# CREATE SOME OBJECTS +# ---------------------------------------------------------------------- +Foo foo +Baz baz + +# ---------------------------------------------------------------------- +# UPLEVEL TESTS (main interp) +# ---------------------------------------------------------------------- +test {"uplevel" can access global variables (via relative level)} { + set globalvar "global value" + uplevelTest_show_var 1 globalvar +} { + $result == "globalvar>>global value" +} + +test {"uplevel" can access global variables (via "#0")} { + set globalvar "global value" + uplevelTest_show_var #0 globalvar +} { + $result == "globalvar>>global value" +} + +test {"uplevel" can access local variables (via relative level)} { + uplevelTest_do { + set localvar "local value" + uplevelTest_show_var 1 localvar + } +} { + $result == "localvar>>local value" +} + +test {"uplevel" can access local variables (via relative level)} { + uplevelTest_do { + set localvar "proper value" + uplevelTest_do { + set localvar "not this one" + uplevelTest_show_var 2 localvar + } + } +} { + $result == "localvar>>proper value" +} + +test {"uplevel" can access local variables (via explicit level)} { + uplevelTest_do { + set localvar "local value" + uplevelTest_show_var #1 localvar + } +} { + $result == "localvar>>local value" +} + +# ---------------------------------------------------------------------- +# UPLEVEL TESTS (across class interps) +# ---------------------------------------------------------------------- +test {"uplevel" can cross class interps to access global variables} { + set globalvar "global value" + foo do { + uplevel #0 uplevelTest_show_var 1 globalvar + } +} { + $result == "Foo says 'globalvar>>global value'" +} + +test {"uplevel" can cross several class interps to access global variables} { + set globalvar "global value" + baz do { + foo do { + uplevel 2 uplevelTest_show_var #0 globalvar + } + } +} { + $result == "Baz says 'Foo says 'globalvar>>global value''" +} + +test {"uplevel" finds proper scope for execution} { + baz do { + foo do { + uplevel do {{info class}} + } + } +} { + $result == "Baz says 'Foo says 'Baz says '::Baz'''" +} + +test {"uplevel" finds proper scope for execution, +and works in conjunction with "unknown" to access +commands at the global scope with local call frames} { + baz do { + set bazvar "value in Baz" + foo do { + uplevel ::info locals + } + } +} { + $result == "Baz says 'Foo says 'bazvar cmds''" +} + +# ---------------------------------------------------------------------- +# LEVEL TESTS (across class scopes) +# ---------------------------------------------------------------------- +test {"info level" works across scope boundaries} { + baz do { + foo do { + info level + } + } +} { + $result == "Baz says 'Foo says '2''" +} + +test {"info level" works across scope boundaries} { + baz do { + foo do { + info level 0 + } + } +} { + $result == "Baz says 'Foo says 'do { + info level 0 + }''" +} + +# ---------------------------------------------------------------------- +# CLEAN UP +# ---------------------------------------------------------------------- +foo delete +baz delete diff --git a/itcl/itcl/tests/old/upvar.test b/itcl/itcl/tests/old/upvar.test new file mode 100644 index 00000000000..15cf233be8d --- /dev/null +++ b/itcl/itcl/tests/old/upvar.test @@ -0,0 +1,110 @@ +# +# Tests for "upvar" across interpreter boundaries +# ---------------------------------------------------------------------- +# AUTHOR: Michael J. McLennan +# Bell Labs Innovations for Lucent Technologies +# mmclennan@lucent.com +# http://www.tcltk.com/itcl +# +# RCS: $Id$ +# ---------------------------------------------------------------------- +# Copyright (c) 1993-1998 Lucent Technologies, Inc. +# ====================================================================== +# See the file "license.terms" for information on usage and +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ---------------------------------------------------------------------- +# DEFINE SOME USEFUL ROUTINES +# ---------------------------------------------------------------------- +proc upvarTest_show_var {var val} { + return "$var>>$val" +} + +proc upvarTest_upvar_in_procs {} { + set upvarTest_var_local "value in main interp" + foo do { + upvar upvarTest_var_local var + set var + } +} + +# ---------------------------------------------------------------------- +# CREATE SOME OBJECTS +# ---------------------------------------------------------------------- +Foo foo +Baz baz + +# ---------------------------------------------------------------------- +# UPVAR TESTS +# ---------------------------------------------------------------------- +test {"::" sends command to global interp but preserves +local variables. This ensures that when control +shifts to the global scope for Extended Tcl commands, +Expect commands, etc., local variables will be +recognized.} { + foo do { + set localvar "special" + ::eval {upvarTest_show_var localvar $localvar} + } +} { + $result == "Foo says 'localvar>>special'" +} + + +test {"upvar" can cross interp boundaries to access local variables} { + upvarTest_upvar_in_procs +} { + $result == "Foo says 'value in main interp'" +} + +test {"upvar" can cross interp boundaries to access global variables} { + set upvarTest_var_global "value in main interp" + foo do { + upvar upvarTest_var_global var + set var + } +} { + $result == "Foo says 'value in main interp'" +} + +test {"upvar" can handle multiple call frames on the stack} { + set upvarTest_var_global "new value" + foo do { + foo do { + upvar #0 upvarTest_var_global var + set var + } + } +} { + $result == "Foo says 'Foo says 'new value''" +} + +test {"upvar" can cross class interp boundaries} { + baz do { + set localvar "value in Baz" + foo do { + upvar localvar var + set var + } + } +} { + $result == "Baz says 'Foo says 'value in Baz''" +} + +test {"upvar" can cross class interp boundaries back to main interp} { + set upvarTest_var_global "global value" + baz do { + foo do { + upvar 2 upvarTest_var_global var + set var + } + } +} { + $result == "Baz says 'Foo says 'global value''" +} + +# ---------------------------------------------------------------------- +# CLEAN UP +# ---------------------------------------------------------------------- +foo delete +baz delete |