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