This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
op.c: update comment about compiler warnings
[perl5.git] / pp_ctl.c
index 211f0bf..011da56 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -165,7 +165,8 @@ PP(pp_regcomp)
     }
 
 
-    if (TAINTING_get && TAINT_get) {
+    assert(TAINTING_get || !TAINT_get);
+    if (TAINT_get) {
        SvTAINTED_on((SV*)new_re);
         RX_TAINT_on(new_re);
     }
@@ -928,35 +929,29 @@ PP(pp_grepstart)
     dSP;
     SV *src;
 
-    if (PL_stack_base + *PL_markstack_ptr == SP) {
+    if (PL_stack_base + TOPMARK == SP) {
        (void)POPMARK;
        if (GIMME_V == G_SCALAR)
            mXPUSHi(0);
        RETURNOP(PL_op->op_next->op_next);
     }
-    PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
+    PL_stack_sp = PL_stack_base + TOPMARK + 1;
     Perl_pp_pushmark(aTHX);                            /* push dst */
     Perl_pp_pushmark(aTHX);                            /* push src */
     ENTER_with_name("grep");                                   /* enter outer scope */
 
     SAVETMPS;
-    if (PL_op->op_private & OPpGREP_LEX)
-       SAVESPTR(PAD_SVl(PL_op->op_targ));
-    else
-       SAVE_DEFSV;
+    SAVE_DEFSV;
     ENTER_with_name("grep_item");                                      /* enter inner scope */
     SAVEVPTR(PL_curpm);
 
-    src = PL_stack_base[*PL_markstack_ptr];
+    src = PL_stack_base[TOPMARK];
     if (SvPADTMP(src)) {
-       src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
+       src = PL_stack_base[TOPMARK] = sv_mortalcopy(src);
        PL_tmps_floor++;
     }
     SvTEMP_off(src);
-    if (PL_op->op_private & OPpGREP_LEX)
-       PAD_SVl(PL_op->op_targ) = src;
-    else
-       DEFSV_set(src);
+    DEFSV_set(src);
 
     PUTBACK;
     if (PL_op->op_type == OP_MAPSTART)
@@ -968,7 +963,7 @@ PP(pp_mapwhile)
 {
     dSP;
     const I32 gimme = GIMME_V;
-    I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
+    I32 items = (SP - PL_stack_base) - TOPMARK; /* how many new items */
     I32 count;
     I32 shift;
     SV** src;
@@ -1069,7 +1064,7 @@ PP(pp_mapwhile)
     LEAVE_with_name("grep_item");                                      /* exit inner scope */
 
     /* All done yet? */
-    if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
+    if (PL_markstack_ptr[-1] > TOPMARK) {
 
        (void)POPMARK;                          /* pop top */
        LEAVE_with_name("grep");                                        /* exit outer scope */
@@ -1078,15 +1073,8 @@ PP(pp_mapwhile)
        (void)POPMARK;                          /* pop dst */
        SP = PL_stack_base + POPMARK;           /* pop original mark */
        if (gimme == G_SCALAR) {
-           if (PL_op->op_private & OPpGREP_LEX) {
-               SV* sv = sv_newmortal();
-               sv_setiv(sv, items);
-               PUSHs(sv);
-           }
-           else {
                dTARGET;
                XPUSHi(items);
-           }
        }
        else if (gimme == G_ARRAY)
            SP += items;
@@ -1104,10 +1092,7 @@ PP(pp_mapwhile)
             src = sv_mortalcopy(src);
         }
        SvTEMP_off(src);
-       if (PL_op->op_private & OPpGREP_LEX)
-           PAD_SVl(PL_op->op_targ) = src;
-       else
-           DEFSV_set(src);
+       DEFSV_set(src);
 
        RETURNOP(cLOGOP->op_other);
     }
@@ -1206,7 +1191,11 @@ PP(pp_flop)
                     /* The wraparound of signed integers is undefined
                      * behavior, but here we aim for count >=1, and
                      * negative count is just wrong. */
-                    if (n < 1)
+                    if (n < 1
+#if IVSIZE > Size_t_size
+                        || n > SSize_t_MAX
+#endif
+                        )
                         overflow = TRUE;
                 }
                 if (overflow)
@@ -1349,22 +1338,17 @@ I32
 Perl_block_gimme(pTHX)
 {
     const I32 cxix = dopoptosub(cxstack_ix);
+    U8 gimme;
     if (cxix < 0)
        return G_VOID;
 
-    switch (cxstack[cxix].blk_gimme) {
-    case G_VOID:
-       return G_VOID;
-    case G_SCALAR:
-       return G_SCALAR;
-    case G_ARRAY:
-       return G_ARRAY;
-    default:
-       Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
-    }
-    NOT_REACHED; /* NOTREACHED */
+    gimme = (cxstack[cxix].blk_gimme & G_WANT);
+    if (!gimme)
+       Perl_croak(aTHX_ "panic: bad gimme: %d\n", gimme);
+    return gimme;
 }
 
+
 I32
 Perl_is_lvalue_sub(pTHX)
 {
@@ -1824,7 +1808,7 @@ PP(pp_caller)
                       cx->blk_sub.retop, TRUE);
     if (!lcop)
        lcop = cx->blk_oldcop;
-    mPUSHi((I32)CopLINE(lcop));
+    mPUSHu(CopLINE(lcop));
     if (!has_arg)
        RETURN;
     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
@@ -2150,7 +2134,6 @@ PP(pp_enteriter)
        save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
        *svp = newSV(0);
        itervar = (void *)gv;
-       save_aliased_sv(gv);
     }
     else {
        SV * const sv = POPs;
@@ -2279,14 +2262,16 @@ PP(pp_leaveloop)
     return NORMAL;
 }
 
-/* handle most of the activity of returning from an lvalue sub.
- * Called by pp_leavesublv and pp_return.
- * For pp_leavesublv, base is null; for pp_return, its the base
- * of the args to be returned (i.e. the mark on entry to pp_return)
+
+/* This duplicates most of pp_leavesub, but with additional code to handle
+ * return args in lvalue context. It was forked from pp_leavesub to
+ * avoid slowing down that function any further.
+ *
+ * Any changes made to this function may need to be copied to pp_leavesub
+ * and vice-versa.
  */
 
-STATIC OP*
-S_return_lvalues(pTHX_ SV **base)
+PP(pp_leavesublv)
 {
     dSP;
     SV **newsp;
@@ -2298,18 +2283,25 @@ S_return_lvalues(pTHX_ SV **base)
     bool ref;
     const char *what = NULL;
 
+    if (CxMULTICALL(&cxstack[cxstack_ix])) {
+        /* entry zero of a stack is always PL_sv_undef, which
+         * simplifies converting a '()' return into undef in scalar context */
+        assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
+       return 0;
+    }
+
     POPBLOCK(cx,newpm);
     cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
     TAINT_NOT;
 
-    mark = base ? base : newsp;
+    mark = newsp + 1;
 
     ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
     if (gimme == G_SCALAR) {
        if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
            SV *sv;
-           if (MARK < SP) {
-               assert(MARK+1 == SP);
+           if (MARK <= SP) {
+               assert(MARK == SP);
                if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
                    !SvSMAGICAL(TOPs)) {
                    what =
@@ -2332,24 +2324,24 @@ S_return_lvalues(pTHX_ SV **base)
                      "Can't return %s from lvalue subroutine", what
            );
        }
-       if (MARK < SP) {
+       if (MARK <= SP) {
              copy_sv:
                if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
                    if (!SvPADTMP(*SP)) {
-                       *++newsp = SvREFCNT_inc(*SP);
+                       *MARK = SvREFCNT_inc(*SP);
                        FREETMPS;
-                       sv_2mortal(*newsp);
+                       sv_2mortal(*MARK);
                    }
                    else {
                        /* FREETMPS could clobber it */
                        SV *sv = SvREFCNT_inc(*SP);
                        FREETMPS;
-                       *++newsp = sv_mortalcopy(sv);
+                       *MARK = sv_mortalcopy(sv);
                        SvREFCNT_dec(sv);
                    }
                }
                else
-                   *++newsp =
+                   *MARK =
                      SvPADTMP(*SP)
                       ? sv_mortalcopy(*SP)
                       : !SvTEMP(*SP)
@@ -2357,9 +2349,11 @@ S_return_lvalues(pTHX_ SV **base)
                          : *SP;
        }
        else {
-           EXTEND(newsp,1);
-           *++newsp = &PL_sv_undef;
+           MEXTEND(MARK, 0);
+           *MARK = &PL_sv_undef;
        }
+        SP = MARK;
+
        if (CxLVAL(cx) & OPpDEREF) {
            SvGETMAGIC(TOPs);
            if (!SvOK(TOPs)) {
@@ -2370,14 +2364,14 @@ S_return_lvalues(pTHX_ SV **base)
     else if (gimme == G_ARRAY) {
        assert (!(CxLVAL(cx) & OPpDEREF));
        if (ref || !CxLVAL(cx))
-           while (++MARK <= SP)
-               *++newsp =
+           for (; MARK <= SP; MARK++)
+               *MARK =
                       SvFLAGS(*MARK) & SVs_PADTMP
                           ? sv_mortalcopy(*MARK)
                     : SvTEMP(*MARK)
                           ? *MARK
                           : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
-       else while (++MARK <= SP) {
+       else for (; MARK <= SP; MARK++) {
            if (*MARK != &PL_sv_undef
                    && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
            ) {
@@ -2386,14 +2380,11 @@ S_return_lvalues(pTHX_ SV **base)
                             ? "a readonly value" : "a temporary";
                     goto croak;
            }
-           else
-               *++newsp =
-                   SvTEMP(*MARK)
-                      ? *MARK
-                      : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
+           else if (!SvTEMP(*MARK))
+               *MARK = sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
        }
     }
-    PL_stack_sp = newsp;
+    PUTBACK;
 
     LEAVE;
     POPSUB(cx,sv);     /* Stack values are safe: release CV and @_ ... */
@@ -2409,127 +2400,74 @@ PP(pp_return)
 {
     dSP; dMARK;
     PERL_CONTEXT *cx;
-    bool clear_errsv = FALSE;
-    I32 gimme;
-    SV **newsp;
-    PMOP *newpm;
-    I32 optype = 0;
-    SV *namesv;
-    OP *retop = NULL;
-
+    SV **oldsp;
     const I32 cxix = dopoptosub(cxstack_ix);
 
-    if (cxix < 0) {
-       if (CxMULTICALL(cxstack)) { /* In this case we must be in a
-                                    * sort block, which is a CXt_NULL
-                                    * not a CXt_SUB */
-           dounwind(0);
-            /* if we were in list context, we would have to splice out
-             * any junk before the return args, like we do in the general
-             * pp_return case, e.g.
-             *   sub f { for (junk1, junk2) { return arg1, arg2 }}
-             */
-            assert(cxstack[0].blk_gimme == G_SCALAR);
-           return 0;
-       }
-       else
-           DIE(aTHX_ "Can't return outside a subroutine");
-    }
-    if (cxix < cxstack_ix)
+    assert(cxstack_ix >= 0);
+    if (cxix < cxstack_ix) {
+        if (cxix < 0) {
+            if (CxMULTICALL(cxstack)) { /* In this case we must be in a
+                                         * sort block, which is a CXt_NULL
+                                         * not a CXt_SUB */
+                dounwind(0);
+                /* if we were in list context, we would have to splice out
+                 * any junk before the return args, like we do in the general
+                 * pp_return case, e.g.
+                 *   sub f { for (junk1, junk2) { return arg1, arg2 }}
+                 */
+                assert(cxstack[0].blk_gimme == G_SCALAR);
+                return 0;
+            }
+            else
+                DIE(aTHX_ "Can't return outside a subroutine");
+        }
        dounwind(cxix);
+    }
 
     cx = &cxstack[cxix];
-    if (CxMULTICALL(cx)) {
-       gimme = cx->blk_gimme;
-       if (gimme == G_VOID)
-           PL_stack_sp = PL_stack_base;
-       else if (gimme == G_SCALAR) {
-           PL_stack_base[1] = *PL_stack_sp;
-           PL_stack_sp = PL_stack_base + 1;
-       }
-       return 0;
-    }
 
-    if (CxTYPE(cx) == CXt_SUB) {
-        if (CvLVALUE(cx->blk_sub.cv))
-            return S_return_lvalues(aTHX_ MARK);
-        else {
-            SV **oldsp = PL_stack_base + cx->blk_oldsp;
-            if (oldsp != MARK) {
+    oldsp = PL_stack_base + cx->blk_oldsp;
+    if (oldsp != MARK) {
+        /* Handle extra junk on the stack. For example,
+         *    for (1,2) { return 3,4 }
+         * leaves 1,2,3,4 on the stack. In list context we
+         * have to splice out the 1,2; In scalar context for
+         *    for (1,2) { return }
+         * we need to set sp = oldsp so that pp_leavesub knows
+         * to push &PL_sv_undef onto the stack.
+         * Note that in pp_return we only do the extra processing
+         * required to handle junk; everything else we leave to
+         * pp_leavesub.
+         */
+        SSize_t nargs = SP - MARK;
+        if (nargs) {
+            if (cx->blk_gimme == G_ARRAY) {
                 /* shift return args to base of call stack frame */
-                SSize_t nargs = SP - MARK;
-                if (nargs) {
-                    if (cx->blk_gimme == G_ARRAY)
-                        Move(MARK + 1, oldsp + 1, nargs, SV**);
-                    else if (cx->blk_gimme == G_SCALAR)
-                        oldsp[1] = *SP;
-                }
+                Move(MARK + 1, oldsp + 1, nargs, SV*);
                 PL_stack_sp  = oldsp + nargs;
             }
-            /* fall through to a normal sub exit */
-            return Perl_pp_leavesub(aTHX);
         }
+        else
+            PL_stack_sp  = oldsp;
     }
 
-    POPBLOCK(cx,newpm);
+    /* fall through to a normal exit */
     switch (CxTYPE(cx)) {
     case CXt_EVAL:
-       if (!(PL_in_eval & EVAL_KEEPERR))
-           clear_errsv = TRUE;
-       POPEVAL(cx);
-       namesv = cx->blk_eval.old_namesv;
-       retop = cx->blk_eval.retop;
-       if (CxTRYBLOCK(cx))
-           break;
-       if (optype == OP_REQUIRE &&
-           (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
-       {
-           /* Unassume the success we assumed earlier. */
-           (void)hv_delete(GvHVn(PL_incgv),
-                           SvPVX_const(namesv),
-                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
-                           G_DISCARD);
-           DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
-       }
-       break;
+        return CxTRYBLOCK(cx)
+            ? Perl_pp_leavetry(aTHX)
+            : Perl_pp_leaveeval(aTHX);
+    case CXt_SUB:
+        return CvLVALUE(cx->blk_sub.cv)
+            ? Perl_pp_leavesublv(aTHX)
+            : Perl_pp_leavesub(aTHX);
     case CXt_FORMAT:
-       retop = cx->blk_sub.retop;
-       POPFORMAT(cx);
-       break;
+        return Perl_pp_leavewrite(aTHX);
     default:
        DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
     }
-
-    TAINT_NOT;
-    if (gimme == G_SCALAR)
-        *++newsp = (MARK < SP) ? sv_mortalcopy(*SP) : &PL_sv_undef;
-    else if (gimme == G_ARRAY) {
-        while (++MARK <= SP) {
-            *++newsp = sv_mortalcopy(*MARK);
-            TAINT_NOT;         /* Each item is independent */
-        }
-    }
-    PL_stack_sp = newsp;
-
-    LEAVE;
-    PL_curpm = newpm;  /* ... and pop $1 et al */
-
-    if (clear_errsv) {
-       CLEAR_ERRSV();
-    }
-    return retop;
 }
 
-/* This duplicates parts of pp_leavesub, so that it can share code with
- * pp_return */
-PP(pp_leavesublv)
-{
-    if (CxMULTICALL(&cxstack[cxstack_ix]))
-       return 0;
-    return S_return_lvalues(aTHX_ NULL);
-
-
-}
 
 static I32
 S_unwind_loop(pTHX_ const char * const opname)
@@ -3157,7 +3095,7 @@ Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
 
 3 is used for a die caught by an inner eval - continue inner loop
 
-See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
+See F<cop.h>: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
 establish a local jmpenv to handle exception traps.
 
 =cut
@@ -3208,8 +3146,8 @@ S_docatch(pTHX_ OP *o)
 =for apidoc find_runcv
 
 Locate the CV corresponding to the currently executing sub or eval.
-If db_seqp is non_null, skip CVs that are in the DB package and populate
-*db_seqp with the cop sequence number at the point that the DB:: code was
+If C<db_seqp> is non_null, skip CVs that are in the DB package and populate
+C<*db_seqp> with the cop sequence number at the point that the DB:: code was
 entered.  (This allows debuggers to eval in the scope of the breakpoint
 rather than in the scope of the debugger itself.)
 
@@ -3544,11 +3482,14 @@ S_check_type_and_open(pTHX_ SV *name)
     /* checking here captures a reasonable error message when
      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
      * user gets a confusing message about looking for the .pmc file
-     * rather than for the .pm file.
+     * rather than for the .pm file so do the check in S_doopen_pm when
+     * PMC is on instead of here. S_doopen_pm calls this func.
      * This check prevents a \0 in @INC causing problems.
      */
+#ifdef PERL_DISABLE_PMC
     if (!IS_SAFE_PATHNAME(p, len, "require"))
         return NULL;
+#endif
 
     /* on Win32 stat is expensive (it does an open() and close() twice and
        a couple other IO calls), the open will fail with a dir on its own with
@@ -3567,11 +3508,7 @@ S_check_type_and_open(pTHX_ SV *name)
     }
 #endif
 
-#if !defined(PERLIO_IS_STDIO)
     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
-#else
-    retio = PerlIO_open(p, PERL_SCRIPT_MODE);
-#endif
 #ifdef WIN32
     /* EACCES stops the INC search early in pp_require to implement
        feature RT #113422 */
@@ -3608,13 +3545,14 @@ S_doopen_pm(pTHX_ SV *name)
 
     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
        SV *const pmcsv = sv_newmortal();
-       Stat_t pmcstat;
+       PerlIO * pmcio;
 
        SvSetSV_nosteal(pmcsv,name);
        sv_catpvs(pmcsv, "c");
 
-       if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
-           return check_type_and_open(pmcsv);
+       pmcio = check_type_and_open(pmcsv);
+       if (pmcio)
+           return pmcio;
     }
     return check_type_and_open(name);
 }
@@ -4231,7 +4169,7 @@ PP(pp_entereval)
 
     /* prepare to compile string */
 
-    if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
+    if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
        save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
     else {
        /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
@@ -4248,7 +4186,7 @@ PP(pp_entereval)
 
     if (doeval(gimme, runcv, seq, saved_hh)) {
        if (was != PL_breakable_sub_gen /* Some subs defined here. */
-           ? (PERLDB_LINE || PERLDB_SAVESRC)
+           ?  PERLDB_LINE_OR_SAVESRC
            :  PERLDB_SAVESRC_NOSUBS) {
            /* Retain the filegv we created.  */
        } else if (!saved_delete) {
@@ -4260,7 +4198,7 @@ PP(pp_entereval)
        /* We have already left the scope set up earlier thanks to the LEAVE
           in doeval().  */
        if (was != PL_breakable_sub_gen /* Some subs defined here. */
-           ? (PERLDB_LINE || PERLDB_SAVESRC)
+           ?  PERLDB_LINE_OR_SAVESRC
            :  PERLDB_SAVESRC_INVALID) {
            /* Retain the filegv we created.  */
        } else if (!saved_delete) {
@@ -4278,10 +4216,11 @@ PP(pp_leaveeval)
     I32 gimme;
     PERL_CONTEXT *cx;
     OP *retop;
-    const U8 save_flags = PL_op -> op_flags;
     I32 optype;
     SV *namesv;
     CV *evalcv;
+    /* grab this value before POPEVAL restores old PL_in_eval */
+    bool keep = cBOOL(PL_in_eval & EVAL_KEEPERR);
 
     PERL_ASYNC_CHECK();
     POPBLOCK(cx,newpm);
@@ -4313,9 +4252,8 @@ PP(pp_leaveeval)
     }
     else {
        LEAVE_with_name("eval");
-       if (!(save_flags & OPf_SPECIAL)) {
+        if (!keep)
            CLEAR_ERRSV();
-       }
     }
 
     RETURNOP(retop);
@@ -4381,9 +4319,11 @@ PP(pp_leavetry)
     I32 gimme;
     PERL_CONTEXT *cx;
     I32 optype;
+    OP *retop;
 
     PERL_ASYNC_CHECK();
     POPBLOCK(cx,newpm);
+    retop = cx->blk_eval.retop;
     POPEVAL(cx);
     PERL_UNUSED_VAR(optype);
 
@@ -4393,7 +4333,7 @@ PP(pp_leavetry)
 
     LEAVE_with_name("eval_scope");
     CLEAR_ERRSV();
-    RETURN;
+    RETURNOP(retop);
 }
 
 PP(pp_entergiven)
@@ -4405,15 +4345,9 @@ PP(pp_entergiven)
     ENTER_with_name("given");
     SAVETMPS;
 
-    if (PL_op->op_targ) {
-       SAVEPADSVANDMORTALIZE(PL_op->op_targ);
-       SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
-       PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
-    }
-    else {
-       SAVE_DEFSV;
-       DEFSV_set(POPs);
-    }
+    assert(!PL_op->op_targ); /* used to be set for lexical $_ */
+    SAVE_DEFSV;
+    DEFSV_set(POPs);
 
     PUSHBLOCK(cx, CXt_GIVEN, SP);
     PUSHGIVEN(cx);