In perl.git, the branch davem/re_eval has been updated <http://perl5.git.perl.org/perl.git/commitdiff/0f37f4a9bafe3e375710bc63df2fffce6f3f63cc?hp=b93ed387fefcbafe93612ae457574ac214f13f3e>
- Log ----------------------------------------------------------------- commit 0f37f4a9bafe3e375710bc63df2fffce6f3f63cc Author: Father Chrysostomos <[email protected]> Date: Tue Jan 24 09:46:11 2012 -0800 Move amagic hint checking to new function so that stringification will be able to use it, too. M embed.fnc M embed.h M gv.c M proto.h commit bb1b2c9166af95f179cbe995a8eb16c8114d29d0 Author: Father Chrysostomos <[email protected]> Date: Tue Jan 24 10:24:21 2012 -0800 [perl #108780] Make âno overloadingâ work with qr// Traditionally, overload::StrVal(qr//) has returned Regexp=SCALAR(0xc0ffee), and later Regexp=REGEXP(0xc0c0a) when regexps were made into first-class SVs. When the overloading pragma was added in 5.10.1, qr// things were not accounted for, so they would still stringify as (?-xism:) even with âno overloadingâ (or as (?^:) under 5.14). This commit makes the overloading pragma work with qr// things, so that they stringify the same way as overload::StrVal; i.e., as Regexp=REGEXP(0xbe600d). M lib/overloading.t M sv.c ----------------------------------------------------------------------- Summary of changes: embed.fnc | 1 + embed.h | 1 + gv.c | 43 ++++++++++++++++++++++++++----------------- lib/overloading.t | 15 ++++++++++++++- proto.h | 1 + sv.c | 5 ++++- 6 files changed, 47 insertions(+), 19 deletions(-) diff --git a/embed.fnc b/embed.fnc index bb59a8d..44c43e0 100644 --- a/embed.fnc +++ b/embed.fnc @@ -178,6 +178,7 @@ XEop |bool |try_amagic_bin |int method|int flags XEop |bool |try_amagic_un |int method|int flags Ap |SV* |amagic_call |NN SV* left|NN SV* right|int method|int dir Ap |SV * |amagic_deref_call|NN SV *ref|int method +p |bool |amagic_is_enabled|int method Ap |int |Gv_AMupdate |NN HV* stash|bool destructing ApR |CV* |gv_handler |NULLOK HV* stash|I32 id Apd |OP* |op_append_elem |I32 optype|NULLOK OP* first|NULLOK OP* last diff --git a/embed.h b/embed.h index c3dd234..c8b8e98 100644 --- a/embed.h +++ b/embed.h @@ -977,6 +977,7 @@ #endif #ifdef PERL_CORE #define allocmy(a,b,c) Perl_allocmy(aTHX_ a,b,c) +#define amagic_is_enabled(a) Perl_amagic_is_enabled(aTHX_ a) #define apply(a,b,c) Perl_apply(aTHX_ a,b,c) #define bind_match(a,b,c) Perl_bind_match(aTHX_ a,b,c) #define block_end(a,b) Perl_block_end(aTHX_ a,b) diff --git a/gv.c b/gv.c index 37a1bd9..a16a0a1 100644 --- a/gv.c +++ b/gv.c @@ -2571,6 +2571,31 @@ Perl_amagic_deref_call(pTHX_ SV *ref, int method) { return tmpsv ? tmpsv : ref; } +bool +Perl_amagic_is_enabled(pTHX_ int method) +{ + SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0); + + assert(PL_curcop->cop_hints & HINT_NO_AMAGIC); + + if ( !lex_mask || !SvOK(lex_mask) ) + /* overloading lexically disabled */ + return FALSE; + else if ( lex_mask && SvPOK(lex_mask) ) { + /* we have an entry in the hints hash, check if method has been + * masked by overloading.pm */ + STRLEN len; + const int offset = method / 8; + const int bit = method % 8; + char *pv = SvPV(lex_mask, len); + + /* Bit set, so this overloading operator is disabled */ + if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) + return FALSE; + } + return TRUE; +} + SV* Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { @@ -2592,23 +2617,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PERL_ARGS_ASSERT_AMAGIC_CALL; if ( PL_curcop->cop_hints & HINT_NO_AMAGIC ) { - SV *lex_mask = cop_hints_fetch_pvs(PL_curcop, "overloading", 0); - - if ( !lex_mask || !SvOK(lex_mask) ) - /* overloading lexically disabled */ - return NULL; - else if ( lex_mask && SvPOK(lex_mask) ) { - /* we have an entry in the hints hash, check if method has been - * masked by overloading.pm */ - STRLEN len; - const int offset = method / 8; - const int bit = method % 8; - char *pv = SvPV(lex_mask, len); - - /* Bit set, so this overloading operator is disabled */ - if ( (STRLEN)offset < len && pv[offset] & ( 1 << bit ) ) - return NULL; - } + if (!amagic_is_enabled(method)) return NULL; } if (!(AMGf_noleft & flags) && SvAMAGIC(left) diff --git a/lib/overloading.t b/lib/overloading.t index 2e1fb40..787edb1 100644 --- a/lib/overloading.t +++ b/lib/overloading.t @@ -1,6 +1,6 @@ #./perl -use Test::More tests => 35; +use Test::More tests => 46; use Scalar::Util qw(refaddr); @@ -18,20 +18,25 @@ use Scalar::Util qw(refaddr); } my $x = Stringifies->new; +my $y = qr//; +my $ystr = "$y"; is( "$x", "foo", "stringifies" ); +is( "$y", $ystr, "stringifies qr//" ); is( 0 + $x, 42, "numifies" ); is( cos($x), "far side of overload table", "cosinusfies" ); { no overloading; is( "$x", overload::StrVal($x), "no stringification" ); + is( "$y", overload::StrVal($y), "no stringification of qr//" ); is( 0 + $x, refaddr($x), "no numification" ); is( cos($x), cos(refaddr($x)), "no cosinusfication" ); { no overloading '""'; is( "$x", overload::StrVal($x), "no stringification" ); + is( "$y", overload::StrVal($y), "no stringification of qr//" ); is( 0 + $x, refaddr($x), "no numification" ); is( cos($x), cos(refaddr($x)), "no cosinusfication" ); } @@ -41,12 +46,14 @@ is( cos($x), "far side of overload table", "cosinusfies" ); no overloading '""'; is( "$x", overload::StrVal($x), "no stringification" ); + is( "$y", overload::StrVal($y), "no stringification of qr//" ); is( 0 + $x, 42, "numifies" ); is( cos($x), "far side of overload table", "cosinusfies" ); { no overloading; is( "$x", overload::StrVal($x), "no stringification" ); + is( "$y", overload::StrVal($y), "no stringification of qr//" ); is( 0 + $x, refaddr($x), "no numification" ); is( cos($x), cos(refaddr($x)), "no cosinusfication" ); } @@ -54,34 +61,40 @@ is( cos($x), "far side of overload table", "cosinusfies" ); use overloading '""'; is( "$x", "foo", "stringifies" ); + is( "$y", $ystr, "stringifies qr//" ); is( 0 + $x, 42, "numifies" ); is( cos($x), "far side of overload table", "cosinusfies" ); no overloading '0+'; is( "$x", "foo", "stringifies" ); + is( "$y", $ystr, "stringifies qr//" ); is( 0 + $x, refaddr($x), "no numification" ); is( cos($x), "far side of overload table", "cosinusfies" ); { no overloading '""'; is( "$x", overload::StrVal($x), "no stringification" ); + is( "$y", overload::StrVal($y), "no stringification of qr//" ); is( 0 + $x, refaddr($x), "no numification" ); is( cos($x), "far side of overload table", "cosinusfies" ); { use overloading; is( "$x", "foo", "stringifies" ); + is( "$y", $ystr, "stringifies qr//" ); is( 0 + $x, 42, "numifies" ); is( cos($x), "far side of overload table", "cosinusfies" ); } } is( "$x", "foo", "stringifies" ); + is( "$y", $ystr, "stringifies qr//" ); is( 0 + $x, refaddr($x), "no numification" ); is( cos($x), "far side of overload table", "cosinusfies" ); no overloading "cos"; is( "$x", "foo", "stringifies" ); + is( "$y", $ystr, "stringifies qr//" ); is( 0 + $x, refaddr($x), "no numification" ); is( cos($x), cos(refaddr($x)), "no cosinusfication" ); diff --git a/proto.h b/proto.h index 5b540a3..e9ccce9 100644 --- a/proto.h +++ b/proto.h @@ -75,6 +75,7 @@ PERL_CALLCONV SV * Perl_amagic_deref_call(pTHX_ SV *ref, int method) #define PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL \ assert(ref) +PERL_CALLCONV bool Perl_amagic_is_enabled(pTHX_ int method); PERL_CALLCONV I32 Perl_apply(pTHX_ I32 type, SV** mark, SV** sp) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); diff --git a/sv.c b/sv.c index 019e8dd..fa08d01 100644 --- a/sv.c +++ b/sv.c @@ -2807,7 +2807,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags if (!referent) { len = 7; retval = buffer = savepvn("NULLREF", len); - } else if (SvTYPE(referent) == SVt_REGEXP) { + } else if (SvTYPE(referent) == SVt_REGEXP && ( + !(PL_curcop->cop_hints & HINT_NO_AMAGIC) + || amagic_is_enabled(string_amg) + )) { REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); I32 seen_evals = 0; -- Perl5 Master Repository
