This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Consistent indentation in AUTHORS
[perl5.git] / op.c
diff --git a/op.c b/op.c
index b96911f..163b6a8 100644 (file)
--- a/op.c
+++ b/op.c
@@ -496,17 +496,6 @@ Perl_op_refcnt_dec(pTHX_ OP *o)
        o->op_ppaddr = PL_ppaddr[type];         \
     } STMT_END
 
-STATIC SV*
-S_gv_ename(pTHX_ GV *gv)
-{
-    SV* const tmpsv = sv_newmortal();
-
-    PERL_ARGS_ASSERT_GV_ENAME;
-
-    gv_efullname3(tmpsv, gv, NULL);
-    return tmpsv;
-}
-
 STATIC OP *
 S_no_fh_allowed(pTHX_ OP *o)
 {
@@ -518,15 +507,6 @@ S_no_fh_allowed(pTHX_ OP *o)
 }
 
 STATIC OP *
-S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
-{
-    PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV;
-    yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)),
-                                    SvUTF8(namesv) | flags);
-    return o;
-}
-
-STATIC OP *
 S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags)
 {
     PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV;
@@ -543,16 +523,6 @@ S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags)
     return o;
 }
 
-STATIC OP *
-S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags)
-{
-    PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV;
-
-    yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)),
-                SvUTF8(namesv) | flags);
-    return o;
-}
-
 STATIC void
 S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid)
 {
@@ -565,7 +535,7 @@ S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP
 STATIC void
 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
 {
-    SV * const namesv = gv_ename(gv);
+    SV * const namesv = cv_name((CV *)gv, NULL);
     PERL_ARGS_ASSERT_BAD_TYPE_GV;
  
     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
@@ -837,8 +807,6 @@ Perl_op_clear(pTHX_ OP *o)
                SvREFCNT_inc_simple_void(gv);
 #ifdef USE_ITHREADS
            if (cPADOPo->op_padix > 0) {
-               /* No GvIN_PAD_off(cGVOPo_gv) here, because other references
-                * may still exist on the pad */
                pad_swipe(cPADOPo->op_padix, TRUE);
                cPADOPo->op_padix = 0;
            }
@@ -905,8 +873,6 @@ Perl_op_clear(pTHX_ OP *o)
     case OP_PUSHRE:
 #ifdef USE_ITHREADS
         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
-           /* No GvIN_PAD_off here, because other references may still
-            * exist on the pad */
            pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
        }
 #else
@@ -5216,7 +5182,7 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
     padop->op_type = (OPCODE)type;
     padop->op_ppaddr = PL_ppaddr[type];
     padop->op_padix =
-       pad_alloc(type, IS_PADGV(sv) ? SVf_READONLY : SVs_PADTMP);
+       pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP);
     SvREFCNT_dec(PAD_SVl(padop->op_padix));
     PAD_SETSV(padop->op_padix, sv);
     assert(sv);
@@ -5249,7 +5215,6 @@ Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
     PERL_ARGS_ASSERT_NEWGVOP;
 
 #ifdef USE_ITHREADS
-    GvIN_PAD_on(gv);
     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
 #else
     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
@@ -7688,8 +7653,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
 #ifdef PERL_DEBUG_READONLY_OPS
     OPSLAB *slab = NULL;
-#endif
     bool special = FALSE;
+#endif
 
     if (o_is_gv) {
        gv = (GV*)o;
@@ -7919,11 +7884,14 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
                assert(CvGV(cv) == gv);
            }
            else {
+               dVAR;
                U32 hash;
                PERL_HASH(hash, name, namlen);
                CvNAME_HEK_set(cv,
                               share_hek(name,
-                                        name_is_utf8 ? -namlen : namlen,
+                                        name_is_utf8
+                                           ? -(SSize_t)namlen
+                                           :  (SSize_t)namlen,
                                         hash));
            }
 
@@ -7981,10 +7949,13 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     if (!CvHASGV(cv)) {
        if (isGV(gv)) CvGV_set(cv, gv);
        else {
+            dVAR;
            U32 hash;
            PERL_HASH(hash, name, namlen);
            CvNAME_HEK_set(cv, share_hek(name,
-                                        name_is_utf8 ? -namlen : namlen,
+                                        name_is_utf8
+                                           ? -(SSize_t)namlen
+                                           :  (SSize_t)namlen,
                                         hash));
        }
        CvFILE_set_from_cop(cv, PL_curcop);
@@ -8080,7 +8051,10 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
             if (PL_parser && PL_parser->error_count)
                 clear_special_blocks(name, gv, cv);
             else
-                special = process_special_blocks(floor, name, gv, cv);
+#ifdef PERL_DEBUG_READONLY_OPS
+                special =
+#endif
+                    process_special_blocks(floor, name, gv, cv);
         }
     }
 
@@ -9052,7 +9026,6 @@ Perl_ck_rvconst(pTHX_ OP *o)
            assert (sizeof(PADOP) <= sizeof(SVOP));
            kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
            SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
-           if (isGV(gv)) GvIN_PAD_on(gv);
            PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
 #else
            kid->op_sv = SvREFCNT_inc_simple_NN(gv);
@@ -9997,6 +9970,33 @@ Perl_ck_sort(pTHX_ OP *o)
            kid->op_next = kid;
            o->op_flags |= OPf_SPECIAL;
        }
+       else if (kid->op_type == OP_CONST
+             && kid->op_private & OPpCONST_BARE) {
+           char tmpbuf[256];
+           STRLEN len;
+           PADOFFSET off;
+           const char * const name = SvPV(kSVOP_sv, len);
+           *tmpbuf = '&';
+           assert (len < 256);
+           Copy(name, tmpbuf+1, len, char);
+           off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv));
+           if (off != NOT_IN_PAD) {
+               if (PAD_COMPNAME_FLAGS_isOUR(off)) {
+                   SV * const fq =
+                       newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off)));
+                   sv_catpvs(fq, "::");
+                   sv_catsv(fq, kSVOP_sv);
+                   SvREFCNT_dec_NN(kSVOP_sv);
+                   kSVOP->op_sv = fq;
+               }
+               else {
+                   OP * const padop = newOP(OP_PADCV, 0);
+                   padop->op_targ = off;
+                   cUNOPx(firstkid)->op_first = padop;
+                   op_free(kid);
+               }
+           }
+       }
 
        firstkid = OP_SIBLING(firstkid);
     }
@@ -10413,7 +10413,12 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
        OP* o3 = aop;
 
        if (proto >= proto_end)
-           return too_many_arguments_sv(entersubop, gv_ename(namegv), 0);
+       {
+           SV * const namesv = cv_name((CV *)namegv, NULL);
+           yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
+                                       SVfARG(namesv)), SvUTF8(namesv));
+           return entersubop;
+       }
 
        switch (*proto) {
            case ';':
@@ -10563,10 +10568,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
                continue;
            default:
            oops: {
-                SV* const tmpsv = sv_newmortal();
-                gv_efullname3(tmpsv, namegv, NULL);
                Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
-                       SVfARG(tmpsv), SVfARG(protosv));
+                                 SVfARG(cv_name((CV *)namegv, NULL)),
+                                 SVfARG(protosv));
             }
        }
 
@@ -10580,7 +10584,11 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
     }
     if (!optional && proto_end > proto &&
        (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
-       return too_few_arguments_sv(entersubop, gv_ename(namegv), 0);
+    {
+       SV * const namesv = cv_name((CV *)namegv, NULL);
+       yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
+                                   SVfARG(namesv)), SvUTF8(namesv));
+    }
     return entersubop;
 }
 
@@ -10761,7 +10769,7 @@ S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p,
     } else {
        *ckfun_p = Perl_ck_entersub_args_proto_or_list;
        *ckobj_p = (SV*)cv;
-       if (flagsp) *flagsp = MGf_REQUIRE_GV;
+       if (flagsp) *flagsp = 0;
     }
 }
 
@@ -10770,7 +10778,7 @@ Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
 {
     PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER;
     PERL_UNUSED_CONTEXT;
-    return S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
+    S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL);
 }
 
 /*
@@ -10844,7 +10852,7 @@ Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun,
            callmg->mg_flags |= MGf_REFCOUNTED;
        }
        callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV)
-                        | (flags & MGf_REQUIRE_GV) | MGf_COPY;
+                        | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY;
     }
 }
 
Unnamed repository; edit this file 'description' to name the repository.