tests/uplevel.test

   1 # Commands covered:  uplevel
   2 #
   3 # This file contains a collection of tests for one or more of the Tcl
   4 # built-in commands.  Sourcing this file into Tcl runs the tests and
   5 # generates output for errors.  No output means no errors were found.
   6 #
   7 # Copyright (c) 1991-1993 The Regents of the University of California.
   8 # Copyright (c) 1994 Sun Microsystems, Inc.
   9 # Copyright (c) 1998-1999 by Scriptics Corporation.
  10 #
  11 # See the file "license.terms" for information on usage and redistribution
  12 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13 #
  14 # RCS: @(#) $Id: uplevel.test,v 1.6 2000/04/10 17:19:05 ericm Exp $
  15
  16 source [file dirname [info script]]/testing.tcl
  17
  18 proc a {x y} {
  19     newset z [expr $x+$y]
  20     return $z
  21 }
  22 proc newset {name value} {
  23     uplevel set $name $value
  24     uplevel 1 {uplevel 1 {set xyz 22}}
  25 }
  26 proc b {x y} {
  27     uplevel #0 set $x $y
  28 }
  29
  30 test uplevel-1.1 {simple operation} {
  31     set xyz 0
  32     a 22 33
  33 } 55
  34 test uplevel-1.2 {command is another uplevel command} {
  35     set xyz 0
  36     a 22 33
  37     set xyz
  38 } 22
  39
  40 proc a1 {} {
  41     b1
  42     global a a1
  43     set a $x
  44     set a1 $y
  45 }
  46 proc b1 {} {
  47     c1
  48     global b b1
  49     set b $x
  50     set b1 $y
  51 }
  52 proc c1 {} {
  53     uplevel 1 set x 111
  54     uplevel #2 set y 222
  55     uplevel 2 set x 333
  56     uplevel #1 set y 444
  57     uplevel 3 set x 555
  58     uplevel #0 set y 666
  59 }
  60 a1
  61 test uplevel-2.1 {relative and absolute uplevel} {set a} 333
  62 test uplevel-2.2 {relative and absolute uplevel} {set a1} 444
  63 test uplevel-2.3 {relative and absolute uplevel} {set b} 111
  64 test uplevel-2.4 {relative and absolute uplevel} {set b1} 222
  65 test uplevel-2.5 {relative and absolute uplevel} {set x} 555
  66 test uplevel-2.6 {relative and absolute uplevel} {set y} 666
  67
  68 test uplevel-3.1 {uplevel to same level} {
  69     set x 33
  70     uplevel #0 set x 44
  71     set x
  72 } 44
  73 test uplevel-3.2 {uplevel to same level} {
  74     set x 33
  75     uplevel 0 set x
  76 } 33
  77 test uplevel-3.3 {uplevel to same level} {
  78     set y xxx
  79     proc a1 {} {set y 55; uplevel 0 set y 66; return $y}
  80     a1
  81 } 66
  82 test uplevel-3.4 {uplevel to same level} {
  83     set y zzz
  84     proc a1 {} {set y 55; uplevel #1 set y}
  85     a1
  86 } 55
  87
  88 test uplevel-4.1 {error check: non-existent level} {
  89     list [catch c1 msg] $msg
  90 } {1 {bad level "#2"}}
  91 test uplevel-4.2 {error check: non-existent level} {
  92     proc c2 {} {uplevel 3 {set a b}}
  93     list [catch c2 msg] $msg
  94 } {1 {bad level "3"}}
  95 test uplevel-4.3 {error check: not enough args} {
  96     list [catch uplevel msg] $msg
  97 } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
  98 test uplevel-4.4 {error check: not enough args} {
  99     proc upBug {} {uplevel 1}
 100     list [catch upBug msg] $msg
 101 } {1 {wrong # args: should be "uplevel ?level? command ?arg ...?"}}
 102
 103 proc a2 {} {
 104     uplevel a3
 105 }
 106 proc a3 {} {
 107     global x y
 108     set x [info level]
 109     set y [info level 1]
 110 }
 111 a2
 112 test uplevel-5.1 {info level} {set x} 1
 113 test uplevel-5.2 {info level} {set y} a3
 114
 115 test uplevel-6.1 {uplevel #0} {
 116     b g1 g1val
 117     set ::g1
 118 } g1val
 119
 120 test uplevel-6.2 {uplevel #bad} {
 121     catch {uplevel #bad set x 1}
 122 } 1
 123
 124 testreport