[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]
[perl #51370] length($@)>0 for empty $@ if utf8 is in use
On Mon Mar 03 06:41:54 2008, pajas@ufal.mff.cuni.cz wrote:
>
> Perl seems to cache character length of scalars, but in case of $@
> it does not reset it after a successfull eval. Here is an example.
>
> The following is reproducible with 5.10.0 and also on 5.8.8 (didn't
> try other releases):
>
> perl -MCarp -e 'use utf8; eval { die "\x{10d}"}; length($@); print
> $@; eval { 1 }; print "\$@ is q($@), length(\$@)
> is ".length($@)."\n" '
>
> The first eval dies and spits a non-ascii character. Then the
> character length of $@ is asked (we are in the scope of the utf8
> pragma). The returned value (16 in this case) seems to be
> remembered,
> since after a subsequent eval{1} which resets $@ to q(), the
> function
> length($@) still returns 16 (but 0 if asked in the scope of 'use
> byte').
>
> -----------------------------------------------------------------
Attached are two patches:
errsv_1.txt:
- this patch clears all the magic associated with $@,
- has the test of the bug report
- scrapes the output of Devel::Peek::Dump at the start and compares it
again after two evals (one that fails and one that succeeds).
errsv_2.txt:
In the thread (Clearing magic) Nicholas said:
<quote>
To my mind, making them all *_mg seems right, as it would trigger any
set magic on ERRSV.
Although (I think) that this would allow rather sick things like tie $@
to work.
</quote>
- this patch changes most of them (not sure if I got them all) into _mg
- has the test of the bug report
- does a tie on $@ and checks if STORE gets called.
Only one of the two patches has to be applied...
Kind regards,
Bram
diff -Naur old/perl-current/op.c new/perl-current/op.c
--- old/perl-current/op.c 2008-06-07 16:05:37.000000000 +0200
+++ new/perl-current/op.c 2008-06-07 18:43:01.000000000 +0200
@@ -2521,7 +2521,7 @@
case 3:
/* Something tried to die. Abandon constant folding. */
/* Pretend the error never happened. */
- sv_setpvn(ERRSV,"",0);
+ clear_errsv();
o->op_next = old_next;
break;
default:
diff -Naur old/perl-current/perl.c new/perl-current/perl.c
--- old/perl-current/perl.c 2008-06-07 16:05:41.000000000 +0200
+++ new/perl-current/perl.c 2008-06-07 18:43:04.000000000 +0200
@@ -2679,8 +2679,9 @@
redo_body:
CALL_BODY_SUB((OP*)&myop);
retval = PL_stack_sp - (PL_stack_base + oldmark);
- if (!(flags & G_KEEPERR))
- sv_setpvn(ERRSV,"",0);
+ if (!(flags & G_KEEPERR)) {
+ clear_errsv();
+ }
break;
case 1:
STATUS_ALL_FAILURE;
@@ -2780,8 +2781,9 @@
redo_body:
CALL_BODY_EVAL((OP*)&myop);
retval = PL_stack_sp - (PL_stack_base + oldmark);
- if (!(flags & G_KEEPERR))
- sv_setpvn(ERRSV,"",0);
+ if (!(flags & G_KEEPERR)) {
+ clear_errsv();
+ }
break;
case 1:
STATUS_ALL_FAILURE;
@@ -3559,7 +3561,7 @@
gv_SVadd(PL_errgv);
#endif
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
- sv_setpvn(ERRSV, "", 0);
+ clear_errsv();
PL_curstash = PL_defstash;
CopSTASH_set(&PL_compiling, PL_defstash);
PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
diff -Naur old/perl-current/perl.h new/perl-current/perl.h
--- old/perl-current/perl.h 2008-06-07 16:05:37.000000000 +0200
+++ new/perl-current/perl.h 2008-06-07 18:43:05.000000000 +0200
@@ -6008,6 +6008,8 @@
#endif /* Include guard */
+#define clear_errsv() STMT_START { sv_setpvn(ERRSV,"",0); if (SvMAGICAL(ERRSV)) { mg_free(ERRSV); } SvPOK_only(ERRSV); } STMT_END
+
/*
* Local variables:
* c-indentation-style: bsd
diff -Naur old/perl-current/pp_ctl.c new/perl-current/pp_ctl.c
--- old/perl-current/pp_ctl.c 2008-06-07 16:05:34.000000000 +0200
+++ new/perl-current/pp_ctl.c 2008-06-07 18:42:59.000000000 +0200
@@ -2148,8 +2148,9 @@
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVESUB(sv);
- if (clear_errsv)
- sv_setpvn(ERRSV,"",0);
+ if (clear_errsv) {
+ clear_errsv();
+ }
return retop;
}
@@ -3000,8 +3001,9 @@
CopARYBASE_set(PL_curcop, 0);
if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
PL_in_eval |= EVAL_KEEPERR;
- else
- sv_setpvn(ERRSV,"",0);
+ else {
+ clear_errsv();
+ }
if (yyparse() || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
PERL_CONTEXT *cx = &cxstack[cxstack_ix];
@@ -3772,8 +3774,9 @@
}
else {
LEAVE;
- if (!(save_flags & OPf_SPECIAL))
- sv_setpvn(ERRSV,"",0);
+ if (!(save_flags & OPf_SPECIAL)) {
+ clear_errsv();
+ }
}
RETURNOP(retop);
@@ -3816,8 +3819,9 @@
PL_in_eval = EVAL_INEVAL;
if (flags & G_KEEPERR)
PL_in_eval |= EVAL_KEEPERR;
- else
- sv_setpvn(ERRSV,"",0);
+ else {
+ clear_errsv();
+ }
if (flags & G_FAKINGEVAL) {
PL_eval_root = PL_op; /* Only needed so that goto works right. */
}
@@ -3876,7 +3880,7 @@
PL_curpm = newpm; /* Don't pop $1 et al till now */
LEAVE;
- sv_setpvn(ERRSV,"",0);
+ clear_errsv();
RETURN;
}
diff -Naur old/perl-current/t/op/eval.t new/perl-current/t/op/eval.t
--- old/perl-current/t/op/eval.t 2008-06-07 16:05:35.000000000 +0200
+++ new/perl-current/t/op/eval.t 2008-06-07 18:42:49.000000000 +0200
@@ -5,7 +5,7 @@
@INC = '../lib';
}
-print "1..95\n";
+print "1..98\n";
eval 'print "ok 1\n";';
@@ -485,4 +485,63 @@
}
+# [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
+# length $@
+$@ = "";
+eval { die "\x{a10d}"; };
+$_ = length $@;
+eval { 1 };
+
+print "not " if ($@ ne "");
+print "ok $test # length of \$@ after eval\n"; $test++;
+
+print "not " if (length $@ != 0);
+print "ok $test # length of \$@ after eval\n"; $test++;
+
+# Check if eval { 1 }; compeltly resets $@
+if (eval "use Devel::Peek; 1;") {
+
+ open PROG, ">", "peek_eval_$$.t" or die "Can't create test file";
+ print PROG <<'END_EVAL_TEST';
+ use Devel::Peek;
+ $! = 0;
+ $@ = $!;
+ my $ok = 0;
+ open(SAVERR, ">&STDERR") or die "Can't dup STDERR: $!";
+ if (open(OUT,">peek_eval$$")) {
+ open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
+ Dump($@);
+ print STDERR "******\n";
+ eval { die "\x{a10d}"; };
+ $_ = length $@;
+ eval { 1 };
+ Dump($@);
+ open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
+ close(OUT);
+ if (open(IN, "peek_eval$$")) {
+ local $/;
+ my $in = <IN>;
+ my ($first, $second) = split (/\*\*\*\*\*\*\n/, $in, 2);
+ $first =~ s/,pNOK//;
+ $ok = 1 if ($first eq $second);
+ }
+ }
+
+ print $ok;
+ END {
+ 1 while unlink("peek_eval$$");
+ }
+END_EVAL_TEST
+ close PROG;
+
+ my $ok = runperl(progfile => "peek_eval_$$.t");
+ print "not " unless $ok;
+ print "ok $test # eval { 1 } completly resets \$@\n";
+
+ $test++;
+ 1 while unlink("peek_eval_$$.t");
+}
+else {
+ print "ok $test # skipped - eval { 1 } completly resets \$@";
+}
diff -Naur old/perl-current/op.c new/perl-current/op.c
--- old/perl-current/op.c 2008-06-07 16:05:37.000000000 +0200
+++ new/perl-current/op.c 2008-06-07 20:22:25.000000000 +0200
@@ -2521,7 +2521,7 @@
case 3:
/* Something tried to die. Abandon constant folding. */
/* Pretend the error never happened. */
- sv_setpvn(ERRSV,"",0);
+ sv_setpvn_mg(ERRSV,"",0);
o->op_next = old_next;
break;
default:
@@ -5719,7 +5719,7 @@
Perl_croak(aTHX_ not_safe);
else {
/* force display of errors found but not reported */
- sv_catpv(ERRSV, not_safe);
+ sv_catpv_mg(ERRSV, not_safe);
Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
}
}
diff -Naur old/perl-current/perl.c new/perl-current/perl.c
--- old/perl-current/perl.c 2008-06-07 16:05:41.000000000 +0200
+++ new/perl-current/perl.c 2008-06-07 20:22:30.000000000 +0200
@@ -2680,7 +2680,7 @@
CALL_BODY_SUB((OP*)&myop);
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
- sv_setpvn(ERRSV,"",0);
+ sv_setpvn_mg(ERRSV,"",0);
break;
case 1:
STATUS_ALL_FAILURE;
@@ -2781,7 +2781,7 @@
CALL_BODY_EVAL((OP*)&myop);
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
- sv_setpvn(ERRSV,"",0);
+ sv_setpvn_mg(ERRSV,"",0);
break;
case 1:
STATUS_ALL_FAILURE;
@@ -3559,7 +3559,7 @@
gv_SVadd(PL_errgv);
#endif
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
- sv_setpvn(ERRSV, "", 0);
+ sv_setpvn_mg(ERRSV, "", 0);
PL_curstash = PL_defstash;
CopSTASH_set(&PL_compiling, PL_defstash);
PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV));
diff -Naur old/perl-current/pp_ctl.c new/perl-current/pp_ctl.c
--- old/perl-current/pp_ctl.c 2008-06-07 16:05:34.000000000 +0200
+++ new/perl-current/pp_ctl.c 2008-06-07 20:22:36.000000000 +0200
@@ -1488,7 +1488,7 @@
PERL_ARGS_ASSERT_QERROR;
if (PL_in_eval)
- sv_catsv(ERRSV, err);
+ sv_catsv_mg(ERRSV, err);
else if (PL_errors)
sv_catsv(PL_errors, err);
else
@@ -1512,7 +1512,7 @@
SV * const err = ERRSV;
const char *e = NULL;
if (!SvPOK(err))
- sv_setpvn(err,"",0);
+ sv_setpvn_mg(err,"",0);
else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
STRLEN len;
e = SvPV_const(err, len);
@@ -1522,8 +1522,8 @@
}
if (!e) {
SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
- sv_catpvn(err, prefix, sizeof(prefix)-1);
- sv_catpvn(err, message, msglen);
+ sv_catpvn_mg(err, prefix, sizeof(prefix)-1);
+ sv_catpvn_mg(err, message, msglen);
if (ckWARN(WARN_MISC)) {
const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
@@ -1531,7 +1531,7 @@
}
}
else {
- sv_setpvn(ERRSV, message, msglen);
+ sv_setpvn_mg(ERRSV, message, msglen);
}
}
@@ -2149,7 +2149,7 @@
LEAVESUB(sv);
if (clear_errsv)
- sv_setpvn(ERRSV,"",0);
+ sv_setpvn_mg(ERRSV,"",0);
return retop;
}
@@ -3001,7 +3001,7 @@
if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
PL_in_eval |= EVAL_KEEPERR;
else
- sv_setpvn(ERRSV,"",0);
+ sv_setpvn_mg(ERRSV,"",0);
if (yyparse() || PL_parser->error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
PERL_CONTEXT *cx = &cxstack[cxstack_ix];
@@ -3037,7 +3037,7 @@
}
else {
if (!*msg) {
- sv_setpvs(ERRSV, "Compilation error");
+ sv_setpvs(ERRSV, "Compilation error"); /* Should this be _mg? sv_setpvs_mg doesn't exist? */
}
}
PERL_UNUSED_VAR(newsp);
@@ -3773,7 +3773,7 @@
else {
LEAVE;
if (!(save_flags & OPf_SPECIAL))
- sv_setpvn(ERRSV,"",0);
+ sv_setpvn_mg(ERRSV,"",0);
}
RETURNOP(retop);
@@ -3817,7 +3817,7 @@
if (flags & G_KEEPERR)
PL_in_eval |= EVAL_KEEPERR;
else
- sv_setpvn(ERRSV,"",0);
+ sv_setpvn_mg(ERRSV,"",0);
if (flags & G_FAKINGEVAL) {
PL_eval_root = PL_op; /* Only needed so that goto works right. */
}
@@ -3876,7 +3876,7 @@
PL_curpm = newpm; /* Don't pop $1 et al till now */
LEAVE;
- sv_setpvn(ERRSV,"",0);
+ sv_setpvn_mg(ERRSV,"",0);
RETURN;
}
diff -Naur old/perl-current/pp_sys.c new/perl-current/pp_sys.c
--- old/perl-current/pp_sys.c 2008-06-07 16:05:38.000000000 +0200
+++ new/perl-current/pp_sys.c 2008-06-07 20:22:39.000000000 +0200
@@ -432,7 +432,7 @@
SV * const error = ERRSV;
SvUPGRADE(error, SVt_PV);
if (SvPOK(error) && SvCUR(error))
- sv_catpvs(error, "\t...caught");
+ sv_catpvs(error, "\t...caught"); /* Shuold this be _mg? sv_catpvs_mg doesn't exist? */
tmpsv = error;
tmps = SvPV_const(tmpsv, len);
}
@@ -485,14 +485,14 @@
PUTBACK;
call_sv((SV*)GvCV(gv),
G_SCALAR|G_EVAL|G_KEEPERR);
- sv_setsv(error,*PL_stack_sp--);
+ sv_setsv_mg(error,*PL_stack_sp--);
}
}
DIE(aTHX_ NULL);
}
else {
if (SvPOK(error) && SvCUR(error))
- sv_catpvs(error, "\t...propagated");
+ sv_catpvs(error, "\t...propagated"); /* Should this be _mg? sv_catpvs_mg doesn't exist? */
tmpsv = error;
if (SvOK(tmpsv))
tmps = SvPV_const(tmpsv, len);
diff -Naur old/perl-current/t/op/eval.t new/perl-current/t/op/eval.t
--- old/perl-current/t/op/eval.t 2008-06-07 16:05:35.000000000 +0200
+++ new/perl-current/t/op/eval.t 2008-06-07 20:23:07.000000000 +0200
@@ -5,7 +5,7 @@
@INC = '../lib';
}
-print "1..95\n";
+print "1..101\n";
eval 'print "ok 1\n";';
@@ -486,3 +486,44 @@
+# [perl #51370] eval { die "\x{a10d}" } followed by eval { 1 } did not reset
+# length $@
+$@ = "";
+eval { die "\x{a10d}"; };
+$_ = length $@;
+eval { 1 };
+
+print "not " if ($@ ne "");
+print "ok $test # length of \$@ after eval\n"; $test++;
+
+print "not " if (length $@ != 0);
+print "ok $test # length of \$@ after eval\n"; $test++;
+
+
+# In [perl #51370] Nicholas wondered wheter all calls with ERRSV should be changed
+# to _mg. This would fix the bug and allow tie'ing and stuff
+{
+ my $ok = 0;
+ my $error = "foo";
+ package Eval2;
+ sub FETCH { $_[0]->[0]; }
+ sub STORE { $_[0]->[0] = $error = $_[1]; }
+ sub TIESCALAR { bless [] }
+
+ tie $@, "Eval2";
+ eval { 1 };
+ print "not " if ($@ ne "");
+ print "ok $test # test a tied \$@\n"; $test++;
+
+ print "not " if ($error ne "");
+ print "ok $test # test a tied \$@\n"; $test++;
+
+ eval { die "ttt\n" };
+ print "not " if ($@ ne "ttt\n");
+ print "ok $test # test a tied \$@\n"; $test++;
+
+ print "not " if ($error ne "ttt\n");
+ print "ok $test # test a tied \$@\n"; $test++;
+}
+
+
diff -Naur old/perl-current/toke.c new/perl-current/toke.c
--- old/perl-current/toke.c 2008-06-07 16:05:41.000000000 +0200
+++ new/perl-current/toke.c 2008-06-07 20:22:42.000000000 +0200
@@ -10652,7 +10652,7 @@
/* Check the eval first */
if (!PL_in_eval && SvTRUE(ERRSV)) {
- sv_catpvs(ERRSV, "Propagated");
+ sv_catpvs(ERRSV, "Propagated"); /* Should this be _mg? sv_catpvs_mg doesn't exist? */
yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
(void)POPs;
res = SvREFCNT_inc_simple(sv);
- Follow-Ups from:
-
"Rafael Garcia-Suarez" <rgarciasuarez@gmail.com>
[Date Prev][Date Next] [Thread Prev][Thread Next] [Date Index][Thread Index][Top&Search][Original]