languages/tcl/t/cmd_uplevel.t

   1 #! perl
   2
   3 # Copyright (C) 2006-2007, The Perl Foundation.
   4 # $Id$
   5
   6 use strict;
   7 use warnings;
   8 use lib qw(tcl/lib ./lib ../lib ../../lib ../../../lib);
   9
  10 use Parrot::Test tests => 10;
  11 use Test::More;
  12
  13 language_output_is( "tcl", <<'TCL', <<'OUT', 'upvar $command' );
  14   proc test {} {uplevel {set a 42}}
  15   test
  16   puts $a
  17 TCL
  18 42
  19 OUT
  20
  21 language_output_is( "tcl", <<'TCL', <<'OUT', "uplevel - bad args" );
  22   uplevel
  23 TCL
  24 wrong # args: should be "uplevel ?level? command ?arg ...?"
  25 OUT
  26
  27 language_output_is( 'tcl', <<'TCL', <<'OUT', 'uplevel - bad args' );
  28   uplevel 0
  29 TCL
  30 wrong # args: should be "uplevel ?level? command ?arg ...?"
  31 OUT
  32
  33 language_output_is( "tcl", <<'TCL', <<'OUT', "uplevel - bad level" );
  34   uplevel a b
  35 TCL
  36 bad level "a"
  37 OUT
  38
  39 language_output_is( "tcl", <<'TCL', <<'OUT', "uplevel 0" );
  40   proc test {} {uplevel 0 {set a 42}; puts $a}
  41   test
  42 TCL
  43 42
  44 OUT
  45
  46 language_output_is( "tcl", <<'TCL', <<'OUT', "uplevel #0" );
  47   proc a {} {uplevel #0 {set a 42}}
  48   proc b {} {a}
  49   a
  50   puts $a
  51 TCL
  52 42
  53 OUT
  54
  55 language_output_is( "tcl", <<'TCL', <<'OUT', "uplevel - from one lexical to another" );
  56   proc add2to_a {} {uplevel {set a [expr {$a+2}]}}
  57   proc test {} { set a 1; add2to_a; puts $a }
  58   test
  59 TCL
  60 3
  61 OUT
  62
  63 language_output_is( 'tcl',
  64     <<'TCL', <<'OUT', 'uplevel - from one lexical in an uplevel to another' );
  65 proc test {} {
  66     set ok 0
  67     level1
  68     puts $ok
  69 }
  70 proc level1 {} {
  71     uplevel #0 deep1
  72 }
  73 proc deep1 {} {
  74     set ok 0
  75     deep2
  76     puts $ok
  77 }
  78 proc deep2 {} {
  79     uplevel 1 {set ok 1}
  80 }
  81 test
  82 TCL
  83 1
  84 0
  85 OUT
  86
  87 language_output_is( 'tcl', <<'TCL', <<'OUT', 'uplevel - reset environent on execption' );
  88   proc test {} {catch {uplevel #0 {error "foo"}}}
  89   set a 4
  90   test
  91   puts $a
  92 TCL
  93 4
  94 OUT
  95
  96 language_output_is( 'tcl', <<'TCL', <<'OUT', 'uplevel - info level interaction' );
  97   proc test {} {uplevel {info level}}
  98   puts [test]
  99 TCL
 100 0
 101 OUT
 102
 103 # Local Variables:
 104 #   mode: cperl
 105 #   cperl-indent-level: 4
 106 #   fill-column: 100
 107 # End:
 108 # vim: expandtab shiftwidth=4: