X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_hot.c;h=64b5fc59f960ee7d72b6dba2943beedf5df5cbee;hb=19c4478c878cb3732a73314cc162df7f808d5d78;hp=61324bfc80f3cfbc0f16122794f92275f650f913;hpb=781e3f050073176aa21ffc243184a1cb57f4ec92;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_hot.c b/pp_hot.c index 61324bf..64b5fc5 100644 --- 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; } } @@ -2735,14 +2742,9 @@ PP(pp_entersub) } /* should call AUTOLOAD now? */ else { -try_autoload: - { - const bool is_method = cLISTOP->op_last && - (cLISTOP->op_last->op_type == OP_METHOD_NAMED || - cLISTOP->op_last->op_type == OP_METHOD); - +try_autoload: if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), - is_method))) + FALSE))) { cv = GvCV(autogv); } @@ -2752,7 +2754,6 @@ try_autoload: gv_efullname3(sub_name, gv, NULL); DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name)); } - } } if (!cv) DIE(aTHX_ "Not a CODE reference"); @@ -2834,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 { @@ -3103,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; }