#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));
AV *oldstack;
CONTEXT *cx;
SV** newsp;
+ bool oldmustcatch = mustcatch;
SAVETMPS;
SAVESPTR(op);
AvREAL_off(sortstack);
av_extend(sortstack, 32);
}
+ mustcatch = TRUE;
SWITCHSTACK(curstack, sortstack);
if (sortstash != stash) {
firstgv = gv_fetchpv("a", TRUE, SVt_PV);
POPBLOCK(cx,curpm);
SWITCHSTACK(sortstack, oldstack);
+ mustcatch = oldmustcatch;
}
LEAVE;
}
}
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;
{
compiling.cop_line = 0;
PUTBACK;
- return doeval(G_SCALAR);
+ return DOCATCH(doeval(G_SCALAR));
}
PP(pp_dofile)
if (perldb && was != sub_generation) { /* Some subs defined here. */
strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
}
- return ret;
+ return DOCATCH(ret);
}
PP(pp_leaveeval)
in_eval = 1;
sv_setpv(GvSV(errgv),"");
- RETURN;
+ PUTBACK;
+ return DOCATCH(op->op_next);
}
PP(pp_leavetry)
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)
myop.op_last = (OP *) &myop;
myop.op_next = Nullop;
myop.op_flags = OPf_KNOW|OPf_STACKED;
+ mustcatch = TRUE;
ENTER;
SAVESPTR(op);
runops();
SPAGAIN;
+ mustcatch = oldmustcatch;
sv = TOPs;
if (sv_isobject(sv)) {
if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) {
GV *gv;
BINOP myop;
SV *sv;
+ bool oldmustcatch = mustcatch;
hv = (HV*)POPs;
myop.op_last = (OP *) &myop;
myop.op_next = Nullop;
myop.op_flags = OPf_KNOW|OPf_STACKED;
+ mustcatch = TRUE;
ENTER;
SAVESPTR(op);
SPAGAIN;
}
+ mustcatch = oldmustcatch;
if (sv_isobject(TOPs))
sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
LEAVE;
--- /dev/null
+#!./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.
projects / platform / upstream / perl.git / commitdiff