diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2019-07-31 17:50:24 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2019-07-31 17:50:24 (GMT) |
commit | de0c57b4383a4d7ced5058c2c50580a0f4ba5477 (patch) | |
tree | ed9f83c4262ccc3cd22a3cf8ad5ad18f197f7d63 /tcl8.6/pkgs/itcl4.1.1/tests/chain.test | |
parent | 4f9885152c6e8eef1a01e2cc50fa4e3db8bbcb5c (diff) | |
download | blt-de0c57b4383a4d7ced5058c2c50580a0f4ba5477.zip blt-de0c57b4383a4d7ced5058c2c50580a0f4ba5477.tar.gz blt-de0c57b4383a4d7ced5058c2c50580a0f4ba5477.tar.bz2 |
upgrade tcl/tk 8.6.10
Diffstat (limited to 'tcl8.6/pkgs/itcl4.1.1/tests/chain.test')
-rw-r--r-- | tcl8.6/pkgs/itcl4.1.1/tests/chain.test | 166 |
1 files changed, 0 insertions, 166 deletions
diff --git a/tcl8.6/pkgs/itcl4.1.1/tests/chain.test b/tcl8.6/pkgs/itcl4.1.1/tests/chain.test deleted file mode 100644 index e80a1d6..0000000 --- a/tcl8.6/pkgs/itcl4.1.1/tests/chain.test +++ /dev/null @@ -1,166 +0,0 @@ -# -# Tests for chaining methods and procs -# ---------------------------------------------------------------------- -# AUTHOR: Michael J. McLennan -# Bell Labs Innovations for Lucent Technologies -# mmclennan@lucent.com -# http://www.tcltk.com/itcl -# ---------------------------------------------------------------------- -# 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. - -package require tcltest 2.1 -namespace import ::tcltest::test -::tcltest::loadTestedCommands -package require itcl - -# ---------------------------------------------------------------------- -# Chaining methods and procs -# ---------------------------------------------------------------------- -test chain-1.1 {define simple classes with inheritance} { - itcl::class test_chain_a { - constructor {args} { -# - eval chain $args - } { - global ::test_chain_status - lappend test_chain_status "a::constructor $args" - } - method show {mesg} { - chain $mesg - global ::test_chain_status - lappend test_chain_status "a::show $mesg" - } - proc tell {mesg} { - global ::test_chain_status - lappend test_chain_status "a::tell $mesg" - chain $mesg - } - } - itcl::class test_chain_b { - constructor {args} { -# - eval chain $args - } { - global ::test_chain_status - lappend test_chain_status "b::constructor $args" - } - method show {mesg} { - chain $mesg - global ::test_chain_status - lappend test_chain_status "b::show $mesg" - } - proc tell {mesg} { - global ::test_chain_status - lappend test_chain_status "b::tell $mesg" - chain $mesg - } - } - itcl::class test_chain_c { - inherit test_chain_a test_chain_b - constructor {args} { - eval chain $args - } { - global ::test_chain_status - lappend test_chain_status "c::constructor $args" - } - proc tell {mesg} { - global ::test_chain_status - lappend test_chain_status "c::tell $mesg" - chain $mesg - } - } - itcl::class test_chain_d { - inherit test_chain_c - constructor {args} { - eval chain $args - } { - global ::test_chain_status - lappend test_chain_status "d::constructor $args" - } - method show {mesg} { - chain $mesg - global ::test_chain_status - lappend test_chain_status "d::show $mesg" - } - proc tell {mesg} { - global ::test_chain_status - lappend test_chain_status "d::tell $mesg" - chain $mesg - } - } -} "" - -test chain-1.2 {create a test object} { - set test_chain_status "" - set testobj [test_chain_d #auto 1 2 3] - set test_chain_status -} {{b::constructor 1 2 3} {a::constructor 1 2 3} {c::constructor 1 2 3} {d::constructor 1 2 3}} - -test chain-1.3 {invoke a chained method} { - set test_chain_status "" - $testobj show "hello there" - set test_chain_status -} {{b::show hello there} {a::show hello there} {d::show hello there}} - -test chain-1.4 {invoke a chained method with a specific name} { - set test_chain_status "" - $testobj test_chain_d::show "hello there" - set test_chain_status -} {{b::show hello there} {a::show hello there} {d::show hello there}} - -test chain-1.5 {chained methods can cross multiple-inheritance branches} { - set test_chain_status "" - $testobj test_chain_a::show "hello there" - set test_chain_status -} {{b::show hello there} {a::show hello there}} - -test chain-1.6 {invoke a chained proc} { - set test_chain_status "" - test_chain_d::tell "testing 1 2 3" - set test_chain_status -} {{d::tell testing 1 2 3} {c::tell testing 1 2 3} {a::tell testing 1 2 3}} - -test chain-1.7 {invoke a chained proc} { - set test_chain_status "" - test_chain_c::tell "testing 1 2 3" - set test_chain_status -} {{c::tell testing 1 2 3} {a::tell testing 1 2 3}} - -test chain-2.1 {create a test object in a base class} { - set test_chain_status "" - set testobj [test_chain_c #auto 4 5 6] - set test_chain_status -} {{b::constructor 4 5 6} {a::constructor 4 5 6} {c::constructor 4 5 6}} - -test chain-2.2 {invoke a chained method} { - set test_chain_status "" - $testobj show "hello there" - set test_chain_status -} {{b::show hello there} {a::show hello there}} - -test chain-3.0 {invoke "chain" outside of a class} { - list [catch {itcl::builtin::chain 1 2 3} err] $err -} {1 {cannot chain functions outside of a class context}} - -test chain-4.0 {[35a5baca67]} -setup { - unset -nocomplain ::answer - itcl::class B {method act args {lappend ::answer B}} - itcl::class D {inherit B; method act args {lappend ::answer D; chain}} -} -body { - [D d] act Now! - set ::answer -} -cleanup { - itcl::delete class B - unset -nocomplain ::answer -} -result {D B} - -# ---------------------------------------------------------------------- -# Clean up -# ---------------------------------------------------------------------- -itcl::delete class test_chain_d test_chain_c test_chain_b test_chain_a - -::tcltest::cleanupTests -return |