In perl.git, the branch smoke-me/debug_readonly_ops has been updated <http://perl5.git.perl.org/perl.git/commitdiff/dea1145824d5d9b8f4e067d5e164de52fa8d4329?hp=be8851fc38b39ec6167336f4fee669536e99e022>
- Log ----------------------------------------------------------------- commit dea1145824d5d9b8f4e067d5e164de52fa8d4329 Author: Nicholas Clark <[email protected]> Date: Tue Aug 14 14:24:34 2012 +0200 In op.c, change S_Slab_to_rw() from an OP * parameter to an OPSLAB *. This makes it consistent with Perl_Slab_to_ro(), which takes an OPSLAB *. M embed.fnc M op.c M proto.h commit b06c479e71452899898c2d9b6bddeef8d94a90e8 Author: Nicholas Clark <[email protected]> Date: Tue Aug 14 14:10:30 2012 +0200 With -DPERL_DEBUG_READONLY_OPS, changing a slab refcnt shouldn't make it r/w. Perl_op_refcnt_inc() and Perl_op_refcnt_dec() now both take care to leave the slab in the same state as they found it. Previously both would unconditionally make the slab read-write. M op.c commit 0aea1d7a6fca91ad69a1b3441f7737f92db9a6e8 Author: Nicholas Clark <[email protected]> Date: Wed Aug 8 12:37:48 2012 +0200 Under -DPERL_DEBUG_READONLY_OPS don't work around glibc 2.2.5 _moddi3 bugs. The work around involves a runtime check and substituting OP pointers based on the result. The substitution fails if the optree is mapped read-only. M pp.c commit cfa42ec51752cd1cf6024095a3ac9d01817ed0af Author: Nicholas Clark <[email protected]> Date: Mon Aug 13 22:00:07 2012 +0200 newXS_len_flags() shouldn't change the line number on PL_curcop when warning. This can actually generate incorrect line numbers in runtime warnings, when XSUBs are redefined from calls made from BEGIN blocks, and the line number from the opening brace of the begin block is mashed with the filename of the current line. For compiletime warnings, PL_curcop == &PL_compiling, so the line numbers will be correct whether taken from PL_compiling or PL_parser. This code dates back to perl-5.000, when it was added to newXS(). It appears to be a copy of code present in newSUB() since alpha 2. M op.c M t/lib/warnings/op commit 9cd399b14e664d5917a8f219756ee8357ceb90e7 Author: Nicholas Clark <[email protected]> Date: Wed Aug 8 22:59:19 2012 +0200 Test that the warning for "can be 0, test with defined" is for the start. The Perl interpreter is careful to use the line number of the start of the 'Value of %s can be "0"; test with defined()" warning, but there were no tests for this. M op.c M t/lib/warnings/op commit 4a235a213e88345463a0ea4966b65b76fa2125f1 Author: Nicholas Clark <[email protected]> Date: Wed Aug 8 22:23:29 2012 +0200 Test that the warning for "Found = in conditional" is for the start line. The Perl interpreter is careful to use the line number of the start of the "Found = in conditional", but there were no tests for this. M op.c M t/lib/warnings/op commit 5511b5ff485c247378a16d5db6dabf662c9c82e3 Author: Nicholas Clark <[email protected]> Date: Wed Aug 8 16:24:57 2012 +0200 Test that the line number for a "sub redefined" warning is for the start. The Perl interpreter is careful to use the line number of the start of a subroutine's redefinition for the warning, but there were no tests for this. M op.c M t/lib/warnings/op ----------------------------------------------------------------------- Summary of changes: embed.fnc | 2 +- op.c | 50 +++++++++++++++++++++++++++++++++----------------- pp.c | 4 ++-- proto.h | 4 ++-- t/lib/warnings/op | 46 ++++++++++++++++++++++++++++++++++++++++++++++ 5 files changed, 84 insertions(+), 22 deletions(-) diff --git a/embed.fnc b/embed.fnc index 64bc381..2b914bf 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1797,7 +1797,7 @@ poxM |OP * |op_refcnt_inc |NULLOK OP *o : FIXME - can be static. poxM |PADOFFSET |op_refcnt_dec |NN OP *o # if defined(PERL_IN_OP_C) -s |void |Slab_to_rw |NN void *op +s |void |Slab_to_rw |NN OPSLAB *const slab # endif #endif diff --git a/op.c b/op.c index f3a0018..ba958d9 100644 --- a/op.c +++ b/op.c @@ -262,17 +262,12 @@ Perl_Slab_to_ro(pTHX_ OPSLAB *slab) } STATIC void -S_Slab_to_rw(pTHX_ void *op) +S_Slab_to_rw(pTHX_ OPSLAB *const slab) { - OP * const o = (OP *)op; - OPSLAB *slab; OPSLAB *slab2; PERL_ARGS_ASSERT_SLAB_TO_RW; - if (!o->op_slabbed) return; - - slab = OpSLAB(o); if (!slab->opslab_readonly) return; slab2 = slab; for (; slab2; slab2 = slab2->opslab_next) { @@ -406,8 +401,14 @@ OP * Perl_op_refcnt_inc(pTHX_ OP *o) { if(o) { - Slab_to_rw(o); - ++o->op_targ; + OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL; + if (slab && slab->opslab_readonly) { + Slab_to_rw(slab); + ++o->op_targ; + Slab_to_ro(slab); + } else { + ++o->op_targ; + } } return o; @@ -416,9 +417,19 @@ Perl_op_refcnt_inc(pTHX_ OP *o) PADOFFSET Perl_op_refcnt_dec(pTHX_ OP *o) { + PADOFFSET result; + OPSLAB *const slab = o->op_slabbed ? OpSLAB(o) : NULL; + PERL_ARGS_ASSERT_OP_REFCNT_DEC; - Slab_to_rw(o); - return --o->op_targ; + + if (slab && slab->opslab_readonly) { + Slab_to_rw(slab); + result = --o->op_targ; + Slab_to_ro(slab); + } else { + result = --o->op_targ; + } + return result; } #endif /* @@ -698,7 +709,8 @@ Perl_op_free(pTHX_ OP *o) if (type == OP_NULL) type = (OPCODE)o->op_targ; - Slab_to_rw(o); + if (o->op_slabbed) + Slab_to_rw(OpSLAB(o)); /* COP* is not cleared by op_clear() so that we may track line * numbers etc even after null() */ @@ -1085,8 +1097,11 @@ S_scalarboolean(pTHX_ OP *o) if (ckWARN(WARN_SYNTAX)) { const line_t oldline = CopLINE(PL_curcop); - if (PL_parser && PL_parser->copline != NOLINE) + if (PL_parser && PL_parser->copline != NOLINE) { + /* This ensures that warnings are reported at the first line + of the conditional, not the last. */ CopLINE_set(PL_curcop, PL_parser->copline); + } Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be =="); CopLINE_set(PL_curcop, oldline); } @@ -5832,6 +5847,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } if (warnop) { const line_t oldline = CopLINE(PL_curcop); + /* This ensures that warnings are reported at the first line + of the construction, not the last. */ CopLINE_set(PL_curcop, PL_parser->copline); Perl_warner(aTHX_ packWARN(WARN_MISC), "Value of %s%s can be \"0\"; test with defined()", @@ -7018,8 +7035,11 @@ Perl_newATTRSUB_flags(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, #endif ) { const line_t oldline = CopLINE(PL_curcop); - if (PL_parser && PL_parser->copline != NOLINE) + if (PL_parser && PL_parser->copline != NOLINE) { + /* This ensures that warnings are reported at the first + line of a redefinition, not the last. */ CopLINE_set(PL_curcop, PL_parser->copline); + } report_redefined_cv(cSVOPo->op_sv, cv, &const_sv); CopLINE_set(PL_curcop, oldline); #ifdef PERL_MAD @@ -7425,14 +7445,10 @@ Perl_newXS_len_flags(pTHX_ const char *name, STRLEN len, /* Redundant check that allows us to avoid creating an SV most of the time: */ if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) { - const line_t oldline = CopLINE(PL_curcop); - if (PL_parser && PL_parser->copline != NOLINE) - CopLINE_set(PL_curcop, PL_parser->copline); report_redefined_cv(newSVpvn_flags( name,len,(flags&SVf_UTF8)|SVs_TEMP ), cv, const_svp); - CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); cv = NULL; diff --git a/pp.c b/pp.c index 5a40a2d..97f842a 100644 --- a/pp.c +++ b/pp.c @@ -2360,7 +2360,7 @@ PP(pp_i_divide) } } -#if defined(__GLIBC__) && IVSIZE == 8 +#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) STATIC PP(pp_i_modulo_0) #else @@ -2383,7 +2383,7 @@ PP(pp_i_modulo) } } -#if defined(__GLIBC__) && IVSIZE == 8 +#if defined(__GLIBC__) && IVSIZE == 8 && !defined(PERL_DEBUG_READONLY_OPS) STATIC PP(pp_i_modulo_1) diff --git a/proto.h b/proto.h index 78fd691..0dad3b6 100644 --- a/proto.h +++ b/proto.h @@ -5302,10 +5302,10 @@ PERL_CALLCONV PADOFFSET Perl_op_refcnt_dec(pTHX_ OP *o) PERL_CALLCONV OP * Perl_op_refcnt_inc(pTHX_ OP *o); # if defined(PERL_IN_OP_C) -STATIC void S_Slab_to_rw(pTHX_ void *op) +STATIC void S_Slab_to_rw(pTHX_ OPSLAB *const slab) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SLAB_TO_RW \ - assert(op) + assert(slab) # endif #endif diff --git a/t/lib/warnings/op b/t/lib/warnings/op index 4f33700..69c3cd3 100644 --- a/t/lib/warnings/op +++ b/t/lib/warnings/op @@ -106,10 +106,15 @@ __END__ # op.c use warnings 'syntax' ; 1 if $a = 1 ; +1 if $a + = 1 ; no warnings 'syntax' ; 1 if $a = 1 ; +1 if $a + = 1 ; EXPECT Found = in conditional, should be == at - line 3. +Found = in conditional, should be == at - line 4. ######## # op.c use warnings 'syntax' ; @@ -664,28 +669,43 @@ Bareword found in conditional at - line 3. use warnings 'misc' ; open FH, "<abc" ; $x = 1 if $x = <FH> ; +$x = 1 if $x + = <FH> ; no warnings 'misc' ; $x = 1 if $x = <FH> ; +$x = 1 if $x + = <FH> ; EXPECT Value of <HANDLE> construct can be "0"; test with defined() at - line 4. +Value of <HANDLE> construct can be "0"; test with defined() at - line 5. ######## # op.c use warnings 'misc' ; opendir FH, "." ; $x = 1 if $x = readdir FH ; +$x = 1 if $x + = readdir FH ; no warnings 'misc' ; $x = 1 if $x = readdir FH ; +$x = 1 if $x + = readdir FH ; closedir FH ; EXPECT Value of readdir() operator can be "0"; test with defined() at - line 4. +Value of readdir() operator can be "0"; test with defined() at - line 5. ######## # op.c use warnings 'misc' ; $x = 1 if $x = <*> ; +$x = 1 if $x + = <*> ; no warnings 'misc' ; $x = 1 if $x = <*> ; +$x = 1 if $x + = <*> ; EXPECT Value of glob construct can be "0"; test with defined() at - line 3. +Value of glob construct can be "0"; test with defined() at - line 4. ######## # op.c use warnings 'misc' ; @@ -726,10 +746,15 @@ EXPECT use warnings 'redefine' ; sub fred {} sub fred {} +sub fred { # warning should be for this line +} no warnings 'redefine' ; sub fred {} +sub fred { +} EXPECT Subroutine fred redefined at - line 4. +Subroutine fred redefined at - line 5. ######## # op.c use warnings 'redefine' ; @@ -1479,3 +1504,24 @@ sub á áÆ () { 1 } EXPECT Constant subroutine main::á áÆ redefined at - line 5. ######## +# OPTION regex +sub DynaLoader::dl_error {}; +use warnings; +# We're testing that the warnings report the same line number: +eval <<'EOC' or die $@; +{ + DynaLoader::boot_DynaLoader("DynaLoader"); +} +EOC +eval <<'EOC' or die $@; +BEGIN { + DynaLoader::boot_DynaLoader("DynaLoader"); +} +1 +EOC +EXPECT +OPTION regex +\ASubroutine DynaLoader::dl_error redefined at \(eval 1\) line 2\. +(?s).* +Subroutine DynaLoader::dl_error redefined at \(eval 2\) line 2\. +######## -- Perl5 Master Repository
