upvar.test

linux 下的源代码分析阅读器 red hat公司新版

#
# Tests for "upvar" across interpreter boundaries
# ----------------------------------------------------------------------
#   AUTHOR:  Michael J. McLennan
#            Bell Labs Innovations for Lucent Technologies
#            [e-mail]
#            http://www.tcltk.com/itcl
#
#      RCS:  $Id: upvar.test 144 2003-02-05 10:56:26Z mdejong $
# ----------------------------------------------------------------------
#            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