In perl.git, the branch smoke-me/debug_readonly_ops has been updated <http://perl5.git.perl.org/perl.git/commitdiff/cc1608c8e25aa6bbfe1453fdae1f4454042a8e90?hp=043fec90e88a2e23823af40a5c0b59539fc58069>
- Log ----------------------------------------------------------------- commit cc1608c8e25aa6bbfe1453fdae1f4454042a8e90 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 11495c760fec69539b343ef0deae257a3eb1b0b4 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 0a2f7dc12323e98451ee48403b74bff4ec17bcdf 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 ----------------------------------------------------------------------- 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 f547316..cb26c72 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1803,7 +1803,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 14ca6fc..8beb0fe 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); } @@ -5831,6 +5846,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()", @@ -7017,8 +7034,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 @@ -7424,14 +7444,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 05a9edf..29db8ed 100644 --- a/pp.c +++ b/pp.c @@ -2364,7 +2364,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 @@ -2387,7 +2387,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 7670835..07cfd9a 100644 --- a/proto.h +++ b/proto.h @@ -5324,10 +5324,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
