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