In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/da60b1cba9b0c916427ac3d445d7b8604cb52295?hp=c57800287bb7332d399cc08ed7d34606d6640e22>
- Log ----------------------------------------------------------------- commit da60b1cba9b0c916427ac3d445d7b8604cb52295 Author: Father Chrysostomos <[email protected]> Date: Tue Jan 24 12:33:49 2012 -0800 Increase $overload::VERSION to 1.18 M lib/overload.pm commit 4403f0436417f874935b2f95d48b8fc6d7a7d624 Author: Father Chrysostomos <[email protected]> Date: Wed Jan 18 13:03:32 2012 -0800 In overload::AddrRef, use âno overloadingâ This speeds this up by about 13 times. M lib/overload.pm commit a75c6ed6bbe8051aad5c980a7e52906076b66543 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 commit 8d5692911401401dd403c3c2aa0aa3eca63171a4 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 ----------------------------------------------------------------------- Summary of changes: embed.fnc | 1 + embed.h | 1 + gv.c | 43 ++++++++++++++++++++++++++----------------- lib/overload.pm | 15 +++------------ lib/overloading.t | 15 ++++++++++++++- proto.h | 1 + sv.c | 5 ++++- 7 files changed, 50 insertions(+), 31 deletions(-) diff --git a/embed.fnc b/embed.fnc index 3d79971..0be9b59 100644 --- a/embed.fnc +++ b/embed.fnc @@ -179,6 +179,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 93d265f..5190062 100644 --- a/embed.h +++ b/embed.h @@ -983,6 +983,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 e99af67..dca0fa2 100644 --- a/gv.c +++ b/gv.c @@ -2574,6 +2574,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) { @@ -2595,23 +2620,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/overload.pm b/lib/overload.pm index 90463b3..0f074e4 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -1,6 +1,6 @@ package overload; -our $VERSION = '1.17'; +our $VERSION = '1.18'; %ops = ( with_assign => "+ - * / % ** << >> x .", @@ -113,17 +113,8 @@ sub Method { } sub AddrRef { - my $package = ref $_[0]; - return "$_[0]" unless $package; - - local $@; - local $!; - require Scalar::Util; - my $class = Scalar::Util::blessed($_[0]); - my $class_prefix = defined($class) ? "$class=" : ""; - my $type = Scalar::Util::reftype($_[0]); - my $addr = Scalar::Util::refaddr($_[0]); - return sprintf("%s%s(0x%x)", $class_prefix, $type, $addr); + no overloading; + "$_[0]"; } *StrVal = *AddrRef; 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 f0f7788..b5ae156 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 c1ece77..2dce137 100644 --- a/sv.c +++ b/sv.c @@ -2809,7 +2809,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
