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