summaryrefslogtreecommitdiffstats
path: root/tcl8.6/pkgs/itcl4.1.1/tests/chain.test
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2019-07-31 17:50:24 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2019-07-31 17:50:24 (GMT)
commitde0c57b4383a4d7ced5058c2c50580a0f4ba5477 (patch)
treeed9f83c4262ccc3cd22a3cf8ad5ad18f197f7d63 /tcl8.6/pkgs/itcl4.1.1/tests/chain.test
parent4f9885152c6e8eef1a01e2cc50fa4e3db8bbcb5c (diff)
downloadblt-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.test166
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