t/TEST: $failure doesnt need to use defined

[perl5.git] / pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index db125b8..e32a17e 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -825,11 +825,25 @@ PP(pp_formline)
                 int len;
                 DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
                 arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
+#ifdef USE_QUADMATH
+                {
+                    const char* qfmt = quadmath_format_single(fmt);
+                    int len;
+                    if (!qfmt)
+                        Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", fmt);
+                    len = quadmath_snprintf(t, max, qfmt, (int) fieldsize, (int) arg, value);
+                    if (len == -1)
+                        Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
+                    if (qfmt != fmt)
+                        Safefree(fmt);
+                }
+#else
                 /* we generate fmt ourselves so it is safe */
                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
                 len = my_snprintf(t, max, fmt, (int) fieldsize, (int) arg, value);
-                PERL_MY_SNPRINTF_POST_GUARD(len, max);
                 GCC_DIAG_RESTORE;
+#endif
+                PERL_MY_SNPRINTF_POST_GUARD(len, max);
                 RESTORE_LC_NUMERIC();
            }
            t += fieldsize;
@@ -1806,7 +1820,7 @@ PP(pp_caller)
     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
        /* So is ccstack[dbcxix]. */
        if (CvHASGV(dbcx->blk_sub.cv)) {
-           PUSHs(cv_name(dbcx->blk_sub.cv, 0));
+           PUSHs(cv_name(dbcx->blk_sub.cv, 0, 0));
            PUSHs(boolSV(CxHASARGS(cx)));
        }
        else {
@@ -1925,7 +1939,7 @@ PP(pp_dbstate)
     PERL_ASYNC_CHECK();
 
     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
-           || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
+           || PL_DBsingle_iv || PL_DBsignal_iv || PL_DBtrace_iv)
     {
        dSP;
        PERL_CONTEXT *cx;
@@ -2098,12 +2112,21 @@ PP(pp_enteriter)
        itervar = &PAD_SVl(PL_op->op_targ);
 #endif
     }
-    else {                                     /* symbol table variable */
+    else if (LIKELY(isGV(TOPs))) {             /* symbol table variable */
        GV * const gv = MUTABLE_GV(POPs);
        SV** svp = &GvSV(gv);
        save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
        *svp = newSV(0);
        itervar = (void *)gv;
+       save_aliased_sv(gv);
+    }
+    else {
+       SV * const sv = POPs;
+       assert(SvTYPE(sv) == SVt_PVMG);
+       assert(SvMAGIC(sv));
+       assert(SvMAGIC(sv)->mg_type == PERL_MAGIC_lvref);
+       itervar = (void *)sv;
+       cxtype |= CXp_FOR_LVREF;
     }
 
     if (PL_op->op_private & OPpITER_DEF)
@@ -2118,6 +2141,8 @@ PP(pp_enteriter)
        if (SvTYPE(maybe_ary) != SVt_PVAV) {
            dPOPss;
            SV * const right = maybe_ary;
+           if (UNLIKELY(cxtype & CXp_FOR_LVREF))
+               DIE(aTHX_ "Assigned value is not a reference");
            SvGETMAGIC(sv);
            SvGETMAGIC(right);
            if (RANGE_IS_NUMERIC(sv,right)) {
@@ -2252,10 +2277,7 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
            const char *what = NULL;
            if (MARK < SP) {
                assert(MARK+1 == SP);
-               if ((SvPADTMP(TOPs) ||
-                    (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
-                      == SVf_READONLY
-                   ) &&
+               if ((SvPADTMP(TOPs) || SvREADONLY(TOPs)) &&
                    !SvSMAGICAL(TOPs)) {
                    what =
                        SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
@@ -2323,11 +2345,9 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
                           : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
        else while (++MARK <= SP) {
            if (*MARK != &PL_sv_undef
-                   && (SvPADTMP(*MARK)
-                      || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
-                            == SVf_READONLY
-                      )
+                   && (SvPADTMP(*MARK) || SvREADONLY(*MARK))
            ) {
+                   const bool ro = cBOOL( SvREADONLY(*MARK) );
                    SV *sv;
                    /* Might be flattened array after $#array =  */
                    PUTBACK;
@@ -2339,7 +2359,7 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
               /* diag_listed_as: Can't return %s from lvalue subroutine */
                    Perl_croak(aTHX_
                        "Can't return a %s from lvalue subroutine",
-                       SvREADONLY(TOPs) ? "readonly value" : "temporary");
+                        ro ? "readonly value" : "temporary");
            }
            else
                *++newsp =
@@ -2729,7 +2749,10 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac
     return 0;
 }
 
-PP(pp_goto) /* also pp_dump */
+
+/* also used for: pp_dump() */
+
+PP(pp_goto)
 {
     dVAR; dSP;
     OP *retop = NULL;
@@ -2845,7 +2868,6 @@ PP(pp_goto) /* also pp_dump */
            SAVETMPS;
            SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
            if (CvISXSUB(cv)) {
-               OP* const retop = cx->blk_sub.retop;
                SV **newsp;
                I32 gimme;
                const SSize_t items = arg ? AvFILL(arg) + 1 : 0;
@@ -2885,6 +2907,7 @@ PP(pp_goto) /* also pp_dump */
                    SvREFCNT_dec(arg);
                }
 
+               retop = cx->blk_sub.retop;
                /* XS subs don't have a CxSUB, so pop it */
                POPBLOCK(cx, PL_curpm);
                /* Push a mark for the start of arglist */
@@ -2892,8 +2915,7 @@ PP(pp_goto) /* also pp_dump */
                PUTBACK;
                (void)(*CvXSUB(cv))(aTHX_ cv);
                LEAVE;
-               PERL_ASYNC_CHECK();
-               return retop;
+               goto _return;
            }
            else {
                PADLIST * const padlist = CvPADLIST(cv);
@@ -2946,8 +2968,8 @@ PP(pp_goto) /* also pp_dump */
                        }
                    }
                }
-               PERL_ASYNC_CHECK();
-               RETURNOP(CvSTART(cv));
+               retop = CvSTART(cv);
+               goto putback_return;
            }
        }
        else {
@@ -3093,7 +3115,8 @@ PP(pp_goto) /* also pp_dump */
        }
     }
 
-    if (do_dump) {
+    else {
+        assert(do_dump);
 #ifdef VMS
        if (!retop) retop = PL_main_start;
 #endif
@@ -3106,8 +3129,11 @@ PP(pp_goto) /* also pp_dump */
        PL_do_undump = FALSE;
     }
 
+    putback_return:
+    PL_stack_sp = sp;
+    _return:
     PERL_ASYNC_CHECK();
-    RETURNOP(retop);
+    return retop;
 }
 
 PP(pp_exit)
@@ -3360,7 +3386,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
 
     /* set up a scratch pad */
 
-    CvPADLIST(evalcv) = pad_new(padnew_SAVE);
+    CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
 
 
@@ -3640,6 +3666,9 @@ S_path_is_searchable(const char *name)
        return TRUE;
 }
 
+
+/* also used for: pp_dofile() */
+
 PP(pp_require)
 {
     dSP;