Update Module-CoreList Changes file for 5.20141002 release

[perl5.git] / op.c

diff --git a/op.c b/op.c
index 57f78f1..08e6028 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
 
        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)
 {
 STATIC OP *
 S_no_fh_allowed(pTHX_ OP *o)
 {


@@ -546,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)
 {
 STATIC void
 S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
 {

-    SV * const namesv = cv_name((CV *)gv, NULL);
+    SV * const namesv = cv_name((CV *)gv, NULL, 0);

     PERL_ARGS_ASSERT_BAD_TYPE_GV;
  
     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
     PERL_ARGS_ASSERT_BAD_TYPE_GV;
  
     yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",


@@ -818,8 +807,6 @@ Perl_op_clear(pTHX_ OP *o)
                SvREFCNT_inc_simple_void(gv);
 #ifdef USE_ITHREADS
            if (cPADOPo->op_padix > 0) {
                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;
            }
                pad_swipe(cPADOPo->op_padix, TRUE);
                cPADOPo->op_padix = 0;
            }


@@ -886,8 +873,6 @@ Perl_op_clear(pTHX_ OP *o)
     case OP_PUSHRE:
 #ifdef USE_ITHREADS
         if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
     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
            pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
        }
 #else


@@ -1049,25 +1034,25 @@ Perl_op_refcnt_unlock(pTHX)
 =for apidoc op_sibling_splice
 
 A general function for editing the structure of an existing chain of
 =for apidoc op_sibling_splice
 
 A general function for editing the structure of an existing chain of

-op_sibling nodes. By analogy with the perl-level splice() function, allows
+op_sibling nodes.  By analogy with the perl-level splice() function, allows

 you to delete zero or more sequential nodes, replacing them with zero or
 more different nodes.  Performs the necessary op_first/op_last
 housekeeping on the parent node and op_sibling manipulation on the
 you to delete zero or more sequential nodes, replacing them with zero or
 more different nodes.  Performs the necessary op_first/op_last
 housekeeping on the parent node and op_sibling manipulation on the

-children. The last deleted node will be marked as as the last node by
+children.  The last deleted node will be marked as as the last node by

 updating the op_sibling or op_lastsib field as appropriate.
 
 Note that op_next is not manipulated, and nodes are not freed; that is the
 updating the op_sibling or op_lastsib field as appropriate.
 
 Note that op_next is not manipulated, and nodes are not freed; that is the

-responsibility of the caller. It also won't create a new list op for an
+responsibility of the caller.  It also won't create a new list op for an

 empty list etc; use higher-level functions like op_append_elem() for that.
 
 parent is the parent node of the sibling chain.
 
 empty list etc; use higher-level functions like op_append_elem() for that.
 
 parent is the parent node of the sibling chain.
 

-start is the node preceding the first node to be spliced. Node(s)
-following it will be deleted, and ops will be inserted after it. If it is
+start is the node preceding the first node to be spliced.  Node(s)
+following it will be deleted, and ops will be inserted after it.  If it is

 NULL, the first node onwards is deleted, and nodes are inserted at the
 beginning.
 
 NULL, the first node onwards is deleted, and nodes are inserted at the
 beginning.
 

-del_count is the number of nodes to delete. If zero, no nodes are deleted.
+del_count is the number of nodes to delete.  If zero, no nodes are deleted.

 If -1 or greater than or equal to the number of remaining kids, all
 remaining kids are deleted.
 
 If -1 or greater than or equal to the number of remaining kids, all
 remaining kids are deleted.
 


@@ -1171,7 +1156,7 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert)
 /*
 =for apidoc op_parent
 
 /*
 =for apidoc op_parent
 

-returns the parent OP of o, if it has a parent. Returns NULL otherwise.
+returns the parent OP of o, if it has a parent.  Returns NULL otherwise.

 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
 work.
 
 (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to
 work.
 


@@ -1745,6 +1730,7 @@ Perl_scalarvoid(pTHX_ OP *o)
            no_bareword_allowed(o);
        else {
            if (ckWARN(WARN_VOID)) {
            no_bareword_allowed(o);
        else {
            if (ckWARN(WARN_VOID)) {

+               NV nv;

                /* don't warn on optimised away booleans, eg 
                 * use constant Foo, 5; Foo || print; */
                if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)
                /* don't warn on optimised away booleans, eg 
                 * use constant Foo, 5; Foo || print; */
                if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT)


@@ -1752,7 +1738,7 @@ Perl_scalarvoid(pTHX_ OP *o)
                /* the constants 0 and 1 are permitted as they are
                   conventionally used as dummies in constructs like
                        1 while some_condition_with_side_effects;  */
                /* the constants 0 and 1 are permitted as they are
                   conventionally used as dummies in constructs like
                        1 while some_condition_with_side_effects;  */

-               else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
+               else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0))

                    useless = NULL;
                else if (SvPOK(sv)) {
                     SV * const dsv = newSVpvs("");
                    useless = NULL;
                else if (SvPOK(sv)) {
                     SV * const dsv = newSVpvs("");


@@ -5197,7 +5183,7 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
     padop->op_type = (OPCODE)type;
     padop->op_ppaddr = PL_ppaddr[type];
     padop->op_padix =
     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);
     SvREFCNT_dec(PAD_SVl(padop->op_padix));
     PAD_SETSV(padop->op_padix, sv);
     assert(sv);


@@ -5230,7 +5216,6 @@ Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
     PERL_ARGS_ASSERT_NEWGVOP;
 
 #ifdef USE_ITHREADS
     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));
     return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
 #else
     return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));


@@ -6378,10 +6363,11 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
     left->op_next = flip;
     right->op_next = flop;
 
     left->op_next = flip;
     right->op_next = flop;
 

-    range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
+    range->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);

     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);
     sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV);

-    flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY);
+    flip->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);;

     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);
     sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV);

+    SvPADTMP_on(PAD_SV(flip->op_targ));

 
     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
 
     flip->op_private =  left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;
     flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0;


@@ -7428,7 +7414,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     }
     if (const_sv) {
        SvREFCNT_inc_simple_void_NN(const_sv);
     }
     if (const_sv) {
        SvREFCNT_inc_simple_void_NN(const_sv);

-       SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
+       SvFLAGS(const_sv) |= SVs_PADTMP;

        if (cv) {
            assert(!CvROOT(cv) && !CvCONST(cv));
            cv_forget_slab(cv);
        if (cv) {
            assert(!CvROOT(cv) && !CvCONST(cv));
            cv_forget_slab(cv);


@@ -7620,7 +7606,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        else *spot = cv_clone(clonee);
        SvREFCNT_dec_NN(clonee);
        cv = *spot;
        else *spot = cv_clone(clonee);
        SvREFCNT_dec_NN(clonee);
        cv = *spot;

-       SvPADMY_on(cv);

     }
     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
        PADOFFSET depth = CvDEPTH(outcv);
     }
     if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) {
        PADOFFSET depth = CvDEPTH(outcv);


@@ -7669,8 +7654,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;
     bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
 #ifdef PERL_DEBUG_READONLY_OPS
     OPSLAB *slab = NULL;

-#endif

     bool special = FALSE;
     bool special = FALSE;

+#endif

 
     if (o_is_gv) {
        gv = (GV*)o;
 
     if (o_is_gv) {
        gv = (GV*)o;


@@ -7850,7 +7835,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     }
     if (const_sv) {
        SvREFCNT_inc_simple_void_NN(const_sv);
     }
     if (const_sv) {
        SvREFCNT_inc_simple_void_NN(const_sv);

-       SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
+       SvFLAGS(const_sv) |= SVs_PADTMP;

        if (cv) {
            assert(!CvROOT(cv) && !CvCONST(cv));
            cv_forget_slab(cv);
        if (cv) {
            assert(!CvROOT(cv) && !CvCONST(cv));
            cv_forget_slab(cv);


@@ -7900,11 +7885,14 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
                assert(CvGV(cv) == gv);
            }
            else {
                assert(CvGV(cv) == gv);
            }
            else {

+               dVAR;

                U32 hash;
                PERL_HASH(hash, name, namlen);
                CvNAME_HEK_set(cv,
                               share_hek(name,
                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));
            }
 
                                         hash));
            }
 


@@ -7962,10 +7950,13 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
     if (!CvHASGV(cv)) {
        if (isGV(gv)) CvGV_set(cv, gv);
        else {
     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,
            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);
                                         hash));
        }
        CvFILE_set_from_cop(cv, PL_curcop);


@@ -8034,7 +8025,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 
     if (block && has_name) {
        if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
 
     if (block && has_name) {
        if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {

-           SV * const tmpstr = cv_name(cv,NULL);
+           SV * const tmpstr = cv_name(cv,NULL,0);

            GV * const db_postponed = gv_fetchpvs("DB::postponed",
                                                  GV_ADDMULTI, SVt_PVHV);
            HV *hv;
            GV * const db_postponed = gv_fetchpvs("DB::postponed",
                                                  GV_ADDMULTI, SVt_PVHV);
            HV *hv;


@@ -8061,7 +8052,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
             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);

         }
     }
 
         }
     }
 


@@ -9033,7 +9027,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));
            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);
            PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
 #else
            kid->op_sv = SvREFCNT_inc_simple_NN(gv);


@@ -9527,7 +9520,7 @@ Perl_ck_readline(pTHX_ OP *o)
     }
     else {
        OP * const newop
     }
     else {
        OP * const newop

-           = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
+           = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));

        op_free(o);
        return newop;
     }
        op_free(o);
        return newop;
     }


@@ -9978,6 +9971,33 @@ Perl_ck_sort(pTHX_ OP *o)
            kid->op_next = kid;
            o->op_flags |= OPf_SPECIAL;
        }
            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);
     }
 
        firstkid = OP_SIBLING(firstkid);
     }


@@ -10395,7 +10415,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
 
        if (proto >= proto_end)
        {
 
        if (proto >= proto_end)
        {

-           SV * const namesv = cv_name((CV *)namegv, NULL);
+           SV * const namesv = cv_name((CV *)namegv, NULL, 0);

            yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
                                        SVfARG(namesv)), SvUTF8(namesv));
            return entersubop;
            yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf,
                                        SVfARG(namesv)), SvUTF8(namesv));
            return entersubop;


@@ -10550,7 +10570,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
            default:
            oops: {
                Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,
            default:
            oops: {
                Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf,

-                                 SVfARG(cv_name((CV *)namegv, NULL)),
+                                 SVfARG(cv_name((CV *)namegv, NULL, 0)),

                                  SVfARG(protosv));
             }
        }
                                  SVfARG(protosv));
             }
        }


@@ -10566,7 +10586,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
     if (!optional && proto_end > proto &&
        (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
     {
     if (!optional && proto_end > proto &&
        (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_'))
     {

-       SV * const namesv = cv_name((CV *)namegv, NULL);
+       SV * const namesv = cv_name((CV *)namegv, NULL, 0);

        yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
                                    SVfARG(namesv)), SvUTF8(namesv));
     }
        yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf,
                                    SVfARG(namesv)), SvUTF8(namesv));
     }


@@ -10759,7 +10779,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;
 {
     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);

 }
 
 /*
 }
 
 /*


@@ -10833,7 +10853,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)
            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;

     }
 }
 
     }
 }