t/op/my.t

   1 #!./perl
   2 BEGIN {
   3     chdir 't' if -d 't';
   4     require './test.pl';
   5     set_up_inc('../lib');
   6 }
   7
   8 sub foo {
   9     my($a, $b) = @_;
  10     my $c;
  11     my $d;
  12     $c = "ok 3\n";
  13     $d = "ok 4\n";
  14     { my($a, undef, $c) = ("ok 9\n", "not ok 10\n", "ok 10\n");
  15       ($x, $y) = ($a, $c); }
  16     is($a, "ok 1\n", 'value of sub argument maintained outside of block');
  17     is($b, "ok 2\n", 'sub argument maintained');
  18     is($c, "ok 3\n", 'variable value maintained outside of block');
  19     is($d, "ok 4\n", 'variable value maintained');
  20 }
  21
  22 $a = "ok 5\n";
  23 $b = "ok 6\n";
  24 $c = "ok 7\n";
  25 $d = "ok 8\n";
  26
  27 &foo("ok 1\n","ok 2\n");
  28
  29 is($a, "ok 5\n", 'global was not affected by duplicate names inside subroutine');
  30 is($b, "ok 6\n", '...');
  31 is($c, "ok 7\n", '...');
  32 is($d, "ok 8\n", '...');
  33 is($x, "ok 9\n", 'globals modified inside of block keeps its value outside of block');
  34 is($y, "ok 10\n", '...');
  35
  36 # same thing, only with arrays and associative arrays
  37
  38 sub foo2 {
  39     my($a, @b) = @_;
  40     my(@c, %d);
  41     @c = "ok 13\n";
  42     $d{''} = "ok 14\n";
  43     { my($a,@c) = ("ok 19\n", "ok 20\n", "ok 21\n"); ($x, $y) = ($a, @c); }
  44     is($a, "ok 11\n", 'value of sub argument maintained outside of block');
  45     is(scalar @b, 1, 'did not add any elements to @b');
  46     is($b[0], "ok 12\n", 'did not alter @b');
  47     is(scalar @c, 1, 'did not add arguments to @c');
  48     is($c[0], "ok 13\n", 'did not alter @c');
  49     is($d{''}, "ok 14\n", 'did not touch %d');
  50 }
  51
  52 $a = "ok 15\n";
  53 @b = "ok 16\n";
  54 @c = "ok 17\n";
  55 $d{''} = "ok 18\n";
  56
  57 &foo2("ok 11\n", "ok 12\n");
  58
  59 is($a, "ok 15\n", 'Global was not modifed out of scope');
  60 is(scalar @b, 1, 'correct number of elements in array');
  61 is($b[0], "ok 16\n", 'array value was not modified out of scope');
  62 is(scalar @c, 1, 'correct number of elements in array');
  63 is($c[0], "ok 17\n", 'array value was not modified out of scope');
  64 is($d{''}, "ok 18\n", 'hash key/value pair is correct');
  65 is($x, "ok 19\n", 'global was modified');
  66 is($y, "ok 20\n", 'this one too');
  67
  68 my $i = "outer";
  69
  70 if (my $i = "inner") {
  71     is( $i, 'inner', 'my variable inside conditional propagates inside block');
  72 }
  73
  74 if ((my $i = 1) == 0) {
  75     fail("nested parens do not propagate variable outside");
  76 }
  77 else {
  78     is($i, 1, 'lexical variable lives available inside else block');
  79 }
  80
  81 my $j = 5;
  82 while (my $i = --$j) {
  83     last unless is( $i, $j, 'lexical inside while block');
  84 }
  85 continue {
  86     last unless is( $i, $j, 'lexical inside continue block');
  87 }
  88 is( $j, 0, 'went through the previous while/continue loop all 4 times' );
  89
  90 $j = 5;
  91 for (my $i = 0; (my $k = $i) < $j; ++$i) {
  92     fail(""), last unless $i >= 0 && $i < $j && $i == $k;
  93 }
  94 ok( ! defined $k, '$k is only defined in the scope of the previous for loop' );
  95
  96 curr_test(37);
  97 $jj = 0;
  98 foreach my $i (30, 31) {
  99     is( $i, $jj+30, 'assignment inside the foreach loop variable definition');
 100     $jj++;
 101 }
 102 is( $jj, 2, 'foreach loop executed twice');
 103
 104 is( $i, 'outer', '$i not modified by while/for/foreach using same variable name');
 105
 106 # Ensure that C<my @y> (without parens) doesn't force scalar context.
 107 my @x;
 108 { @x = my @y }
 109 is(scalar @x, 0, 'my @y without parens does not force scalar context');
 110 { @x = my %y }
 111 is(scalar @x, 0, 'my %y without parens does not force scalar context');
 112
 113 # Found in HTML::FormatPS
 114 my %fonts = qw(nok 35);
 115 for my $full (keys %fonts) {
 116     $full =~ s/^n//;
 117     is( $fonts{nok}, 35, 'Supposed to be copy-on-write via force_normal after a THINKFIRST check.' );
 118 }
 119
 120 #  [perl #29340] optimising away the = () left the padav returning the
 121 # array rather than the contents, leading to 'Bizarre copy of array' error
 122
 123 sub opta { my @a=() }
 124 sub opth { my %h=() }
 125 eval { my $x = opta };
 126 is($@, '', ' perl #29340, No bizarre copy of array error');
 127 eval { my $x = opth };
 128 is($@, '', ' perl #29340, No bizarre copy of array error via hash');
 129
 130 sub foo3 {
 131     ++my $x->{foo};
 132     ok(! defined $x->{bar}, '$x->{bar} is not defined');
 133     ++$x->{bar};
 134 }
 135 eval { foo3(); foo3(); };
 136 is( $@, '', 'no errors while checking autovivification and persistence of hash refs inside subs' );
 137
 138 # my $foo = undef should always assign [perl #37776]
 139 {
 140     my $count = 35;
 141     loop:
 142     my $test = undef;
 143     is($test, undef, 'var is undef, repeated test');
 144     $test = 42;
 145     goto loop if ++$count < 37;
 146 }
 147
 148 # [perl #113554]
 149 eval "my ()";
 150 is( $@, '', "eval of my() passes");
 151
 152 # RT #126844
 153 # This triggered a compile-time assert failure in rpeep()
 154 eval 'my($a,$b),$x,my($c,$d)';
 155 pass("RT #126844");
 156
 157 #Variable number of tests due to the way the while/for loops are tested now
 158 done_testing();