Lookup overloaded assignment operators when trying to swap the arguments

[perl5.git] / gv.c

diff --git a/gv.c b/gv.c
index 9da6c1a..2befa71 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -318,7 +318,7 @@ Perl_gv_init_pvn(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, U32 flag
     const U32 old_type = SvTYPE(gv);
     const bool doproto = old_type > SVt_NULL;
     char * const proto = (doproto && SvPOK(gv))
     const U32 old_type = SvTYPE(gv);
     const bool doproto = old_type > SVt_NULL;
     char * const proto = (doproto && SvPOK(gv))

-       ? (SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0), SvPVX(gv))
+       ? ((void)(SvIsCOW(gv) && (sv_force_normal((SV *)gv), 0)), SvPVX(gv))

        : NULL;
     const STRLEN protolen = proto ? SvCUR(gv) : 0;
     const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;
        : NULL;
     const STRLEN protolen = proto ? SvCUR(gv) : 0;
     const U32 proto_utf8  = proto ? SvUTF8(gv) : 0;


@@ -482,6 +482,7 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
        gv = (GV *)newSV(0);
        gv_init(gv, stash, name, len, TRUE);
     }
        gv = (GV *)newSV(0);
        gv_init(gv, stash, name, len, TRUE);
     }

+    GvMULTI_on(gv);

     if (ampable) {
        ENTER;
        oldcurcop = PL_curcop;
     if (ampable) {
        ENTER;
        oldcurcop = PL_curcop;


@@ -516,15 +517,16 @@ S_maybe_add_coresub(pTHX_ HV * const stash, GV *gv,
        (void)hv_store(stash,name,len,(SV *)gv,0);
     if (ampable) {
        CvLVALUE_on(cv);
        (void)hv_store(stash,name,len,(SV *)gv,0);
     if (ampable) {
        CvLVALUE_on(cv);

-       newATTRSUB(oldsavestack_ix,
-                  newSVOP(OP_CONST, 0, SvREFCNT_inc_simple_NN(gv)),
+       newATTRSUB_flags(
+                  oldsavestack_ix, (OP *)gv,

                   NULL,NULL,
                   coresub_op(
                     opnum
                       ? newSVuv((UV)opnum)
                       : newSVpvn(name,len),
                     code, opnum
                   NULL,NULL,
                   coresub_op(
                     opnum
                       ? newSVuv((UV)opnum)
                       : newSVpvn(name,len),
                     code, opnum

-                  )
+                  ),
+                  1

        );
        assert(GvCV(gv) == cv);
        if (opnum != OP_VEC && opnum != OP_SUBSTR)
        );
        assert(GvCV(gv) == cv);
        if (opnum != OP_VEC && opnum != OP_SUBSTR)


@@ -909,8 +911,10 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags)
     sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
 #ifdef USE_ITHREADS
     av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop),
     sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0);
 #ifdef USE_ITHREADS
     av_push(superisa, newSVpvn_flags(CopSTASHPV(PL_curcop),

-                                     strlen(CopSTASHPV(PL_curcop)),
-                                     CopSTASH_flags(PL_curcop)
+                                     CopSTASH_len(PL_curcop) < 0
+                                       ? -CopSTASH_len(PL_curcop)
+                                       :  CopSTASH_len(PL_curcop),
+                                     SVf_UTF8*(CopSTASH_len(PL_curcop) < 0)

                                     ));
 #else
     av_push(superisa, newSVhek(CopSTASH(PL_curcop)
                                     ));
 #else
     av_push(superisa, newSVhek(CopSTASH(PL_curcop)


@@ -1399,18 +1403,6 @@ S_gv_magicalize_isa(pTHX_ GV *gv)
             NULL, 0);
 }
 
             NULL, 0);
 }
 

-STATIC void
-S_gv_magicalize_overload(pTHX_ GV *gv)
-{
-    HV* hv;
-
-    PERL_ARGS_ASSERT_GV_MAGICALIZE_OVERLOAD;
-
-    hv = GvHVn(gv);
-    GvMULTI_on(gv);
-    hv_magic(hv, NULL, PERL_MAGIC_overload);
-}
-

 GV *
 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                       const svtype sv_type)
 GV *
 Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                       const svtype sv_type)


@@ -1693,7 +1685,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 
     /* set up magic where warranted */
     if (stash != PL_defstash) { /* not the main stash */
 
     /* set up magic where warranted */
     if (stash != PL_defstash) { /* not the main stash */

-       /* We only have to check for four names here: EXPORT, ISA, OVERLOAD
+       /* We only have to check for three names here: EXPORT, ISA

           and VERSION. All the others apply only to the main stash or to
           CORE (which is checked right after this). */
        if (len > 2) {
           and VERSION. All the others apply only to the main stash or to
           CORE (which is checked right after this). */
        if (len > 2) {


@@ -1707,10 +1699,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                if (strEQ(name2, "SA"))
                    gv_magicalize_isa(gv);
                break;
                if (strEQ(name2, "SA"))
                    gv_magicalize_isa(gv);
                break;

-           case 'O':
-               if (strEQ(name2, "VERLOAD"))
-                   gv_magicalize_overload(gv);
-               break;

            case 'V':
                if (strEQ(name2, "ERSION"))
                    GvMULTI_on(gv);
            case 'V':
                if (strEQ(name2, "ERSION"))
                    GvMULTI_on(gv);


@@ -1758,11 +1746,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                    gv_magicalize_isa(gv);
                }
                break;
                    gv_magicalize_isa(gv);
                }
                break;

-           case 'O':
-               if (strEQ(name2, "VERLOAD")) {
-                   gv_magicalize_overload(gv);
-               }
-               break;

            case 'S':
                if (strEQ(name2, "IG")) {
                    HV *hv;
            case 'S':
                if (strEQ(name2, "IG")) {
                    HV *hv;


@@ -1913,7 +1896,11 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
             SvREADONLY_on(av);
 
             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)
             SvREADONLY_on(av);
 
             if (sv_type == SVt_PVHV || sv_type == SVt_PVGV)

+           {
+               if (addmg) (void)hv_store(stash,name,len,(SV *)gv,0);
+               addmg = 0;

                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);
                 require_tie_mod(gv, name, newSVpvs("Tie::Hash::NamedCapture"), "TIEHASH", 0);

+           }

 
             break;
        }
 
             break;
        }


@@ -2275,24 +2262,31 @@ Perl_Gv_AMupdate(pTHX_ HV *stash, bool destructing)
     int filled = 0, have_ovl = 0;
     int i, lim = 1;
 
     int filled = 0, have_ovl = 0;
     int i, lim = 1;
 

-    /* Work with "fallback" key, which we assume to be first in PL_AMG_names */
+    /* The first key in PL_AMG_names is the overloadedness indicator, which
+       allows us to skip overloading entries for non-overloaded classes. */

 
     /* Try to find via inheritance. */
     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);
 
     /* Try to find via inheritance. */
     GV *gv = gv_fetchmeth_pvn(stash, PL_AMG_names[0], 2, -1, 0);

-    SV * const sv = gv ? GvSV(gv) : NULL;

     CV* cv;
 
     if (!gv)
        lim = DESTROY_amg;              /* Skip overloading entries. */
     CV* cv;
 
     if (!gv)
        lim = DESTROY_amg;              /* Skip overloading entries. */

-#ifdef PERL_DONT_CREATE_GVSV
-    else if (!sv) {
+
+    else {
+      
+      /* The "fallback" key is special-cased here, being absent from the
+        list in PL_AMG_names. */
+
+      SV *sv;
+      gv = gv_fetchmeth_pvn(stash, "(fallback", 9, -1, 0);
+
+      if (!gv || !(sv = GvSV(gv)))

        NOOP;   /* Equivalent to !SvTRUE and !SvOK  */
        NOOP;   /* Equivalent to !SvTRUE and !SvOK  */

-    }
-#endif
-    else if (SvTRUE(sv))
+      else if (SvTRUE(sv))

        amt.fallback=AMGfallYES;
        amt.fallback=AMGfallYES;

-    else if (SvOK(sv))
+      else if (SvOK(sv))

        amt.fallback=AMGfallNEVER;
        amt.fallback=AMGfallNEVER;

+    }

 
     for (i = 1; i < lim; i++)
        amt.table[i] = NULL;
 
     for (i = 1; i < lim; i++)
        amt.table[i] = NULL;


@@ -2568,6 +2562,31 @@ Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
     return tmpsv ? tmpsv : ref;
 }
 
     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)
 {
 SV*
 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 {


@@ -2589,27 +2608,11 @@ 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 ) {
   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)
   }
 
   if (!(AMGf_noleft & flags) && SvAMAGIC(left)

-      && (stash = SvSTASH(SvRV(left)))
+      && (stash = SvSTASH(SvRV(left))) && Gv_AMG(stash)

       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
                        ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
       && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
       && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
                        ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table


@@ -2674,12 +2677,8 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
                 */
                SV* const newref = newSVsv(tmpRef);
                SvOBJECT_on(newref);
                 */
                SV* const newref = newSVsv(tmpRef);
                SvOBJECT_on(newref);

-               /* As a bit of a source compatibility hack, SvAMAGIC() and
-                  friends dereference an RV, to behave the same was as when
-                  overloading was stored on the reference, not the referant.
-                  Hence we can't use SvAMAGIC_on()
-               */
-               SvFLAGS(newref) |= SVf_AMAGIC;
+               /* No need to do SvAMAGIC_on here, as SvAMAGIC macros
+                  delegate to the stash. */

                SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
                return newref;
             }
                SvSTASH_set(newref, MUTABLE_HV(SvREFCNT_inc(SvSTASH(tmpRef))));
                return newref;
             }


@@ -2736,14 +2735,21 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
         }
         if (!cv) goto not_found;
     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)
         }
         if (!cv) goto not_found;
     } else if (!(AMGf_noright & flags) && SvAMAGIC(right)

-              && (stash = SvSTASH(SvRV(right)))
+              && (stash = SvSTASH(SvRV(right))) && Gv_AMG(stash)

               && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
               && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
                          ? (amtp = (AMT*)mg->mg_ptr)->table
                          : NULL))
               && (mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table))
               && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
                          ? (amtp = (AMT*)mg->mg_ptr)->table
                          : NULL))

-              && (cv = cvp[off=method])) { /* Method for right
-                                            * argument found */
-      lr=1;
+              && ((cv = cvp[off=method+assignshift])
+                  || (assign && amtp->fallback > AMGfallNEVER && /* fallback to
+                                                                  * usual method */
+                      (
+#ifdef DEBUGGING
+                       fl = 1,
+#endif
+                       cv = cvp[off=method])))) { /* Method for right
+                                                   * argument found */
+       lr=1;

     } else if (((cvp && amtp->fallback > AMGfallNEVER)
                 || (ocvp && oamtp->fallback > AMGfallNEVER))
               && !(flags & AMGf_unary)) {
     } else if (((cvp && amtp->fallback > AMGfallNEVER)
                 || (ocvp && oamtp->fallback > AMGfallNEVER))
               && !(flags & AMGf_unary)) {