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