Thread::Queue 2.11

[perl5.git] / pp_hot.c

diff --git a/pp_hot.c b/pp_hot.c
index cd1a885..64b5fc5 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -39,14 +39,7 @@ PP(pp_const)
 {
     dVAR;
     dSP;
-    if ( PL_op->op_flags & OPf_SPECIAL )
-        /* This is a const op added to hold the hints hash for
-           pp_entereval. The hash can be modified by the code
-           being eval'ed, so we return a copy instead. */
-        mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv));
-    else
-        /* Normal const. */
-        XPUSHs(cSVOP_sv);
+    XPUSHs(cSVOP_sv);
     RETURN;
 }
 
@@ -808,8 +801,6 @@ PP(pp_rv2av)
 {
     dVAR; dSP; dTOPss;
     const I32 gimme = GIMME_V;
-    static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
-    static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
     static const char an_array[] = "an ARRAY";
     static const char a_hash[] = "a HASH";
     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
@@ -828,8 +819,7 @@ PP(pp_rv2av)
        }
        else if (LVRET) {
            if (gimme != G_ARRAY)
-               Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
-                          : return_hash_to_lvalue_scalar);
+               goto croak_cant_return;
            SETs(sv);
            RETURN;
        }
@@ -845,9 +835,7 @@ PP(pp_rv2av)
            }
            else if (LVRET) {
                if (gimme != G_ARRAY)
-                   Perl_croak(aTHX_
-                              is_pp_rv2av ? return_array_to_lvalue_scalar
-                              : return_hash_to_lvalue_scalar);
+                   goto croak_cant_return;
                SETs(sv);
                RETURN;
            }
@@ -878,9 +866,7 @@ PP(pp_rv2av)
            }
            else if (LVRET) {
                if (gimme != G_ARRAY)
-                   Perl_croak(aTHX_
-                              is_pp_rv2av ? return_array_to_lvalue_scalar
-                              : return_hash_to_lvalue_scalar);
+                   goto croak_cant_return;
                SETs(sv);
                RETURN;
            }
@@ -930,6 +916,11 @@ PP(pp_rv2av)
     }
     }
     RETURN;
+
+ croak_cant_return:
+    Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
+              is_pp_rv2av ? "array" : "hash");
+    RETURN;
 }
 
 STATIC void
@@ -1029,8 +1020,14 @@ PP(pp_aassign)
                *(relem++) = sv;
                didstore = av_store(ary,i++,sv);
                if (magic) {
-                   if (SvSMAGICAL(sv))
+                   if (SvSMAGICAL(sv)) {
+                       /* More magic can happen in the mg_set callback, so we
+                        * backup the delaymagic for now. */
+                       U16 dmbak = PL_delaymagic;
+                       PL_delaymagic = 0;
                        mg_set(sv);
+                       PL_delaymagic = dmbak;
+                   }
                    if (!didstore)
                        sv_2mortal(sv);
                }
@@ -1060,8 +1057,12 @@ PP(pp_aassign)
                        duplicates += 2;
                    didstore = hv_store_ent(hash,sv,tmpstr,0);
                    if (magic) {
-                       if (SvSMAGICAL(tmpstr))
+                       if (SvSMAGICAL(tmpstr)) {
+                           U16 dmbak = PL_delaymagic;
+                           PL_delaymagic = 0;
                            mg_set(tmpstr);
+                           PL_delaymagic = dmbak;
+                       }
                        if (!didstore)
                            sv_2mortal(tmpstr);
                    }
@@ -1085,7 +1086,13 @@ PP(pp_aassign)
            }
            else
                sv_setsv(sv, &PL_sv_undef);
-           SvSETMAGIC(sv);
+
+           if (SvSMAGICAL(sv)) {
+               U16 dmbak = PL_delaymagic;
+               PL_delaymagic = 0;
+               mg_set(sv);
+               PL_delaymagic = dmbak;
+           }
            break;
        }
     }
@@ -2828,10 +2835,6 @@ try_autoload:
        if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
            && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
            sub_crush_depth(cv);
-#if 0
-       DEBUG_S(PerlIO_printf(Perl_debug_log,
-                             "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
-#endif
        RETURNOP(CvSTART(cv));
     }
     else {
@@ -3097,81 +3100,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
        }
     }
 
-    gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
-
-    if (!gv) {
-       /* This code tries to figure out just what went wrong with
-          gv_fetchmethod.  It therefore needs to duplicate a lot of
-          the internals of that function.  We can't move it inside
-          Perl_gv_fetchmethod_autoload(), however, since that would
-          cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
-          don't want that.
-       */
-       const char* leaf = name;
-       const char* sep = NULL;
-       const char* p;
-
-       for (p = name; *p; p++) {
-           if (*p == '\'')
-               sep = p, leaf = p + 1;
-           else if (*p == ':' && *(p + 1) == ':')
-               sep = p, leaf = p + 2;
-       }
-       if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
-           /* the method name is unqualified or starts with SUPER:: */
-#ifndef USE_ITHREADS
-           if (sep)
-               stash = CopSTASH(PL_curcop);
-#else
-           bool need_strlen = 1;
-           if (sep) {
-               packname = CopSTASHPV(PL_curcop);
-           }
-           else
-#endif
-           if (stash) {
-               HEK * const packhek = HvNAME_HEK(stash);
-               if (packhek) {
-                   packname = HEK_KEY(packhek);
-                   packlen = HEK_LEN(packhek);
-#ifdef USE_ITHREADS
-                   need_strlen = 0;
-#endif
-               } else {
-                   goto croak;
-               }
-           }
+    gv = gv_fetchmethod_flags(stash ? stash : (HV*)packsv, name,
+                             GV_AUTOLOAD | GV_CROAK);
 
-           if (!packname) {
-           croak:
-               Perl_croak(aTHX_
-                          "Can't use anonymous symbol table for method lookup");
-           }
-#ifdef USE_ITHREADS
-           if (need_strlen)
-               packlen = strlen(packname);
-#endif
+    assert(gv);
 
-       }
-       else {
-           /* the method name is qualified */
-           packname = name;
-           packlen = sep - name;
-       }
-       
-       /* we're relying on gv_fetchmethod not autovivifying the stash */
-       if (gv_stashpvn(packname, packlen, 0)) {
-           Perl_croak(aTHX_
-                      "Can't locate object method \"%s\" via package \"%.*s\"",
-                      leaf, (int)packlen, packname);
-       }
-       else {
-           Perl_croak(aTHX_
-                      "Can't locate object method \"%s\" via package \"%.*s\""
-                      " (perhaps you forgot to load \"%.*s\"?)",
-                      leaf, (int)packlen, packname, (int)packlen, packname);
-       }
-    }
     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
 }