Fix perl_call_*() when !G_EVAL

On Mon, 24 Feb 1997 15:19:17 EST, Gurusamy Sarathy wrote:
>On Mon, 24 Feb 1997 12:53:57 GMT, Tim Bunce wrote:
>>> From: Tom Christiansen <tchrist@jhereg.perl.com>
>>> >Dprof "works".  
>>> Then how come it's not in the core? :-(
>>I'd certainly like it to be there for 5.004.
>
>I'd agree, except there's this bug in perl_call_*() that makes
>it fail to run this fully:
>
>   % perl -d:DProf -e 'sub T { eval { die "burp" } } T(); print "zip\n"'
>   %

Ok, here's a patch for the perl_call_*() problems with error traps,
meant for 5.004 (hope I didn't miss the boat!).

This is a subset of the functionality contained in Michael Schroeder's
stack-of-stacks patch.  The patch itself if simple: code that calls
runops() without explicitly setting up a jmp_buf sets a flag that
indicates doeval() is responsible for catching any longjmp()s
locally.  The three places that call doeval() then call setjmp()
based on this flag.

This patch is binary compatible and minimal (as opposed to the
stack-of-stacks patch which has other issues involved, making it
more complicated).  There's a testsuite with 9 tests (3_28 fails all
but one).

p5p-msgid: <199702250725.CAA09192@aatma.engin.umich.edu>

1 files changed, 308 insertions, 0 deletions

diff --git a/t/op/runlevel.t b/t/op/runlevel.t
new file mode 100644
index 0000000000..ca6aac5e5b
--- /dev/null
+++ b/t/op/runlevel.t
@@ -0,0 +1,308 @@
+#!./perl
+
+##
+## all of these tests are from Michael Schroeder
+## <Michael.Schroeder@informatik.uni-erlangen.de>
+##
+## The more esoteric failure modes require Michael's
+## stack-of-stacks patch (so we don't test them here,
+## and they are commented out before the __END__).
+##
+## The remaining tests pass with a simpler fix
+## intended for 5.004
+##
+## Gurusamy Sarathy <gsar@umich.edu> 97-02-24
+##
+
+chdir 't' if -d 't';
+@INC = "../lib";
+$ENV{PERL5LIB} = "../lib";
+
+$|=1;
+
+undef $/;
+@prgs = split "\n########\n", <DATA>;
+print "1..", scalar @prgs, "\n";
+
+$tmpfile = "runltmp000";
+1 while -f ++$tmpfile;
+END { unlink $tmpfile if $tmpfile; }
+
+for (@prgs){
+    my $switch;
+    if (s/^\s*-\w+//){
+       $switch = $&;
+    }
+    my($prog,$expected) = split(/\nEXPECT\n/, $_);
+    open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1";
+    print TEST $prog, "\n";
+    close TEST;
+    $status = $?;
+    $results = `cat $tmpfile`;
+    $results =~ s/\n+$//;
+    $expected =~ s/\n+$//;
+    if ( $results ne $expected){
+       print STDERR "PROG: $switch\n$prog\n";
+       print STDERR "EXPECTED:\n$expected\n";
+       print STDERR "GOT:\n$results\n";
+       print "not ";
+    }
+    print "ok ", ++$i, "\n";
+}
+
+=head2 stay out of here (the real tests are after __END__)
+
+##
+## these tests don't pass yet (need the full stack-of-stacks patch)
+## GSAR 97-02-24
+##
+
+########
+# sort within sort
+sub sortfn {
+  (split(/./, 'x'x10000))[0];
+  my (@y) = ( 4, 6, 5);
+  @y = sort { $a <=> $b } @y;
+  print "sortfn ".join(', ', @y)."\n";
+  return $_[0] <=> $_[1];
+}
+@x = ( 3, 2, 1 );
+@x = sort { &sortfn($a, $b) } @x;
+print "---- ".join(', ', @x)."\n";
+EXPECT
+sortfn 4, 5, 6
+---- 1, 2, 3
+########
+# trapping eval within sort (doesn't work currently because
+# die does a SWITCHSTACK())
+@a = (3, 2, 1);
+@a = sort { eval('die("no way")') ,  $a <=> $b} @a;
+print join(", ", @a)."\n";
+EXPECT
+1, 2, 3
+########
+# this actually works fine, but results in a poor error message
+@a = (1, 2, 3);
+foo:
+{
+  @a = sort { last foo; } @a;
+}
+EXPECT
+cannot reach destination block at - line 2.
+########
+package TEST;
+ 
+sub TIESCALAR {
+  my $foo;
+  return bless \$foo;
+}
+sub FETCH {
+  next;
+  return "ZZZ";
+}
+sub STORE {
+}
+ 
+package main;
+ 
+tie $bar, TEST;
+{
+  print "- $bar\n";
+}
+print "OK\n";
+EXPECT
+cannot reach destination block at - line 8.
+########
+package TEST;
+ 
+sub TIESCALAR {
+  my $foo;
+  return bless \$foo;
+}
+sub FETCH {
+  goto bbb;
+  return "ZZZ";
+}
+ 
+package main;
+ 
+tie $bar, TEST;
+print "- $bar\n";
+exit;
+bbb:
+print "bbb\n";
+EXPECT
+bbb
+########
+# trapping eval within sort (doesn't work currently because
+# die does a SWITCHSTACK())
+sub foo {
+  $a <=> $b unless eval('$a == 0 ? die("foo\n") : ($a <=> $b)');
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+EXPECT
+0, 1, 2, 3
+########
+package TEST;
+sub TIESCALAR {
+  my $foo;
+  next;
+  return bless \$foo;
+}
+package main;
+{
+tie $bar, TEST;
+}
+EXPECT
+cannot reach destination block at - line 4.
+########
+# large stack extension causes realloc, and segfault
+package TEST;
+sub TIESCALAR {
+  my $foo;
+  return bless \$foo;
+}
+sub FETCH {
+  return "fetch";
+}
+sub STORE {
+(split(/./, 'x'x10000))[0];
+}
+package main;
+tie $bar, TEST;
+$bar = "x";
+
+=cut
+
+##
+##
+## The real tests begin here
+##
+##
+
+__END__
+@a = (1, 2, 3);
+{
+  @a = sort { last ; } @a;
+}
+EXPECT
+Can't "last" outside a block at - line 3.
+########
+package TEST;
+ 
+sub TIESCALAR {
+  my $foo;
+  return bless \$foo;
+}
+sub FETCH {
+  eval 'die("test")';
+  print "still in fetch\n";
+  return ">$@<";
+}
+package main;
+ 
+tie $bar, TEST;
+print "- $bar\n";
+EXPECT
+still in fetch
+- >test at (eval 1) line 1.
+<
+########
+package TEST;
+ 
+sub TIESCALAR {
+  my $foo;
+  eval('die("foo\n")');
+  print "after eval\n";
+  return bless \$foo;
+}
+sub FETCH {
+  return "ZZZ";
+}
+ 
+package main;
+ 
+tie $bar, TEST;
+print "- $bar\n";
+print "OK\n";
+EXPECT
+after eval
+- ZZZ
+OK
+########
+package TEST;
+ 
+sub TIEHANDLE {
+  my $foo;
+  return bless \$foo;
+}
+sub PRINT {
+print STDERR "PRINT CALLED\n";
+(split(/./, 'x'x10000))[0];
+eval('die("test\n")');
+}
+ 
+package main;
+ 
+open FH, ">&STDOUT";
+tie *FH, TEST;
+print FH "OK\n";
+print "DONE\n";
+EXPECT
+PRINT CALLED
+DONE
+########
+sub warnhook {
+  print "WARNHOOK\n";
+  eval('die("foooo\n")');
+}
+$SIG{'__WARN__'} = 'warnhook';
+warn("dfsds\n");
+print "END\n";
+EXPECT
+WARNHOOK
+END
+########
+package TEST;
+ 
+use overload
+     "\"\""   =>  \&str
+;
+ 
+sub str {
+  eval('die("test\n")');
+  return "STR";
+}
+ 
+package main;
+ 
+$bar = bless {}, TEST;
+print "$bar\n";
+print "OK\n";
+EXPECT
+STR
+OK
+########
+sub foo {
+  $a <=> $b unless eval('$a == 0 ? bless undef : ($a <=> $b)');
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+EXPECT
+0, 1, 2, 3
+########
+sub foo {
+  goto bar if $a == 0;
+  $a <=> $b;
+}
+@a = (3, 2, 0, 1);
+@a = sort foo @a;
+print join(', ', @a)."\n";
+exit;
+bar:
+print "bar reached\n";
+EXPECT
+Can't "goto" outside a block at - line 2.