t/op/do.t

   1 #!./perl
   2
   3 sub foo1
   4 {
   5     ok($_[0]);
   6     'value';
   7 }
   8
   9 sub foo2
  10 {
  11     shift;
  12     ok($_[0]);
  13     $x = 'value';
  14     $x;
  15 }
  16
  17 my $test = 1;
  18 sub ok {
  19     my($ok, $name) = @_;
  20
  21     # You have to do it this way or VMS will get confused.
  22     printf "%s %d%s\n", $ok ? "ok" : "not ok",
  23                         $test,
  24                         defined $name ? " - $name" : '';
  25
  26     printf "# Failed test at line %d\n", (caller)[2] unless $ok;
  27
  28     $test++;
  29     return $ok;
  30 }
  31
  32 print "1..50\n";
  33
  34 # Test do &sub and proper @_ handling.
  35 $_[0] = 0;
  36 {
  37     no warnings 'deprecated';
  38     $result = do foo1(1);
  39 }
  40
  41 ok( $result eq 'value',  ":$result: eq :value:" );
  42 ok( $_[0] == 0 );
  43
  44 $_[0] = 0;
  45 {
  46     no warnings 'deprecated';
  47     $result = do foo2(0,1,0);
  48 }
  49 ok( $result eq 'value', ":$result: eq :value:" );
  50 ok( $_[0] == 0 );
  51
  52 $result = do{ ok 1; 'value';};
  53 ok( $result eq 'value',  ":$result: eq :value:" );
  54
  55 sub blather {
  56     ok 1 foreach @_;
  57 }
  58
  59 {
  60     no warnings 'deprecated';
  61     do blather("ayep","sho nuff");
  62 }
  63 @x = ("jeepers", "okydoke");
  64 @y = ("uhhuh", "yeppers");
  65 {
  66     no warnings 'deprecated';
  67     do blather(@x,"noofie",@y);
  68 }
  69
  70 unshift @INC, '.';
  71
  72 if (open(DO, ">$$.16")) {
  73     print DO "ok(1, 'do in scalar context') if defined wantarray && not wantarray\n";
  74     close DO or die "Could not close: $!";
  75 }
  76
  77 my $a = do "$$.16"; die $@ if $@;
  78
  79 if (open(DO, ">$$.17")) {
  80     print DO "ok(1, 'do in list context') if defined wantarray &&     wantarray\n";
  81     close DO or die "Could not close: $!";
  82 }
  83
  84 my @a = do "$$.17"; die $@ if $@;
  85
  86 if (open(DO, ">$$.18")) {
  87     print DO "ok(1, 'do in void context') if not defined wantarray\n";
  88     close DO or die "Could not close: $!";
  89 }
  90
  91 do "$$.18"; die $@ if $@;
  92
  93 # bug ID 20010920.007
  94 eval qq{ do qq(a file that does not exist); };
  95 ok( !$@, "do on a non-existing file, first try" );
  96
  97 eval qq{ do uc qq(a file that does not exist); };
  98 ok( !$@, "do on a non-existing file, second try"  );
  99
 100 # 6 must be interpreted as a file name here
 101 ok( (!defined do 6) && $!, "'do 6' : $!" );
 102
 103 # [perl #19545]
 104 push @t, ($u = (do {} . "This should be pushed."));
 105 ok( $#t == 0, "empty do result value" );
 106
 107 $zok = '';
 108 $owww = do { 1 if $zok };
 109 ok( $owww eq '', 'last is unless' );
 110 $owww = do { 2 unless not $zok };
 111 ok( $owww == 1, 'last is if not' );
 112
 113 $zok = 'swish';
 114 $owww = do { 3 unless $zok };
 115 ok( $owww eq 'swish', 'last is unless' );
 116 $owww = do { 4 if not $zok };
 117 ok( $owww eq '', 'last is if not' );
 118
 119 # [perl #38809]
 120 @a = (7);
 121 $x = sub { do { return do { @a } }; 2 }->();
 122 ok(defined $x && $x == 1, 'return do { } receives caller scalar context');
 123 @x = sub { do { return do { @a } }; 2 }->();
 124 ok("@x" eq "7", 'return do { } receives caller list context');
 125
 126 @a = (7, 8);
 127 $x = sub { do { return do { 1; @a } }; 3 }->();
 128 ok(defined $x && $x == 2, 'return do { ; } receives caller scalar context');
 129 @x = sub { do { return do { 1; @a } }; 3 }->();
 130 ok("@x" eq "7 8", 'return do { ; } receives caller list context');
 131
 132 @b = (11 .. 15);
 133 $x = sub { do { return do { 1; @a, @b } }; 3 }->();
 134 ok(defined $x && $x == 5, 'return do { ; , } receives caller scalar context');
 135 @x = sub { do { return do { 1; @a, @b } }; 3 }->();
 136 ok("@x" eq "7 8 11 12 13 14 15", 'return do { ; , } receives caller list context');
 137
 138 $x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
 139 ok(defined $x && $x == 5, 'return do { ; }, do { ; } receives caller scalar context');
 140 @x = sub { do { return do { 1; @a }, do { 2; @b } }; 3 }->();
 141 ok("@x" eq "7 8 11 12 13 14 15", 'return do { ; }, do { ; } receives caller list context');
 142
 143 @a = (7, 8, 9);
 144 $x = sub { do { do { 1; return @a } }; 4 }->();
 145 ok(defined $x && $x == 3, 'do { return } receives caller scalar context');
 146 @x = sub { do { do { 1; return @a } }; 4 }->();
 147 ok("@x" eq "7 8 9", 'do { return } receives caller list context');
 148
 149 @a = (7, 8, 9, 10);
 150 $x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
 151 ok(defined $x && $x == 4, 'return do { do { ; } } receives caller scalar context');
 152 @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
 153 ok("@x" eq "7 8 9 10", 'return do { do { ; } } receives caller list context');
 154
 155 # Do blocks created by constant folding
 156 # [perl #68108]
 157 $x = sub { if (1) { 20 } }->();
 158 ok($x == 20, 'if (1) { $x } receives caller scalar context');
 159
 160 @a = (21 .. 23);
 161 $x = sub { if (1) { @a } }->();
 162 ok($x == 3, 'if (1) { @a } receives caller scalar context');
 163 @x = sub { if (1) { @a } }->();
 164 ok("@x" eq "21 22 23", 'if (1) { @a } receives caller list context');
 165
 166 $x = sub { if (1) { 0; 20 } }->();
 167 ok($x == 20, 'if (1) { ...; $x } receives caller scalar context');
 168
 169 @a = (24 .. 27);
 170 $x = sub { if (1) { 0; @a } }->();
 171 ok($x == 4, 'if (1) { ...; @a } receives caller scalar context');
 172 @x = sub { if (1) { 0; @a } }->();
 173 ok("@x" eq "24 25 26 27", 'if (1) { ...; @a } receives caller list context');
 174
 175 $x = sub { if (1) { 0; 20 } else{} }->();
 176 ok($x == 20, 'if (1) { ...; $x } else{} receives caller scalar context');
 177
 178 @a = (24 .. 27);
 179 $x = sub { if (1) { 0; @a } else{} }->();
 180 ok($x == 4, 'if (1) { ...; @a } else{} receives caller scalar context');
 181 @x = sub { if (1) { 0; @a } else{} }->();
 182 ok("@x" eq "24 25 26 27", 'if (1) { ...; @a } else{} receives caller list context');
 183
 184 $x = sub { if (0){} else { 0; 20 } }->();
 185 ok($x == 20, 'if (0){} else { ...; $x } receives caller scalar context');
 186
 187 @a = (24 .. 27);
 188 $x = sub { if (0){} else { 0; @a } }->();
 189 ok($x == 4, 'if (0){} else { ...; @a } receives caller scalar context');
 190 @x = sub { if (0){} else { 0; @a } }->();
 191 ok("@x" eq "24 25 26 27", 'if (0){} else { ...; @a } receives caller list context');
 192
 193
 194 END {
 195     1 while unlink("$$.16", "$$.17", "$$.18");
 196 }