This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update Test::Harness 3.36 -> 3.38
[perl5.git] / pp.c
diff --git a/pp.c b/pp.c
index 56dcf5d..a6b3041 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -150,9 +150,7 @@ PP(pp_padhv)
             && block_gimme() == G_VOID  ))
          && (!SvRMAGICAL(TARG) || !mg_find(TARG, PERL_MAGIC_tied))
     )
-        /* use newSViv(0) rather than PL_sv_no - see OP_AND comment in
-         * S_check_for_bool_cxt() */
-       SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
+       SETs(HvUSEDKEYS(TARG) ? &PL_sv_yes : &PL_sv_no);
     else if (gimme == G_SCALAR) {
        SV* const sv = Perl_hv_scalar(aTHX_ MUTABLE_HV(TARG));
        SETs(sv);
@@ -3398,8 +3396,10 @@ PP(pp_substr)
        tmps = SvPV_force_nomg(sv, curlen);
        if (DO_UTF8(repl_sv) && repl_len) {
            if (!DO_UTF8(sv)) {
+                /* Upgrade the dest, and recalculate tmps in case the buffer
+                 * got reallocated; curlen may also have been changed */
                sv_utf8_upgrade_nomg(sv);
-               curlen = SvCUR(sv);
+               tmps = SvPV_nomg(sv, curlen);
            }
        }
        else if (DO_UTF8(sv))
@@ -3473,10 +3473,45 @@ PP(pp_vec)
 {
     dSP;
     const IV size   = POPi;
-    const IV offset = POPi;
+    SV* offsetsv   = POPs;
     SV * const src = POPs;
     const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
     SV * ret;
+    UV   retuv = 0;
+    STRLEN offset;
+
+    /* extract a STRLEN-ranged integer value from offsetsv into offset,
+     * or die trying */
+    {
+        IV iv = SvIV(offsetsv);
+
+        /* avoid a large UV being wrapped to a negative value */
+        if (SvIOK_UV(offsetsv) && SvUVX(offsetsv) > (UV)IV_MAX) {
+            if (!lvalue)
+                goto return_val; /* out of range: return 0 */
+            Perl_croak_nocontext("Out of memory!");
+        }
+
+        if (iv < 0) {
+            if (!lvalue)
+                goto return_val; /* out of range: return 0 */
+            Perl_croak_nocontext("Negative offset to vec in lvalue context");
+        }
+
+#if PTRSIZE < IVSIZE
+        if (iv > Size_t_MAX) {
+            if (!lvalue)
+                goto return_val; /* out of range: return 0 */
+            Perl_croak_nocontext("Out of memory!");
+        }
+#endif
+
+        offset = (STRLEN)iv;
+    }
+
+    retuv = do_vecget(src, offset, size);
+
+  return_val:
 
     if (lvalue) {                      /* it's an lvalue! */
        ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
@@ -3492,7 +3527,8 @@ PP(pp_vec)
        ret = TARG;
     }
 
-    sv_setuv(ret, do_vecget(src, offset, size));
+
+    sv_setuv(ret, retuv);
     if (!lvalue)
        SvSETMAGIC(ret);
     PUSHs(ret);
@@ -3628,7 +3664,7 @@ PP(pp_ord)
     const U8 *s = (U8*)SvPV_const(argsv, len);
 
     SETu(DO_UTF8(argsv)
-           ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
+           ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0)
            : (UV)(*s));
 
     return NORMAL;
@@ -5654,8 +5690,6 @@ PP(pp_reverse)
     }
     else {
        char *up;
-       char *down;
-       I32 tmp;
        dTARGET;
        STRLEN len;
 
@@ -5668,6 +5702,7 @@ PP(pp_reverse)
 
        up = SvPV_force(TARG, len);
        if (len > 1) {
+            char *down;
            if (DO_UTF8(TARG)) {        /* first reverse each character */
                U8* s = (U8*)SvPVX(TARG);
                const U8* send = (U8*)(s + len);
@@ -5684,9 +5719,9 @@ PP(pp_reverse)
                        down = (char*)(s - 1);
                        /* reverse this character */
                        while (down > up) {
-                           tmp = *up;
+                            const char tmp = *up;
                            *up++ = *down;
-                           *down-- = (char)tmp;
+                            *down-- = tmp;
                        }
                    }
                }
@@ -5694,9 +5729,9 @@ PP(pp_reverse)
            }
            down = SvPVX(TARG) + len - 1;
            while (down > up) {
-               tmp = *up;
+                const char tmp = *up;
                *up++ = *down;
-               *down-- = (char)tmp;
+                *down-- = tmp;
            }
            (void)SvPOK_only_UTF8(TARG);
        }
@@ -6144,7 +6179,7 @@ PP(pp_split)
     }
 
     GETTARGET;
-    PUSHi(iters);
+    XPUSHi(iters);
     RETURN;
 }
 
@@ -6803,6 +6838,26 @@ PP(pp_argdefelem)
 }
 
 
+static SV *
+S_find_runcv_name(void)
+{
+    dTHX;
+    CV *cv;
+    GV *gv;
+    SV *sv;
+
+    cv = find_runcv(0);
+    if (!cv)
+        return &PL_sv_no;
+
+    gv = CvGV(cv);
+    if (!gv)
+        return &PL_sv_no;
+
+    sv = sv_2mortal(newSV(0));
+    gv_fullname4(sv, gv, NULL, TRUE);
+    return sv;
+}
 
 /* Check a  a subs arguments - i.e. that it has the correct number of args
  * (and anything else we might think of in future). Typically used with
@@ -6825,14 +6880,15 @@ PP(pp_argcheck)
     too_few = (argc < (params - opt_params));
 
     if (UNLIKELY(too_few || (!slurpy && argc > params)))
-        /* diag_listed_as: Too few arguments for subroutine */
-        /* diag_listed_as: Too many arguments for subroutine */
-        Perl_croak_caller("Too %s arguments for subroutine",
-                            too_few ? "few" : "many");
+        /* diag_listed_as: Too few arguments for subroutine '%s' */
+        /* diag_listed_as: Too many arguments for subroutine '%s' */
+        Perl_croak_caller("Too %s arguments for subroutine '%" SVf "'",
+                          too_few ? "few" : "many", S_find_runcv_name());
 
     if (UNLIKELY(slurpy == '%' && argc > params && (argc - params) % 2))
-        Perl_croak_caller("Odd name/value argument for subroutine");
-
+        /* diag_listed_as: Odd name/value argument for subroutine '%s' */
+        Perl_croak_caller("Odd name/value argument for subroutine '%" SVf "'",
+                          S_find_runcv_name());
 
     return NORMAL;
 }