t/op/runlevel.t

   1 #!./perl
   2
   3 ##
   4 ## Many of these tests are originally from Michael Schroeder
   5 ## <Michael.Schroeder@informatik.uni-erlangen.de>
   6 ## Adapted and expanded by Gurusamy Sarathy <gsar@activestate.com>
   7 ##
   8
   9 chdir 't' if -d 't';
  10 @INC = '../lib';
  11 require './test.pl';
  12
  13 $|=1;
  14
  15 run_multiple_progs('', \*DATA);
  16
  17 done_testing();
  18
  19 __END__
  20 @a = (1, 2, 3);
  21 {
  22   @a = sort { last ; } @a;
  23 }
  24 EXPECT
  25 Can't "last" outside a loop block at - line 3.
  26 ########
  27 package TEST;
  28
  29 sub TIESCALAR {
  30   my $foo;
  31   return bless \$foo;
  32 }
  33 sub FETCH {
  34   eval 'die("test")';
  35   print "still in fetch\n";
  36   return ">$@<";
  37 }
  38 package main;
  39
  40 tie $bar, TEST;
  41 print "- $bar\n";
  42 EXPECT
  43 still in fetch
  44 - >test at (eval 1) line 1.
  45 <
  46 ########
  47 package TEST;
  48
  49 sub TIESCALAR {
  50   my $foo;
  51   eval('die("foo\n")');
  52   print "after eval\n";
  53   return bless \$foo;
  54 }
  55 sub FETCH {
  56   return "ZZZ";
  57 }
  58
  59 package main;
  60
  61 tie $bar, TEST;
  62 print "- $bar\n";
  63 print "OK\n";
  64 EXPECT
  65 after eval
  66 - ZZZ
  67 OK
  68 ########
  69 package TEST;
  70
  71 sub TIEHANDLE {
  72   my $foo;
  73   return bless \$foo;
  74 }
  75 sub PRINT {
  76 print STDERR "PRINT CALLED\n";
  77 (split(/./, 'x'x10000))[0];
  78 eval('die("test\n")');
  79 }
  80
  81 package main;
  82
  83 open FH, ">&STDOUT";
  84 tie *FH, TEST;
  85 print FH "OK\n";
  86 print STDERR "DONE\n";
  87 EXPECT
  88 PRINT CALLED
  89 DONE
  90 ########
  91 sub warnhook {
  92   print "WARNHOOK\n";
  93   eval('die("foooo\n")');
  94 }
  95 $SIG{'__WARN__'} = 'warnhook';
  96 warn("dfsds\n");
  97 print "END\n";
  98 EXPECT
  99 WARNHOOK
 100 END
 101 ########
 102 package TEST;
 103
 104 use overload
 105      "\"\""   =>  \&str
 106 ;
 107
 108 sub str {
 109   eval('die("test\n")');
 110   return "STR";
 111 }
 112
 113 package main;
 114
 115 $bar = bless {}, TEST;
 116 print "$bar\n";
 117 print "OK\n";
 118 EXPECT
 119 STR
 120 OK
 121 ########
 122 sub foo {
 123   $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
 124 }
 125 @a = (3, 2, 0, 1);
 126 @a = sort foo @a;
 127 print join(', ', @a)."\n";
 128 EXPECT
 129 0, 1, 2, 3
 130 ########
 131 sub foo {
 132   goto bar if $a == 0 || $b == 0;
 133   $a <=> $b;
 134 }
 135 @a = (3, 2, 0, 1);
 136 @a = sort foo @a;
 137 print join(', ', @a)."\n";
 138 exit;
 139 bar:
 140 print "bar reached\n";
 141 EXPECT
 142 Can't "goto" out of a pseudo block at - line 2.
 143 ########
 144 %seen = ();
 145 sub sortfn {
 146   (split(/./, 'x'x10000))[0];
 147   my (@y) = ( 4, 6, 5);
 148   @y = sort { $a <=> $b } @y;
 149   my $t = "sortfn ".join(', ', @y)."\n";
 150   print $t if ($seen{$t}++ == 0);
 151   return $_[0] <=> $_[1];
 152 }
 153 @x = ( 3, 2, 1 );
 154 @x = sort { &sortfn($a, $b) } @x;
 155 print "---- ".join(', ', @x)."\n";
 156 EXPECT
 157 sortfn 4, 5, 6
 158 ---- 1, 2, 3
 159 ########
 160 @a = (3, 2, 1);
 161 @a = sort { eval('die("no way")') ,  $a <=> $b} @a;
 162 print join(", ", @a)."\n";
 163 EXPECT
 164 1, 2, 3
 165 ########
 166 @a = (1, 2, 3);
 167 foo:
 168 {
 169   @a = sort { last foo; } @a;
 170 }
 171 EXPECT
 172 Label not found for "last foo" at - line 4.
 173 ########
 174 package TEST;
 175
 176 sub TIESCALAR {
 177   my $foo;
 178   return bless \$foo;
 179 }
 180 sub FETCH {
 181   next;
 182   return "ZZZ";
 183 }
 184 sub STORE {
 185 }
 186
 187 package main;
 188
 189 tie $bar, TEST;
 190 {
 191   print "- $bar\n";
 192 }
 193 print "OK\n";
 194 EXPECT
 195 Can't "next" outside a loop block at - line 8.
 196 ########
 197 package TEST;
 198
 199 sub TIESCALAR {
 200   my $foo;
 201   return bless \$foo;
 202 }
 203 sub FETCH {
 204   goto bbb;
 205   return "ZZZ";
 206 }
 207
 208 package main;
 209
 210 tie $bar, TEST;
 211 print "- $bar\n";
 212 exit;
 213 bbb:
 214 print "bbb\n";
 215 EXPECT
 216 Can't find label bbb at - line 8.
 217 ########
 218 sub foo {
 219   $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
 220 }
 221 @a = (3, 2, 0, 1);
 222 @a = sort foo @a;
 223 print join(', ', @a)."\n";
 224 EXPECT
 225 0, 1, 2, 3
 226 ########
 227 package TEST;
 228 sub TIESCALAR {
 229   my $foo;
 230   return bless \$foo;
 231 }
 232 sub FETCH {
 233   return "fetch";
 234 }
 235 sub STORE {
 236 (split(/./, 'x'x10000))[0];
 237 }
 238 package main;
 239 tie $bar, TEST;
 240 $bar = "x";
 241 ########
 242 package TEST;
 243 sub TIESCALAR {
 244   my $foo;
 245   next;
 246   return bless \$foo;
 247 }
 248 package main;
 249 {
 250 tie $bar, TEST;
 251 }
 252 EXPECT
 253 Can't "next" outside a loop block at - line 4.
 254 ########
 255 @a = (1, 2, 3);
 256 foo:
 257 {
 258   @a = sort { exit(0) } @a;
 259 }
 260 END { print "foobar\n" }
 261 EXPECT
 262 foobar
 263 ########
 264 $SIG{__DIE__} = sub {
 265     print "In DIE\n";
 266     $i = 0;
 267     while (($p,$f,$l,$s) = caller(++$i)) {
 268         print "$p|$f|$l|$s\n";
 269     }
 270 };
 271 eval { die };
 272 &{sub { eval 'die' }}();
 273 sub foo { eval { die } } foo();
 274 {package rmb; sub{ eval{die} } ->() };  # check __ANON__ knows package
 275 EXPECT
 276 In DIE
 277 main|-|8|(eval)
 278 In DIE
 279 main|-|9|(eval)
 280 main|-|9|main::__ANON__
 281 In DIE
 282 main|-|10|(eval)
 283 main|-|10|main::foo
 284 In DIE
 285 rmb|-|11|(eval)
 286 rmb|-|11|rmb::__ANON__
 287 ########
 288 package TEST;
 289
 290 sub TIEARRAY {
 291   return bless [qw(foo fee fie foe)], $_[0];
 292 }
 293 sub FETCH {
 294   my ($s,$i) = @_;
 295   if ($i) {
 296     goto bbb;
 297   }
 298 bbb:
 299   return $s->[$i];
 300 }
 301
 302 package main;
 303 tie my @bar, 'TEST';
 304 print join('|', @bar[0..3]), "\n";
 305 EXPECT
 306 foo|fee|fie|foe
 307 ########
 308 package TH;
 309 sub TIEHASH { bless {}, TH }
 310 sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" }
 311 tie %h, TH;
 312 eval { $h{A} = 1; print "never\n"; };
 313 print $@;
 314 eval { $h{B} = 2; };
 315 print $@;
 316 EXPECT
 317 A 1
 318 bar
 319 B 2
 320 bar
 321 ########
 322 sub n { 0 }
 323 sub f { my $x = shift; d(); }
 324 f(n());
 325 f();
 326
 327 sub d {
 328     my $i = 0; my @a;
 329     while (do { { package DB; @a = caller($i++) } } ) {
 330         @a = @DB::args;
 331         for (@a) { print "$_\n"; $_ = '' }
 332     }
 333 }
 334 EXPECT
 335 0
 336 ########
 337 sub TIEHANDLE { bless {} }
 338 sub PRINT { next }
 339
 340 tie *STDERR, '';
 341 { map ++$_, 1 }
 342
 343 EXPECT
 344 Can't "next" outside a loop block at - line 2.
 345 ########
 346 sub TIEHANDLE { bless {} }
 347 sub PRINT { print "[TIE] $_[1]" }
 348
 349 tie *STDERR, '';
 350 die "DIE\n";
 351
 352 EXPECT
 353 [TIE] DIE
 354 ########
 355 sub TIEHANDLE { bless {} }
 356 sub PRINT {
 357     (split(/./, 'x'x10000))[0];
 358     eval('die("test\n")');
 359     warn "[TIE] $_[1]";
 360 }
 361 open OLDERR, '>&STDERR';
 362 tie *STDERR, '';
 363
 364 use warnings FATAL => qw(uninitialized);
 365 print undef;
 366
 367 EXPECT
 368 [TIE] Use of uninitialized value in print at - line 11.