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