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