Change spaces to tabs for t/op/tie_fetch_count.t in MANIFEST

[perl5.git] / op.c

diff --git a/op.c b/op.c
index f667164..9539248 100644 (file)
--- a/op.c
+++ b/op.c
@@ -103,7 +103,14 @@ recursive, but it's recursive on basic blocks, not on tree nodes.
 #include "perl.h"
 #include "keywords.h"
 
-#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
+#define CALL_A_PEEP(peep, o) CALL_FPTR((peep)->fn)(aTHX_ o, peep)
+
+#define CALL_PEEP(o)                                                   \
+    STMT_START {                                                       \
+       peep_next_t _next_peep = { PL_peepp, NULL };                    \
+       CALL_A_PEEP(&_next_peep, o);                                    \
+    } STMT_END
+
 #define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
 
 #if defined(PL_OP_SLAB_ALLOC)
@@ -2305,17 +2312,21 @@ Perl_scope(pTHX_ OP *o)
     }
     return o;
 }
-       
+
 int
 Perl_block_start(pTHX_ int full)
 {
     dVAR;
     const int retval = PL_savestack_ix;
+
     pad_block_start(full);
     SAVEHINTS();
     PL_hints &= ~HINT_BLOCK_SCOPE;
     SAVECOMPILEWARNINGS();
     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
+
+    CALL_BLOCK_HOOKS(start, full);
+
     return retval;
 }
 
@@ -2324,15 +2335,40 @@ Perl_block_end(pTHX_ I32 floor, OP *seq)
 {
     dVAR;
     const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
-    OP* const retval = scalarseq(seq);
+    OP* retval = scalarseq(seq);
+
+    CALL_BLOCK_HOOKS(pre_end, &retval);
+
     LEAVE_SCOPE(floor);
     CopHINTS_set(&PL_compiling, PL_hints);
     if (needblockscope)
        PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
     pad_leavemy();
+
+    CALL_BLOCK_HOOKS(post_end, &retval);
+
     return retval;
 }
 
+/*
+=head1 Compile-time scope hooks
+
+=for apidoc Ao||blockhook_register
+
+Register a set of hooks to be called when the Perl lexical scope changes
+at compile time. See L<perlguts/"Compile-time scope hooks">.
+
+=cut
+*/
+
+void
+Perl_blockhook_register(pTHX_ BHK *hk)
+{
+    PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
+
+    Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
+}
+
 STATIC OP *
 S_newDEFSVOP(pTHX)
 {
@@ -5430,7 +5466,7 @@ Perl_cv_undef(pTHX_ CV *cv)
        LEAVE;
     }
     SvPOK_off(MUTABLE_SV(cv));         /* forget prototype */
-    CvGV(cv) = NULL;
+    CvGV_set(cv, NULL);
 
     pad_undef(cv);
 
@@ -5447,8 +5483,9 @@ Perl_cv_undef(pTHX_ CV *cv)
     if (CvISXSUB(cv) && CvXSUB(cv)) {
        CvXSUB(cv) = NULL;
     }
-    /* delete all flags except WEAKOUTSIDE */
-    CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
+    /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
+     * ref status of CvOUTSIDE and CvGV */
+    CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
 }
 
 void
@@ -5631,7 +5668,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     dVAR;
     GV *gv;
     const char *ps;
-    STRLEN ps_len;
+    STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
     register CV *cv = NULL;
     SV *const_sv;
     /* If the subroutine has no body, no attributes, and no builtin attributes
@@ -5815,6 +5852,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
            if (PERLDB_INTER)/* Advice debugger on the new sub. */
              ++PL_sub_generation;
+           if (CvSTASH(cv))
+               sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
        }
        else {
            /* Might have had built-in attributes applied -- propagate them. */
@@ -5840,9 +5879,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        }
     }
     if (!CvGV(cv)) {
-       CvGV(cv) = gv;
+       CvGV_set(cv, gv);
        CvFILE_set_from_cop(cv, PL_curcop);
        CvSTASH(cv) = PL_curstash;
+       if (PL_curstash)
+           Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
     }
     if (attrs) {
        /* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
@@ -6200,7 +6241,9 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
             mro_method_changed_in(GvSTASH(gv)); /* newXS */
        }
     }
-    CvGV(cv) = gv;
+    if (!name)
+       CvANON_on(cv);
+    CvGV_set(cv, gv);
     (void)gv_fetchfile(filename);
     CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
                                   an external constant string */
@@ -6209,8 +6252,6 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
 
     if (name)
        process_special_blocks(name, gv, cv);
-    else
-       CvANON_on(cv);
 
     return cv;
 }
@@ -6251,7 +6292,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
     }
     cv = PL_compcv;
     GvFORM(gv) = cv;
-    CvGV(cv) = gv;
+    CvGV_set(cv, gv);
     CvFILE_set_from_cop(cv, PL_curcop);
 
 
@@ -7167,11 +7208,12 @@ Perl_ck_glob(pTHX_ OP *o)
        ENTER;
        Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
                newSVpvs("File::Glob"), NULL, NULL, NULL);
-       gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
-       glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
-       GvCV(gv) = GvCV(glob_gv);
-       SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
-       GvIMPORTED_CV_on(gv);
+       if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
+           gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
+           GvCV(gv) = GvCV(glob_gv);
+           SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
+           GvIMPORTED_CV_on(gv);
+       }
        LEAVE;
     }
 #endif /* PERL_EXTERNAL_GLOB */
@@ -8480,11 +8522,13 @@ S_is_inplace_av(pTHX_ OP *o, OP *oright) {
  * peep() is called */
 
 void
-Perl_peep(pTHX_ register OP *o)
+Perl_peep(pTHX_ register OP *o, peep_next_t *next_peep)
 {
     dVAR;
     register OP* oldop = NULL;
 
+    PERL_ARGS_ASSERT_PEEP;
+
     if (!o || o->op_opt)
        return;
     ENTER;
@@ -8679,7 +8723,7 @@ Perl_peep(pTHX_ register OP *o)
             sop = fop->op_sibling;
            while (cLOGOP->op_other->op_type == OP_NULL)
                cLOGOP->op_other = cLOGOP->op_other->op_next;
-           peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
+           CALL_A_PEEP(next_peep, cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
           
           stitch_keys:     
            o->op_opt = 1;
@@ -8730,20 +8774,20 @@ Perl_peep(pTHX_ register OP *o)
        case OP_ONCE:
            while (cLOGOP->op_other->op_type == OP_NULL)
                cLOGOP->op_other = cLOGOP->op_other->op_next;
-           peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
+           CALL_A_PEEP(next_peep, cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
            break;
 
        case OP_ENTERLOOP:
        case OP_ENTERITER:
            while (cLOOP->op_redoop->op_type == OP_NULL)
                cLOOP->op_redoop = cLOOP->op_redoop->op_next;
-           peep(cLOOP->op_redoop);
+           CALL_A_PEEP(next_peep, cLOOP->op_redoop);
            while (cLOOP->op_nextop->op_type == OP_NULL)
                cLOOP->op_nextop = cLOOP->op_nextop->op_next;
-           peep(cLOOP->op_nextop);
+           CALL_A_PEEP(next_peep, cLOOP->op_nextop);
            while (cLOOP->op_lastop->op_type == OP_NULL)
                cLOOP->op_lastop = cLOOP->op_lastop->op_next;
-           peep(cLOOP->op_lastop);
+           CALL_A_PEEP(next_peep, cLOOP->op_lastop);
            break;
 
        case OP_SUBST:
@@ -8752,7 +8796,7 @@ Perl_peep(pTHX_ register OP *o)
                   cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
                cPMOP->op_pmstashstartu.op_pmreplstart
                    = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
-           peep(cPMOP->op_pmstashstartu.op_pmreplstart);
+           CALL_A_PEEP(next_peep, cPMOP->op_pmstashstartu.op_pmreplstart);
            break;
 
        case OP_EXEC: