itcl/itcl/tests/old/upvar.test

   1 #
   2 # Tests for "upvar" across interpreter boundaries
   3 # ----------------------------------------------------------------------
   4 #   AUTHOR:  Michael J. McLennan
   5 #            Bell Labs Innovations for Lucent Technologies
   6 #            mmclennan@lucent.com
   7 #            http://www.tcltk.com/itcl
   8 #
   9 #      RCS:  $Id$
  10 # ----------------------------------------------------------------------
  11 #            Copyright (c) 1993-1998  Lucent Technologies, Inc.
  12 # ======================================================================
  13 # See the file "license.terms" for information on usage and
  14 # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15
  16 # ----------------------------------------------------------------------
  17 #  DEFINE SOME USEFUL ROUTINES
  18 # ----------------------------------------------------------------------
  19 proc upvarTest_show_var {var val} {
  20         return "$var>>$val"
  21 }
  22
  23 proc upvarTest_upvar_in_procs {} {
  24         set upvarTest_var_local "value in main interp"
  25         foo do {
  26                 upvar upvarTest_var_local var
  27                 set var
  28         }
  29 }
  30
  31 # ----------------------------------------------------------------------
  32 #  CREATE SOME OBJECTS
  33 # ----------------------------------------------------------------------
  34 Foo foo
  35 Baz baz
  36
  37 # ----------------------------------------------------------------------
  38 #  UPVAR TESTS
  39 # ----------------------------------------------------------------------
  40 test {"::" sends command to global interp but preserves
  41 local variables.  This ensures that when control
  42 shifts to the global scope for Extended Tcl commands,
  43 Expect commands, etc., local variables will be
  44 recognized.} {
  45         foo do {
  46                 set localvar "special"
  47                 ::eval {upvarTest_show_var localvar $localvar}
  48         }
  49 } {
  50         $result == "Foo says 'localvar>>special'"
  51 }
  52
  53
  54 test {"upvar" can cross interp boundaries to access local variables} {
  55         upvarTest_upvar_in_procs
  56 } {
  57         $result == "Foo says 'value in main interp'"
  58 }
  59
  60 test {"upvar" can cross interp boundaries to access global variables} {
  61         set upvarTest_var_global "value in main interp"
  62         foo do {
  63                 upvar upvarTest_var_global var
  64                 set var
  65         }
  66 } {
  67         $result == "Foo says 'value in main interp'"
  68 }
  69
  70 test {"upvar" can handle multiple call frames on the stack} {
  71         set upvarTest_var_global "new value"
  72         foo do {
  73                 foo do {
  74                         upvar #0 upvarTest_var_global var
  75                         set var
  76                 }
  77         }
  78 } {
  79         $result == "Foo says 'Foo says 'new value''"
  80 }
  81
  82 test {"upvar" can cross class interp boundaries} {
  83         baz do {
  84                 set localvar "value in Baz"
  85                 foo do {
  86                         upvar localvar var
  87                         set var
  88                 }
  89         }
  90 } {
  91         $result == "Baz says 'Foo says 'value in Baz''"
  92 }
  93
  94 test {"upvar" can cross class interp boundaries back to main interp} {
  95         set upvarTest_var_global "global value"
  96         baz do {
  97                 foo do {
  98                         upvar 2 upvarTest_var_global var
  99                         set var
 100                 }
 101         }
 102 } {
 103         $result == "Baz says 'Foo says 'global value''"
 104 }
 105
 106 # ----------------------------------------------------------------------
 107 #  CLEAN UP
 108 # ----------------------------------------------------------------------
 109 foo delete
 110 baz delete