t/op/runlevel.t

   1 #!./perl
   2
   3 ##
   4 ## all of these tests are from Michael Schroeder
   5 ## <Michael.Schroeder@informatik.uni-erlangen.de>
   6 ##
   7 ## The more esoteric failure modes require Michael's
   8 ## stack-of-stacks patch (so we don't test them here,
   9 ## and they are commented out before the __END__).
  10 ##
  11 ## The remaining tests pass with a simpler fix
  12 ## intended for 5.004
  13 ##
  14 ## Gurusamy Sarathy <gsar@umich.edu> 97-02-24
  15 ##
  16
  17 chdir 't' if -d 't';
  18 @INC = "../lib";
  19 $Is_VMS = $^O eq 'VMS';
  20 $Is_MSWin32 = $^O eq 'MSWin32';
  21 $ENV{PERL5LIB} = "../lib" unless $Is_VMS;
  22
  23 $|=1;
  24
  25 undef $/;
  26 @prgs = split "\n########\n", <DATA>;
  27 print "1..", scalar @prgs, "\n";
  28
  29 $tmpfile = "runltmp000";
  30 1 while -f ++$tmpfile;
  31 END { if ($tmpfile) { 1 while unlink $tmpfile; } }
  32
  33 for (@prgs){
  34     my $switch;
  35     if (s/^\s*(-\w+)//){
  36        $switch = $1;
  37     }
  38     my($prog,$expected) = split(/\nEXPECT\n/, $_);
  39     open TEST, ">$tmpfile";
  40     print TEST "$prog\n";
  41     close TEST;
  42     my $results = $Is_VMS ?
  43                   `MCR $^X "-I[-.lib]" $switch $tmpfile` :
  44                       $Is_MSWin32 ?
  45                           `.\\perl -I../lib $switch $tmpfile 2>&1` :
  46                               `sh -c './perl $switch $tmpfile' 2>&1`;
  47     my $status = $?;
  48     $results =~ s/\n+$//;
  49     # allow expected output to be written as if $prog is on STDIN
  50     $results =~ s/runltmp\d+/-/g;
  51     $results =~ s/\n%[A-Z]+-[SIWEF]-.*$// if $Is_VMS;  # clip off DCL status msg
  52     $expected =~ s/\n+$//;
  53     if ($results ne $expected) {
  54        print STDERR "PROG: $switch\n$prog\n";
  55        print STDERR "EXPECTED:\n$expected\n";
  56        print STDERR "GOT:\n$results\n";
  57        print "not ";
  58     }
  59     print "ok ", ++$i, "\n";
  60 }
  61
  62 =head2 stay out of here (the real tests are after __END__)
  63
  64 ##
  65 ## these tests don't pass yet (need the full stack-of-stacks patch)
  66 ## GSAR 97-02-24
  67 ##
  68
  69 ########
  70 # sort within sort
  71 sub sortfn {
  72   (split(/./, 'x'x10000))[0];
  73   my (@y) = ( 4, 6, 5);
  74   @y = sort { $a <=> $b } @y;
  75   print "sortfn ".join(', ', @y)."\n";
  76   return $_[0] <=> $_[1];
  77 }
  78 @x = ( 3, 2, 1 );
  79 @x = sort { &sortfn($a, $b) } @x;
  80 print "---- ".join(', ', @x)."\n";
  81 EXPECT
  82 sortfn 4, 5, 6
  83 ---- 1, 2, 3
  84 ########
  85 # trapping eval within sort (doesn't work currently because
  86 # die does a SWITCHSTACK())
  87 @a = (3, 2, 1);
  88 @a = sort { eval('die("no way")') ,  $a <=> $b} @a;
  89 print join(", ", @a)."\n";
  90 EXPECT
  91 1, 2, 3
  92 ########
  93 # this actually works fine, but results in a poor error message
  94 @a = (1, 2, 3);
  95 foo:
  96 {
  97   @a = sort { last foo; } @a;
  98 }
  99 EXPECT
 100 cannot reach destination block at - line 2.
 101 ########
 102 package TEST;
 103
 104 sub TIESCALAR {
 105   my $foo;
 106   return bless \$foo;
 107 }
 108 sub FETCH {
 109   next;
 110   return "ZZZ";
 111 }
 112 sub STORE {
 113 }
 114
 115 package main;
 116
 117 tie $bar, TEST;
 118 {
 119   print "- $bar\n";
 120 }
 121 print "OK\n";
 122 EXPECT
 123 cannot reach destination block at - line 8.
 124 ########
 125 package TEST;
 126
 127 sub TIESCALAR {
 128   my $foo;
 129   return bless \$foo;
 130 }
 131 sub FETCH {
 132   goto bbb;
 133   return "ZZZ";
 134 }
 135
 136 package main;
 137
 138 tie $bar, TEST;
 139 print "- $bar\n";
 140 exit;
 141 bbb:
 142 print "bbb\n";
 143 EXPECT
 144 bbb
 145 ########
 146 # trapping eval within sort (doesn't work currently because
 147 # die does a SWITCHSTACK())
 148 sub foo {
 149   $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
 150 }
 151 @a = (3, 2, 0, 1);
 152 @a = sort foo @a;
 153 print join(', ', @a)."\n";
 154 EXPECT
 155 0, 1, 2, 3
 156 ########
 157 package TEST;
 158 sub TIESCALAR {
 159   my $foo;
 160   next;
 161   return bless \$foo;
 162 }
 163 package main;
 164 {
 165 tie $bar, TEST;
 166 }
 167 EXPECT
 168 cannot reach destination block at - line 4.
 169 ########
 170 # large stack extension causes realloc, and segfault
 171 package TEST;
 172 sub TIESCALAR {
 173   my $foo;
 174   return bless \$foo;
 175 }
 176 sub FETCH {
 177   return "fetch";
 178 }
 179 sub STORE {
 180 (split(/./, 'x'x10000))[0];
 181 }
 182 package main;
 183 tie $bar, TEST;
 184 $bar = "x";
 185
 186 =cut
 187
 188 ##
 189 ##
 190 ## The real tests begin here
 191 ##
 192 ##
 193
 194 __END__
 195 @a = (1, 2, 3);
 196 {
 197   @a = sort { last ; } @a;
 198 }
 199 EXPECT
 200 Can't "last" outside a block at - line 3.
 201 ########
 202 package TEST;
 203
 204 sub TIESCALAR {
 205   my $foo;
 206   return bless \$foo;
 207 }
 208 sub FETCH {
 209   eval 'die("test")';
 210   print "still in fetch\n";
 211   return ">$@<";
 212 }
 213 package main;
 214
 215 tie $bar, TEST;
 216 print "- $bar\n";
 217 EXPECT
 218 still in fetch
 219 - >test at (eval 1) line 1.
 220 <
 221 ########
 222 package TEST;
 223
 224 sub TIESCALAR {
 225   my $foo;
 226   eval('die("foo\n")');
 227   print "after eval\n";
 228   return bless \$foo;
 229 }
 230 sub FETCH {
 231   return "ZZZ";
 232 }
 233
 234 package main;
 235
 236 tie $bar, TEST;
 237 print "- $bar\n";
 238 print "OK\n";
 239 EXPECT
 240 after eval
 241 - ZZZ
 242 OK
 243 ########
 244 package TEST;
 245
 246 sub TIEHANDLE {
 247   my $foo;
 248   return bless \$foo;
 249 }
 250 sub PRINT {
 251 print STDERR "PRINT CALLED\n";
 252 (split(/./, 'x'x10000))[0];
 253 eval('die("test\n")');
 254 }
 255
 256 package main;
 257
 258 open FH, ">&STDOUT";
 259 tie *FH, TEST;
 260 print FH "OK\n";
 261 print STDERR "DONE\n";
 262 EXPECT
 263 PRINT CALLED
 264 DONE
 265 ########
 266 sub warnhook {
 267   print "WARNHOOK\n";
 268   eval('die("foooo\n")');
 269 }
 270 $SIG{'__WARN__'} = 'warnhook';
 271 warn("dfsds\n");
 272 print "END\n";
 273 EXPECT
 274 WARNHOOK
 275 END
 276 ########
 277 package TEST;
 278
 279 use overload
 280      "\"\""   =>  \&str
 281 ;
 282
 283 sub str {
 284   eval('die("test\n")');
 285   return "STR";
 286 }
 287
 288 package main;
 289
 290 $bar = bless {}, TEST;
 291 print "$bar\n";
 292 print "OK\n";
 293 EXPECT
 294 STR
 295 OK
 296 ########
 297 sub foo {
 298   $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
 299 }
 300 @a = (3, 2, 0, 1);
 301 @a = sort foo @a;
 302 print join(', ', @a)."\n";
 303 EXPECT
 304 0, 1, 2, 3
 305 ########
 306 sub foo {
 307   goto bar if $a == 0;
 308   $a <=> $b;
 309 }
 310 @a = (3, 2, 0, 1);
 311 @a = sort foo @a;
 312 print join(', ', @a)."\n";
 313 exit;
 314 bar:
 315 print "bar reached\n";
 316 EXPECT
 317 Can't "goto" outside a block at - line 2.