Advanced
Mailing List Archive

Mailing List Archive

  1. Home >
  2. Perl>
  3. porters
G_KEEPERR patch
gsar at engin
Oct 18, 1995, 8:16 PM
Post #1 of 5 (628 views)
Permalink
This is the G_KEEPERR patch, to be applied over the perl5.001m source.

This patch implements the following enhancements:

* Addition of a new flag, G_KEEPERR, for perl_call_*() calls. This flag
currently makes sense only in conjunction with G_EVAL (it is ignored without
G_EVAL), and is meant to be used for calling cleanup code. Errors that result
while executing such code will be appended to $@ rather than overwriting
it. New errors will be vetted for duplicates and only one instance of the
error will be appended to $@. Duplicates are checked against the %@ hash,
the keys of which are errors and the values are the counts of the number of
errors encountered. The %@ hash can be emptied by user code to reset the
vetting for duplicates.

* Using the G_KEEPERR flag for calling destructors in the source eliminates
the "DESTROY clobbers $@ bug".

* $@ is now cached as a global in the source for efficiency.

Many thanks to Tim, Tye and Paul for comments and the gentle reminders.

- Sarathy.
gsar@engin.umich.edu
--------------------------------8<------------------------------------
*** toke.c.old Tue Oct 10 12:13:24 1995
--- toke.c Wed Oct 18 19:35:58 1995
***************
*** 4851,4857 ****
if (in_eval & 2)
warn("%s",buf);
else if (in_eval)
! sv_catpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),buf);
else
fputs(buf,stderr);
if (++error_count >= 10)
--- 4851,4857 ----
if (in_eval & 2)
warn("%s",buf);
else if (in_eval)
! sv_catpv(GvSV(errgv),buf);
else
fputs(buf,stderr);
if (++error_count >= 10)
*** perl.c.old Thu Jun 22 18:38:28 1995
--- perl.c Wed Oct 18 19:44:37 1995
***************
*** 671,677 ****

cLOGOP->op_other = op;
markstack_ptr--;
! pp_entertry();
markstack_ptr++;

restart:
--- 671,695 ----

cLOGOP->op_other = op;
markstack_ptr--;
! /* we're trying to emulate pp_entertry() here */
! {
! register CONTEXT *cx;
! I32 gimme = GIMME;
!
! ENTER;
! SAVETMPS;
!
! push_return(op->op_next);
! PUSHBLOCK(cx, CXt_EVAL, stack_sp);
! PUSHEVAL(cx, 0, 0);
! eval_root = op; /* Only needed so that goto works right. */
!
! in_eval = 1;
! if (flags & G_KEEPERR)
! in_eval |= 4;
! else
! sv_setpv(GvSV(errgv),"");
! }
markstack_ptr++;

restart:
***************
*** 716,723 ****
if (op)
run();
retval = stack_sp - (stack_base + oldmark);
! if (flags & G_EVAL)
! sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");

cleanup:
if (flags & G_EVAL) {
--- 734,741 ----
if (op)
run();
retval = stack_sp - (stack_base + oldmark);
! if ((flags & G_EVAL) && !(flags & G_KEEPERR))
! sv_setpv(GvSV(errgv),"");

cleanup:
if (flags & G_EVAL) {
***************
*** 1077,1082 ****
--- 1095,1102 ----
incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
SvMULTI_on(incgv);
defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
+ errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
+ SvMULTI_on(errgv);
curstash = defstash;
compiling.cop_stash = defstash;
debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
***************
*** 1721,1727 ****

switch (setjmp(top_env)) {
case 0: {
! SV* atsv = GvSV(gv_fetchpv("@",TRUE, SVt_PV));
PUSHMARK(stack_sp);
perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
(void)SvPV(atsv, len);
--- 1741,1747 ----

switch (setjmp(top_env)) {
case 0: {
! SV* atsv = GvSV(errgv);
PUSHMARK(stack_sp);
perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
(void)SvPV(atsv, len);
*** pp_ctl.c.old Tue Sep 5 21:52:09 1995
--- pp_ctl.c Wed Oct 18 21:51:37 1995
***************
*** 942,953 ****
register CONTEXT *cx;
I32 gimme;
SV **newsp;
- SV *errsv;

! errsv = GvSV(gv_fetchpv("@",TRUE, SVt_PV));
! /* As destructors may produce errors we set $@ at the last moment */
! sv_setpv(errsv, ""); /* clear $@ before destroying */
!
cxix = dopoptoeval(cxstack_ix);
if (cxix >= 0) {
I32 optype;
--- 942,968 ----
register CONTEXT *cx;
I32 gimme;
SV **newsp;

! if (in_eval & 4) {
! SV **svp;
! STRLEN klen = strlen(message);
!
! if (hv_exists(GvHV(errgv), message, klen)) {
! svp = hv_fetch(GvHV(errgv), message, klen, FALSE);
! if (svp)
! sv_inc(*svp);
! }
! else {
! SV *tmpstr = newSVpv("\t(in cleanup) ", 0);
! (void) hv_store(GvHV(errgv), message, klen, newSViv(1), 0);
! sv_catpv(tmpstr, message);
! sv_catsv(GvSV(errgv), tmpstr);
! SvREFCNT_dec(tmpstr);
! }
! }
! else
! sv_catpv(GvSV(errgv), message);
!
cxix = dopoptoeval(cxstack_ix);
if (cxix >= 0) {
I32 optype;
***************
*** 968,976 ****

LEAVE;

- sv_insert(errsv, 0, 0, message, strlen(message));
if (optype == OP_REQUIRE)
! DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na));
return pop_return();
}
}
--- 983,990 ----

LEAVE;

if (optype == OP_REQUIRE)
! DIE("%s", SvPVx(GvSV(errgv), na));
return pop_return();
}
}
***************
*** 1925,1931 ****
rslen = 1;
rschar = '\n';
rspara = 0;
! sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
if (yyparse() || error_count || !eval_root) {
SV **newsp;
I32 gimme;
--- 1940,1946 ----
rslen = 1;
rschar = '\n';
rspara = 0;
! sv_setpv(GvSV(errgv),"");
if (yyparse() || error_count || !eval_root) {
SV **newsp;
I32 gimme;
***************
*** 1943,1949 ****
lex_end();
LEAVE;
if (optype == OP_REQUIRE)
! DIE("%s", SvPVx(GvSV(gv_fetchpv("@",TRUE, SVt_PV)), na));
rs = nrs;
rslen = nrslen;
rschar = nrschar;
--- 1958,1964 ----
lex_end();
LEAVE;
if (optype == OP_REQUIRE)
! DIE("%s", SvPVx(GvSV(errgv), na));
rs = nrs;
rslen = nrslen;
rschar = nrschar;
***************
*** 2182,2188 ****

lex_end();
LEAVE;
! sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");

RETURNOP(retop);
}
--- 2196,2202 ----

lex_end();
LEAVE;
! sv_setpv(GvSV(errgv),"");

RETURNOP(retop);
}
***************
*** 2202,2208 ****
eval_root = op; /* Only needed so that goto works right. */

in_eval = 1;
! sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
RETURN;
}

--- 2216,2222 ----
eval_root = op; /* Only needed so that goto works right. */

in_eval = 1;
! sv_setpv(GvSV(errgv),"");
RETURN;
}

***************
*** 2247,2253 ****
curpm = newpm; /* Don't pop $1 et al till now */

LEAVE;
! sv_setpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),"");
RETURN;
}

--- 2261,2267 ----
curpm = newpm; /* Don't pop $1 et al till now */

LEAVE;
! sv_setpv(GvSV(errgv),"");
RETURN;
}

*** pp_sys.c.dist Thu Jun 1 18:06:10 1995
--- pp_sys.c Wed Oct 18 19:33:58 1995
***************
*** 192,198 ****
tmps = SvPV(TOPs, na);
}
if (!tmps || !*tmps) {
! SV *error = GvSV(gv_fetchpv("@", TRUE, SVt_PV));
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...caught");
--- 192,198 ----
tmps = SvPV(TOPs, na);
}
if (!tmps || !*tmps) {
! SV *error = GvSV(errgv);
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...caught");
***************
*** 218,224 ****
tmps = SvPV(TOPs, na);
}
if (!tmps || !*tmps) {
! SV *error = GvSV(gv_fetchpv("@", TRUE, SVt_PV));
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...propagated");
--- 218,224 ----
tmps = SvPV(TOPs, na);
}
if (!tmps || !*tmps) {
! SV *error = GvSV(errgv);
(void)SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
sv_catpv(error, "\t...propagated");
*** perl.h.old Thu Jun 22 18:38:30 1995
--- perl.h Wed Oct 18 18:48:45 1995
***************
*** 1247,1252 ****
--- 1247,1255 ----
IEXT I32 Imaxscream IINIT(-1);
IEXT SV * Ilastscream;

+ /* shortcuts to misc objects */
+ IEXT GV * Ierrgv;
+
/* shortcuts to debugging objects */
IEXT GV * IDBgv;
IEXT GV * IDBline;
*** interp.sym.old Thu Jun 22 18:38:19 1995
--- interp.sym Wed Oct 18 18:42:50 1995
***************
*** 47,52 ****
--- 47,53 ----
e_tmpname
endav
envgv
+ errgv
eval_root
eval_start
fdpid
*** sv.c.old Fri Aug 18 18:33:54 1995
--- sv.c Wed Sep 13 21:04:55 1995
***************
*** 2129,2135 ****
PUSHMARK(SP);
PUSHs(&ref);
PUTBACK;
! perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL);
del_XRV(SvANY(&ref));
}
LEAVE;
--- 2129,2135 ----
PUSHMARK(SP);
PUSHs(&ref);
PUTBACK;
! perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
del_XRV(SvANY(&ref));
}
LEAVE;
*** cop.h.dist Sun Mar 12 22:25:47 1995
--- cop.h Tue Sep 5 18:14:17 1995
***************
*** 231,233 ****
--- 231,234 ----
#define G_DISCARD 2 /* Call FREETMPS. */
#define G_EVAL 4 /* Assume eval {} around subroutine call. */
#define G_NOARGS 8 /* Don't construct a @_ array. */
+ #define G_KEEPERR 16 /* Append errors to $@ rather than overwriting it */
Re: G_KEEPERR patch [ In reply to ]
gsar at engin
Oct 19, 1995, 9:25 PM
Post #2 of 5 (627 views)
Permalink
I forgot to mention that you will need to run

make regen_headers

after applying the G_KEEPERR patch I sent out yesterday.

Thanks to Andreas for spotting the goof.

Also, here is a small test case you can fool with:

package Demo;
sub new { bless {}}
sub DESTROY { die "fuz" }
sub foo {
my($self) = @_;
$self = $self->new() unless (ref $self);
my(@other) = ();
for (1..2) { push @other, $self->new(); }
my($a1) = $self->new();
my($a2) = $self->new();
my($a3) = $self->new();
my($a4) = $self->new();
die "foo";
}
package main;
eval { @a = Demo->foo() };
print $@ if $@;
print "---\n", %@, "\n";

- Sarathy.
gsar@engin.umich.edu
Re: G_KEEPERR patch [ In reply to ]
Tim.Bunce at ig
Oct 20, 1995, 5:05 AM
Post #3 of 5 (631 views)
Permalink
> From: Gurusamy Sarathy <gsar@engin.umich.edu>
>
> Also, here is a small test case you can fool with:
>
> package Demo;
> sub new { bless {}}
> sub DESTROY { die "fuz" }
> sub foo {
> my($self) = @_;
> $self = $self->new() unless (ref $self);
> my(@other) = ();
> for (1..2) { push @other, $self->new(); }
> my($a1) = $self->new();
> my($a2) = $self->new();
> my($a3) = $self->new();
> my($a4) = $self->new();
> die "foo";
> }
> package main;
> eval { @a = Demo->foo() };
> print $@ if $@;
> print "---\n", %@, "\n";

Could you also post its output for those with too little time to apply
the patch :-(

Tim.
Re: G_KEEPERR patch [ In reply to ]
k at anna
Oct 21, 1995, 6:42 AM
Post #4 of 5 (630 views)
Permalink
% perl -le '
package Demo;
sub new { bless {}}
sub DESTROY { die "fuz" }
sub foo {
my($self) = @_;
$self = $self->new() unless (ref $self);
my(@other) = ();
for (1..2) { push @other, $self->new(); }
my($a1) = $self->new();
my($a2) = $self->new();
my($a3) = $self->new();
my($a4) = $self->new();
die "foo";
}
package main;
eval { @a = Demo->foo() };
print $@ if $@;
print "---\n", %@, "\n";

'
foo at -e line 14.
(in cleanup) fuz at -e line 4.

---
fuz at -e line 4.
7



Output of an older perl:

foo at -e line 14.
fuz at -e line 4.

---






andreas
Re: G_KEEPERR patch [ In reply to ]
gsar at engin
Oct 21, 1995, 10:30 AM
Post #5 of 5 (627 views)
Permalink
On Sat, 21 Oct 1995 14:42:01 BST, Andreas Koenig wrote:
>
>
>% perl -le '
>package Demo;
>sub new { bless {}}
>sub DESTROY { die "fuz" }
>sub foo {
> my($self) = @_;
> $self = $self->new() unless (ref $self);
> my(@other) = ();
> for (1..2) { push @other, $self->new(); }
> my($a1) = $self->new();
> my($a2) = $self->new();
> my($a3) = $self->new();
> my($a4) = $self->new();
> die "foo";
>}
>package main;
>eval { @a = Demo->foo() };
>print $@ if $@;
>print "---\n", %@, "\n";
>
>'
>foo at -e line 14.
> (in cleanup) fuz at -e line 4.
>
>---
>fuz at -e line 4.
>7
>
>
>
>Output of an older perl:
>
>foo at -e line 14.
>fuz at -e line 4.
>
>---
>

5.001m will report just the error inside the DESTROY if the eval line is

eval { @a = Demo->new->foo() }; # create a temp object inside eval

And if the DESTROY doesn't cause an error, $@ will be empty, as if no
error occurred. This was the original problem with 5.001m.

My previous half-cooked attempt at G_KEEPERR would have retained _all_ the
errors, and would produce this:

fuz at evalerror.bug3 line 4.
(also) fuz at evalerror.bug3 line 4.
(also) foo at evalerror.bug3 line 14.
(also) fuz at evalerror.bug3 line 4.
(also) fuz at evalerror.bug3 line 4.
(also) fuz at evalerror.bug3 line 4.
(also) fuz at evalerror.bug3 line 4.
(also) fuz at evalerror.bug3 line 4.
---

With the latest patch, the duplicates among the cleanup errors are removed,
and the original error always appears outdented, as Andreas shows above.
And the prefix has been changed to "(in cleanup)". I had considered
"(background error)" as a prefix, but it seems too long.


- Sarathy.
gsar@engin.umich.edu

©2024 GT.net. A Gossamer Threads company.
5th Floor, 455 Granville St., Vancouver, BC V6C 1T1, Canada | Legal