OpenFPGA/libs/EXTERNAL/tcl8.6.12/pkgs/itcl4.2.2/tests/chain.test

#
# 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