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>

7 files changed, 377 insertions, 4 deletions

diff --git a/gv.c b/gv.c
index 62afd9163e..67b2600bfe 100644
--- a/gv.c
+++ b/gv.c
@@ -1284,12 +1284,14 @@ int flags;
     dSP;
     BINOP myop;
     SV* res;
+    bool oldmustcatch = mustcatch;
 
     Zero(&myop, 1, BINOP);
     myop.op_last = (OP *) &myop;
     myop.op_next = Nullop;
     myop.op_flags = OPf_KNOW|OPf_STACKED;
 
+    mustcatch = TRUE;
     ENTER;
     SAVESPTR(op);
     op = (OP *) &myop;
@@ -1315,6 +1317,7 @@ int flags;
 
     res=POPs;
     PUTBACK;
+    mustcatch = oldmustcatch;
 
     if (postpr) {
       int ans;
diff --git a/interp.sym b/interp.sym
index ec9c038986..a82c2c4843 100644
--- a/interp.sym
+++ b/interp.sym
@@ -85,6 +85,7 @@ minus_l
 minus_n
 minus_p
 multiline
+mustcatch
 mystack_base
 mystack_mark
 mystack_max
diff --git a/perl.c b/perl.c
index a93ff71977..9f3942e68f 100644
--- a/perl.c
+++ b/perl.c
@@ -496,6 +496,7 @@ setuid perl scripts securely.\n");
     main_cv = Nullcv;
 
     time(&basetime);
+    mustcatch = FALSE;
 
     switch (Sigsetjmp(top_env,1)) {
     case 1:
@@ -953,7 +954,8 @@ I32 flags;		/* See G_* flags in cop.h */
     Sigjmp_buf oldtop;
     I32 oldscope;
     static CV *DBcv;
-    
+    bool oldmustcatch = mustcatch;
+
     if (flags & G_DISCARD) {
 	ENTER;
 	SAVETMPS;
@@ -1043,6 +1045,8 @@ I32 flags;		/* See G_* flags in cop.h */
 	    goto cleanup;
 	}
     }
+    else
+	mustcatch = TRUE;
 
     if (op == (OP*)&myop)
 	op = pp_entersub();
@@ -1069,6 +1073,9 @@ I32 flags;		/* See G_* flags in cop.h */
 	}
 	Copy(oldtop, top_env, 1, Sigjmp_buf);
     }
+    else
+	mustcatch = oldmustcatch;
+
     if (flags & G_DISCARD) {
 	stack_sp = stack_base + oldmark;
 	retval = 0;
diff --git a/perl.h b/perl.h
index d62c0352f0..5028b17bf5 100644
--- a/perl.h
+++ b/perl.h
@@ -1827,6 +1827,7 @@ IEXT I32	Icxstack_ix IINIT(-1);
 IEXT I32	Icxstack_max IINIT(128);
 IEXT Sigjmp_buf	Itop_env;
 IEXT I32	Irunlevel;
+IEXT bool	Imustcatch;	/* doeval() must be caught locally */
 
 /* stack stuff */
 IEXT AV *	Icurstack;		/* THE STACK */
diff --git a/pp_ctl.c b/pp_ctl.c
index c70375b730..6eab4da34e 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -23,6 +23,9 @@
 #define WORD_ALIGN sizeof(U16)
 #endif
 
+#define DOCATCH(o) (mustcatch ? docatch(o) : (o))
+
+static OP *docatch _((OP *o));
 static OP *doeval _((int gimme));
 static OP *dofindlabel _((OP *op, char *label, OP **opstack));
 static void doparseform _((SV *sv));
@@ -625,6 +628,7 @@ PP(pp_sort)
 	    AV *oldstack;
 	    CONTEXT *cx;
 	    SV** newsp;
+	    bool oldmustcatch = mustcatch;
 
 	    SAVETMPS;
 	    SAVESPTR(op);
@@ -635,6 +639,7 @@ PP(pp_sort)
 		AvREAL_off(sortstack);
 		av_extend(sortstack, 32);
 	    }
+	    mustcatch = TRUE;
 	    SWITCHSTACK(curstack, sortstack);
 	    if (sortstash != stash) {
 		firstgv = gv_fetchpv("a", TRUE, SVt_PV);
@@ -651,6 +656,7 @@ PP(pp_sort)
 
 	    POPBLOCK(cx,curpm);
 	    SWITCHSTACK(sortstack, oldstack);
+	    mustcatch = oldmustcatch;
 	}
 	LEAVE;
     }
@@ -1935,6 +1941,46 @@ SV *sv;
 }
 
 static OP *
+docatch(o)
+OP *o;
+{
+    int ret;
+    int oldrunlevel = runlevel;
+    Sigjmp_buf oldtop;
+
+    op = o;
+    runlevel--;				/* pretense */
+    Copy(top_env, oldtop, 1, Sigjmp_buf);
+#ifdef DEBUGGING
+    assert(mustcatch == TRUE);
+#endif
+    mustcatch = FALSE;
+    switch ((ret = Sigsetjmp(top_env,1))) {
+    default:				/* topmost level handles it */
+	Copy(oldtop, top_env, 1, Sigjmp_buf);
+	runlevel = oldrunlevel;
+	mustcatch = TRUE;
+	Siglongjmp(top_env, ret);
+	/* NOTREACHED */
+    case 3:
+	if (!restartop) {
+	    PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+	    break;
+	}
+	op = restartop;
+	restartop = 0;
+	/* FALL THROUGH */
+    case 0:
+        runops();
+	break;
+    }
+    Copy(oldtop, top_env, 1, Sigjmp_buf);
+    runlevel = oldrunlevel;
+    mustcatch = TRUE;
+    return Nullop;
+}
+
+static OP *
 doeval(gimme)
 int gimme;
 {
@@ -2177,7 +2223,7 @@ PP(pp_require)
     compiling.cop_line = 0;
 
     PUTBACK;
-    return doeval(G_SCALAR);
+    return DOCATCH(doeval(G_SCALAR));
 }
 
 PP(pp_dofile)
@@ -2232,7 +2278,7 @@ PP(pp_entereval)
     if (perldb && was != sub_generation) { /* Some subs defined here. */
 	strcpy(safestr, "_<(eval )");	/* Anything fake and short. */
     }
-    return ret;
+    return DOCATCH(ret);
 }
 
 PP(pp_leaveeval)
@@ -2316,7 +2362,8 @@ PP(pp_entertry)
 
     in_eval = 1;
     sv_setpv(GvSV(errgv),"");
-    RETURN;
+    PUTBACK;
+    return DOCATCH(op->op_next);
 }
 
 PP(pp_leavetry)
diff --git a/pp_sys.c b/pp_sys.c
index 75fdc4055a..fbd5012c40 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -459,6 +459,7 @@ PP(pp_tie)
     SV **mark = stack_base + ++*markstack_ptr;	/* reuse in entersub */
     I32 markoff = mark - stack_base - 1;
     char *methname;
+    bool oldmustcatch = mustcatch;
 
     varsv = mark[0];
     if (SvTYPE(varsv) == SVt_PVHV)
@@ -479,6 +480,7 @@ PP(pp_tie)
     myop.op_last = (OP *) &myop;
     myop.op_next = Nullop;
     myop.op_flags = OPf_KNOW|OPf_STACKED;
+    mustcatch = TRUE;
 
     ENTER;
     SAVESPTR(op);
@@ -493,6 +495,7 @@ PP(pp_tie)
         runops();
     SPAGAIN;
 
+    mustcatch = oldmustcatch;
     sv = TOPs;
     if (sv_isobject(sv)) {
 	if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) {
@@ -569,6 +572,7 @@ PP(pp_dbmopen)
     GV *gv;
     BINOP myop;
     SV *sv;
+    bool oldmustcatch = mustcatch;
 
     hv = (HV*)POPs;
 
@@ -587,6 +591,7 @@ PP(pp_dbmopen)
     myop.op_last = (OP *) &myop;
     myop.op_next = Nullop;
     myop.op_flags = OPf_KNOW|OPf_STACKED;
+    mustcatch = TRUE;
 
     ENTER;
     SAVESPTR(op);
@@ -629,6 +634,7 @@ PP(pp_dbmopen)
 	SPAGAIN;
     }
 
+    mustcatch = oldmustcatch;
     if (sv_isobject(TOPs))
 	sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
     LEAVE;
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.