#
|
#
|
# Tests for "uplevel" across interpreter boundaries
|
# Tests for "uplevel" across interpreter boundaries
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# AUTHOR: Michael J. McLennan
|
# AUTHOR: Michael J. McLennan
|
# Bell Labs Innovations for Lucent Technologies
|
# Bell Labs Innovations for Lucent Technologies
|
# mmclennan@lucent.com
|
# mmclennan@lucent.com
|
# http://www.tcltk.com/itcl
|
# http://www.tcltk.com/itcl
|
#
|
#
|
# RCS: $Id: uplevel.test,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $
|
# RCS: $Id: uplevel.test,v 1.1.1.1 2002-01-16 10:24:47 markom Exp $
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
|
# ======================================================================
|
# ======================================================================
|
# See the file "license.terms" for information on usage and
|
# See the file "license.terms" for information on usage and
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# DEFINE SOME USEFUL ROUTINES
|
# DEFINE SOME USEFUL ROUTINES
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
proc uplevelTest_show_var {level var} {
|
proc uplevelTest_show_var {level var} {
|
return "$var>>[uplevel $level set $var]"
|
return "$var>>[uplevel $level set $var]"
|
}
|
}
|
|
|
proc uplevelTest_do {cmd} {
|
proc uplevelTest_do {cmd} {
|
eval $cmd
|
eval $cmd
|
}
|
}
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# CREATE SOME OBJECTS
|
# CREATE SOME OBJECTS
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
Foo foo
|
Foo foo
|
Baz baz
|
Baz baz
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# UPLEVEL TESTS (main interp)
|
# UPLEVEL TESTS (main interp)
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
test {"uplevel" can access global variables (via relative level)} {
|
test {"uplevel" can access global variables (via relative level)} {
|
set globalvar "global value"
|
set globalvar "global value"
|
uplevelTest_show_var 1 globalvar
|
uplevelTest_show_var 1 globalvar
|
} {
|
} {
|
$result == "globalvar>>global value"
|
$result == "globalvar>>global value"
|
}
|
}
|
|
|
test {"uplevel" can access global variables (via "#0")} {
|
test {"uplevel" can access global variables (via "#0")} {
|
set globalvar "global value"
|
set globalvar "global value"
|
uplevelTest_show_var #0 globalvar
|
uplevelTest_show_var #0 globalvar
|
} {
|
} {
|
$result == "globalvar>>global value"
|
$result == "globalvar>>global value"
|
}
|
}
|
|
|
test {"uplevel" can access local variables (via relative level)} {
|
test {"uplevel" can access local variables (via relative level)} {
|
uplevelTest_do {
|
uplevelTest_do {
|
set localvar "local value"
|
set localvar "local value"
|
uplevelTest_show_var 1 localvar
|
uplevelTest_show_var 1 localvar
|
}
|
}
|
} {
|
} {
|
$result == "localvar>>local value"
|
$result == "localvar>>local value"
|
}
|
}
|
|
|
test {"uplevel" can access local variables (via relative level)} {
|
test {"uplevel" can access local variables (via relative level)} {
|
uplevelTest_do {
|
uplevelTest_do {
|
set localvar "proper value"
|
set localvar "proper value"
|
uplevelTest_do {
|
uplevelTest_do {
|
set localvar "not this one"
|
set localvar "not this one"
|
uplevelTest_show_var 2 localvar
|
uplevelTest_show_var 2 localvar
|
}
|
}
|
}
|
}
|
} {
|
} {
|
$result == "localvar>>proper value"
|
$result == "localvar>>proper value"
|
}
|
}
|
|
|
test {"uplevel" can access local variables (via explicit level)} {
|
test {"uplevel" can access local variables (via explicit level)} {
|
uplevelTest_do {
|
uplevelTest_do {
|
set localvar "local value"
|
set localvar "local value"
|
uplevelTest_show_var #1 localvar
|
uplevelTest_show_var #1 localvar
|
}
|
}
|
} {
|
} {
|
$result == "localvar>>local value"
|
$result == "localvar>>local value"
|
}
|
}
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# UPLEVEL TESTS (across class interps)
|
# UPLEVEL TESTS (across class interps)
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
test {"uplevel" can cross class interps to access global variables} {
|
test {"uplevel" can cross class interps to access global variables} {
|
set globalvar "global value"
|
set globalvar "global value"
|
foo do {
|
foo do {
|
uplevel #0 uplevelTest_show_var 1 globalvar
|
uplevel #0 uplevelTest_show_var 1 globalvar
|
}
|
}
|
} {
|
} {
|
$result == "Foo says 'globalvar>>global value'"
|
$result == "Foo says 'globalvar>>global value'"
|
}
|
}
|
|
|
test {"uplevel" can cross several class interps to access global variables} {
|
test {"uplevel" can cross several class interps to access global variables} {
|
set globalvar "global value"
|
set globalvar "global value"
|
baz do {
|
baz do {
|
foo do {
|
foo do {
|
uplevel 2 uplevelTest_show_var #0 globalvar
|
uplevel 2 uplevelTest_show_var #0 globalvar
|
}
|
}
|
}
|
}
|
} {
|
} {
|
$result == "Baz says 'Foo says 'globalvar>>global value''"
|
$result == "Baz says 'Foo says 'globalvar>>global value''"
|
}
|
}
|
|
|
test {"uplevel" finds proper scope for execution} {
|
test {"uplevel" finds proper scope for execution} {
|
baz do {
|
baz do {
|
foo do {
|
foo do {
|
uplevel do {{info class}}
|
uplevel do {{info class}}
|
}
|
}
|
}
|
}
|
} {
|
} {
|
$result == "Baz says 'Foo says 'Baz says '::Baz'''"
|
$result == "Baz says 'Foo says 'Baz says '::Baz'''"
|
}
|
}
|
|
|
test {"uplevel" finds proper scope for execution,
|
test {"uplevel" finds proper scope for execution,
|
and works in conjunction with "unknown" to access
|
and works in conjunction with "unknown" to access
|
commands at the global scope with local call frames} {
|
commands at the global scope with local call frames} {
|
baz do {
|
baz do {
|
set bazvar "value in Baz"
|
set bazvar "value in Baz"
|
foo do {
|
foo do {
|
uplevel ::info locals
|
uplevel ::info locals
|
}
|
}
|
}
|
}
|
} {
|
} {
|
$result == "Baz says 'Foo says 'bazvar cmds''"
|
$result == "Baz says 'Foo says 'bazvar cmds''"
|
}
|
}
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# LEVEL TESTS (across class scopes)
|
# LEVEL TESTS (across class scopes)
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
test {"info level" works across scope boundaries} {
|
test {"info level" works across scope boundaries} {
|
baz do {
|
baz do {
|
foo do {
|
foo do {
|
info level
|
info level
|
}
|
}
|
}
|
}
|
} {
|
} {
|
$result == "Baz says 'Foo says '2''"
|
$result == "Baz says 'Foo says '2''"
|
}
|
}
|
|
|
test {"info level" works across scope boundaries} {
|
test {"info level" works across scope boundaries} {
|
baz do {
|
baz do {
|
foo do {
|
foo do {
|
info level 0
|
info level 0
|
}
|
}
|
}
|
}
|
} {
|
} {
|
$result == "Baz says 'Foo says 'do {
|
$result == "Baz says 'Foo says 'do {
|
info level 0
|
info level 0
|
}''"
|
}''"
|
}
|
}
|
|
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
# CLEAN UP
|
# CLEAN UP
|
# ----------------------------------------------------------------------
|
# ----------------------------------------------------------------------
|
foo delete
|
foo delete
|
baz delete
|
baz delete
|
|
|
