fix buggy popping of subroutine contexts in the lvalue

subroutines implementation (change#4081); correct the
plethora of cases where DIE() was more appropriate than
croak()

p4raw-link: @4081 on //depot/perl: cd06dffe59d60ee6a2fdd7c81f8cef42c7026b36

p4raw-id: //depot/perl@4235

diff --git a/pp.c b/pp.c
index 773626f..2948d3a 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -407,7 +407,7 @@ PP(pp_rv2cv)
        if (CvCLONE(cv))
            cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
        if ((PL_op->op_private & OPpLVAL_INTRO) && !CvLVALUE(cv))
-           Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call");
+           DIE(aTHX_ "Can't modify non-lvalue subroutine call");
     }
     else
        cv = (CV*)&PL_sv_undef;
@@ -469,7 +469,7 @@ PP(pp_prototype)
                goto set;
            else {                      /* None such */
              nonesuch:
-               Perl_croak(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
+               DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
            }
        }
     }
@@ -871,7 +871,7 @@ PP(pp_predec)
 {
     djSP;
     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
-       Perl_croak(aTHX_ PL_no_modify);
+       DIE(aTHX_ PL_no_modify);
     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
        SvIVX(TOPs) != IV_MIN)
     {
@@ -888,7 +888,7 @@ PP(pp_postinc)
 {
     djSP; dTARGET;
     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
-       Perl_croak(aTHX_ PL_no_modify);
+       DIE(aTHX_ PL_no_modify);
     sv_setsv(TARG, TOPs);
     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
        SvIVX(TOPs) != IV_MAX)
@@ -909,7 +909,7 @@ PP(pp_postdec)
 {
     djSP; dTARGET;
     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
-       Perl_croak(aTHX_ PL_no_modify);
+       DIE(aTHX_ PL_no_modify);
     sv_setsv(TARG, TOPs);
     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
        SvIVX(TOPs) != IV_MIN)
@@ -3303,7 +3303,7 @@ PP(pp_unpack)
                pat++;
            }
            else
-               Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
+               DIE(aTHX_ "'!' allowed only after types %s", natstr);
        }
        if (pat >= patend)
            len = 1;
@@ -3316,17 +3316,18 @@ PP(pp_unpack)
            while (isDIGIT(*pat)) {
                len = (len * 10) + (*pat++ - '0');
                if (len < 0)
-                   Perl_croak(aTHX_ "Repeat count in unpack overflows");
+                   DIE(aTHX_ "Repeat count in unpack overflows");
            }
        }
        else
            len = (datumtype != '@');
        switch(datumtype) {
        default:
-           Perl_croak(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
+           DIE(aTHX_ "Invalid type in unpack: '%c'", (int)datumtype);
        case ',': /* grandfather in commas but with a warning */
            if (commas++ == 0 && ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
+               Perl_warner(aTHX_ WARN_UNSAFE,
+                           "Invalid type in unpack: '%c'", (int)datumtype);
            break;
        case '%':
            if (len == 1 && pat[-1] != '1')
@@ -3992,7 +3993,7 @@ PP(pp_unpack)
                    }
                }
                if ((s >= strend) && bytes)
-                   Perl_croak(aTHX_ "Unterminated compressed integer");
+                   DIE(aTHX_ "Unterminated compressed integer");
            }
            break;
        case 'P':
@@ -4365,7 +4366,7 @@ PP(pp_pack)
                pat++;
            }
            else
-               Perl_croak(aTHX_ "'!' allowed only after types %s", natstr);
+               DIE(aTHX_ "'!' allowed only after types %s", natstr);
        }
        if (*pat == '*') {
            len = strchr("@Xxu", datumtype) ? 0 : items;
@@ -4376,7 +4377,7 @@ PP(pp_pack)
            while (isDIGIT(*pat)) {
                len = (len * 10) + (*pat++ - '0');
                if (len < 0)
-                   Perl_croak(aTHX_ "Repeat count in pack overflows");
+                   DIE(aTHX_ "Repeat count in pack overflows");
            }
        }
        else
@@ -4390,7 +4391,7 @@ PP(pp_pack)
        }
        switch(datumtype) {
        default:
-           Perl_croak(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
+           DIE(aTHX_ "Invalid type in pack: '%c'", (int)datumtype);
        case ',': /* grandfather in commas but with a warning */
            if (commas++ == 0 && ckWARN(WARN_UNSAFE))
                Perl_warner(aTHX_ WARN_UNSAFE,
@@ -4679,7 +4680,7 @@ PP(pp_pack)
                adouble = Perl_floor(SvNV(fromstr));
 
                if (adouble < 0)
-                   Perl_croak(aTHX_ "Cannot compress negative numbers");
+                   DIE(aTHX_ "Cannot compress negative numbers");
 
                if (
 #ifdef BW_BITS
@@ -4713,7 +4714,7 @@ PP(pp_pack)
                    /* Copy string and check for compliance */
                    from = SvPV(fromstr, len);
                    if ((norm = is_an_int(from, len)) == NULL)
-                       Perl_croak(aTHX_ "can compress only unsigned integer");
+                       DIE(aTHX_ "can compress only unsigned integer");
 
                    New('w', result, len, char);
                    in = result + len;
@@ -4733,14 +4734,14 @@ PP(pp_pack)
                        double next = floor(adouble / 128);
                        *--in = (unsigned char)(adouble - (next * 128)) | 0x80;
                        if (--in < buf)  /* this cannot happen ;-) */
-                           Perl_croak(aTHX_ "Cannot compress integer");
+                           DIE(aTHX_ "Cannot compress integer");
                        adouble = next;
                    } while (adouble > 0);
                    buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */
                    sv_catpvn(cat, in, (buf + sizeof(buf)) - in);
                }
                else
-                   Perl_croak(aTHX_ "Cannot compress non integer");
+                   DIE(aTHX_ "Cannot compress non integer");
            }
             break;
        case 'i':

diff --git a/pp_ctl.c b/pp_ctl.c
index 07c3e74..e849e33 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -971,7 +971,7 @@ PP(pp_flop)
          (looks_like_number(left) && *SvPVX(left) != '0') )
        {
            if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
-               Perl_croak(aTHX_ "Range iterator outside integer range");
+               DIE(aTHX_ "Range iterator outside integer range");
            i = SvIV(left);
            max = SvIV(right);
            if (max >= i) {
@@ -1616,7 +1616,7 @@ PP(pp_enteriter)
                (looks_like_number(sv) && *SvPVX(sv) != '0')) {
                 if (SvNV(sv) < IV_MIN ||
                     SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
-                    Perl_croak(aTHX_ "Range iterator outside integer range");
+                    DIE(aTHX_ "Range iterator outside integer range");
                 cx->blk_loop.iterix = SvIV(sv);
                 cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
            }

diff --git a/pp_hot.c b/pp_hot.c
index df5e062..904ee9f 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -234,7 +234,7 @@ PP(pp_preinc)
 {
     djSP;
     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
-       Perl_croak(aTHX_ PL_no_modify);
+       DIE(aTHX_ PL_no_modify);
     if (SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
        SvIVX(TOPs) != IV_MAX)
     {
@@ -1645,7 +1645,7 @@ PP(pp_subst)
     if (SvREADONLY(TARG)
        || (SvTYPE(TARG) > SVt_PVLV
            && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
-       Perl_croak(aTHX_ PL_no_modify);
+       DIE(aTHX_ PL_no_modify);
     PUTBACK;
 
     s = SvPV(TARG, len);
@@ -2014,36 +2014,49 @@ PP(pp_leavesublv)
        /* Here we go for robustness, not for speed, so we change all
         * the refcounts so the caller gets a live guy. Cannot set
         * TEMP, so sv_2mortal is out of question. */
-       if (!CvLVALUE(cxsub.cv))
-           Perl_croak(aTHX_ "Can't modify non-lvalue subroutine call");
+       if (!CvLVALUE(cxsub.cv)) {
+           POPSUB2();
+           PL_curpm = newpm;
+           DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+       }
        if (gimme == G_SCALAR) {
            MARK = newsp + 1;
            EXTEND_MORTAL(1);
            if (MARK == SP) {
-               if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY))
-                   Perl_croak(aTHX_ "Can't return a %s from lvalue subroutine",
+               if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+                   POPSUB2();
+                   PL_curpm = newpm;
+                   DIE(aTHX_ "Can't return a %s from lvalue subroutine",
                        SvREADONLY(TOPs) ? "readonly value" : "temporary");
+               }
                else {                  /* Can be a localized value
                                         * subject to deletion. */
                    PL_tmps_stack[++PL_tmps_ix] = *mark;
                    SvREFCNT_inc(*mark);
                }
            }
-           else                        /* Should not happen? */
-               Perl_croak(aTHX_ "%s returned from lvalue subroutine in scalar context",
+           else {                      /* Should not happen? */
+               POPSUB2();
+               PL_curpm = newpm;
+               DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
                    (MARK > SP ? "Empty array" : "Array"));
+           }
            SP = MARK;
        }
        else if (gimme == G_ARRAY) {
            EXTEND_MORTAL(SP - newsp);
            for (mark = newsp + 1; mark <= SP; mark++) {
-               if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY))
-               /* Might be flattened array after $#array =  */
-               Perl_croak(aTHX_ "Can't return %s from lvalue subroutine",
+               if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+                   /* Might be flattened array after $#array =  */
+                   PUTBACK;
+                   POPSUB2();
+                   PL_curpm = newpm;
+                   DIE(aTHX_ "Can't return %s from lvalue subroutine",
                        (*mark != &PL_sv_undef)
                        ? (SvREADONLY(TOPs)
                            ? "a readonly value" : "a temporary")
                        : "an uninitialized value");
+               }
                else {
                    mortalize:
                    /* Can be a localized value subject to deletion. */
@@ -2258,7 +2271,7 @@ try_autoload:
                    || !(sv = AvARRAY(av)[0]))
                {
                    MUTEX_UNLOCK(CvMUTEXP(cv));
-                   Perl_croak(aTHX_ "no argument for locked method call");
+                   DIE(aTHX_ "no argument for locked method call");
                }
            }
            if (SvROK(sv))

diff --git a/pp_sys.c b/pp_sys.c
index 2a0ec38..cf08f73 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -3657,7 +3657,7 @@ PP(pp_system)
            PerlLIO_close(pp[0]);
            if (n) {                    /* Error */
                if (n != sizeof(int))
-                   Perl_croak(aTHX_ "panic: kid popen errno read");
+                   DIE(aTHX_ "panic: kid popen errno read");
                errno = errkid;         /* Propagate errno from kid */
                STATUS_CURRENT = -1;
            }