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