Move amagic hint checking to new function

so that stringification will be able to use it, too.

diff --git a/embed.fnc b/embed.fnc
index 3d79971..0be9b59 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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/proto.h b/proto.h
index f0f7788..b5ae156 100644 (file)
--- 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);