X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/72d33970ea94fe3382327160378d9bc042cb1d73..f1c895b1d5d94eb3140ca62793fdca667bcc9386:/pp_ctl.c

diff --git a/pp_ctl.c b/pp_ctl.c
index c8c6773..71542db 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -153,7 +153,7 @@ PP(pp_regcomp)
 	       modified by get-magic), to avoid incorrectly setting the
 	       RXf_TAINTED flag with RX_TAINT_on further down. */
 	    TAINT_set(was_tainted);
-#if NO_TAINT_SUPPORT
+#ifdef NO_TAINT_SUPPORT
             PERL_UNUSED_VAR(was_tainted);
 #endif
 	}
@@ -696,6 +696,7 @@ PP(pp_formline)
 
 	case FF_LINESNGL: /* process ^*  */
 	    chopspace = 0;
+            /* FALLTHROUGH */
 
 	case FF_LINEGLOB: /* process @*  */
 	    {
@@ -836,13 +837,13 @@ PP(pp_formline)
 	    }
 	    /* Formats aren't yet marked for locales, so assume "yes". */
 	    {
-		STORE_NUMERIC_STANDARD_SET_LOCAL();
+                DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
 		arg &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
                 /* we generate fmt ourselves so it is safe */
                 GCC_DIAG_IGNORE(-Wformat-nonliteral);
 		my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg, value);
                 GCC_DIAG_RESTORE;
-		RESTORE_NUMERIC_STANDARD();
+                RESTORE_LC_NUMERIC();
 	    }
 	    t += fieldsize;
 	    break;
@@ -938,7 +939,8 @@ PP(pp_grepstart)
     SAVEVPTR(PL_curpm);
 
     src = PL_stack_base[*PL_markstack_ptr];
-    if (SvPADTMP(src) && !IS_PADGV(src)) {
+    if (SvPADTMP(src)) {
+        assert(!IS_PADGV(src));
 	src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
 	PL_tmps_floor++;
     }
@@ -1090,7 +1092,10 @@ PP(pp_mapwhile)
 
 	/* set $_ to the new source item */
 	src = PL_stack_base[PL_markstack_ptr[-1]];
-	if (SvPADTMP(src) && !IS_PADGV(src)) src = sv_mortalcopy(src);
+	if (SvPADTMP(src)) {
+            assert(!IS_PADGV(src));
+            src = sv_mortalcopy(src);
+        }
 	SvTEMP_off(src);
 	if (PL_op->op_private & OPpGREP_LEX)
 	    PAD_SVl(PL_op->op_targ) = src;
@@ -1180,25 +1185,33 @@ PP(pp_flop)
 	SvGETMAGIC(right);
 
 	if (RANGE_IS_NUMERIC(left,right)) {
-	    IV i, j;
-	    IV max;
+	    IV i, j, n;
 	    if ((SvOK(left) && !SvIOK(left) && SvNV_nomg(left) < IV_MIN) ||
 		(SvOK(right) && (SvIOK(right)
 				 ? SvIsUV(right) && SvUV(right) > IV_MAX
 				 : SvNV_nomg(right) > IV_MAX)))
 		DIE(aTHX_ "Range iterator outside integer range");
 	    i = SvIV_nomg(left);
-	    max = SvIV_nomg(right);
-	    if (max >= i) {
-		j = max - i + 1;
-		if (j > SSize_t_MAX)
-		    Perl_croak(aTHX_ "Out of memory during list extend");
-		EXTEND_MORTAL(j);
-		EXTEND(SP, j);
+	    j = SvIV_nomg(right);
+	    if (j >= i) {
+                /* Dance carefully around signed max. */
+                bool overflow = (i <= 0 && j > SSize_t_MAX + i - 1);
+                if (!overflow) {
+                    n = j - i + 1;
+                    /* The wraparound of signed integers is undefined
+                     * behavior, but here we aim for count >=1, and
+                     * negative count is just wrong. */
+                    if (n < 1)
+                        overflow = TRUE;
+                }
+                if (overflow)
+                    Perl_croak(aTHX_ "Out of memory during list extend");
+		EXTEND_MORTAL(n);
+		EXTEND(SP, n);
 	    }
 	    else
-		j = 0;
-	    while (j--) {
+		n = 0;
+	    while (n--) {
 		SV * const sv = sv_2mortal(newSViv(i++));
 		PUSHs(sv);
 	    }
@@ -1344,9 +1357,8 @@ Perl_block_gimme(pTHX)
 	return G_ARRAY;
     default:
 	Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
-	assert(0); /* NOTREACHED */
-	return 0;
     }
+    NOT_REACHED; /* NOTREACHED */
 }
 
 I32
@@ -1383,6 +1395,9 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
     I32 i;
 
     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
+#ifndef DEBUGGING
+    PERL_UNUSED_CONTEXT;
+#endif
 
     for (i = startingblock; i >= 0; i--) {
 	const PERL_CONTEXT * const cx = &cxstk[i];
@@ -1396,6 +1411,7 @@ S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
              * code block. Hide this faked entry from the world. */
             if (cx->cx_type & CXp_SUB_RE_FAKE)
                 continue;
+            /* FALLTHROUGH */
 	case CXt_EVAL:
 	case CXt_FORMAT:
 	    DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
@@ -1697,6 +1713,9 @@ PP(pp_xor)
 }
 
 /*
+
+=head1 CV Manipulation Functions
+
 =for apidoc caller_cx
 
 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>.  The
@@ -1843,9 +1862,16 @@ PP(pp_caller)
     if (CxTYPE(cx) == CXt_EVAL) {
 	/* eval STRING */
 	if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
-	    PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
-				 SvCUR(cx->blk_eval.cur_text)-2,
-				 SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
+            SV *cur_text = cx->blk_eval.cur_text;
+            if (SvCUR(cur_text) >= 2) {
+                PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
+                                     SvUTF8(cur_text)|SVs_TEMP));
+            }
+            else {
+                /* I think this is will always be "", but be sure */
+                PUSHs(sv_2mortal(newSVsv(cur_text)));
+            }
+
 	    PUSHs(&PL_sv_no);
 	}
 	/* require */
@@ -2932,8 +2958,10 @@ PP(pp_goto) /* also pp_dump */
 		       to freed memory as the result of undef *_.  So put
 		       it in the callee’s pad, donating our refer-
 		       ence count. */
-		    SvREFCNT_dec(PAD_SVl(0));
-		    PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
+		    if (arg) {
+			SvREFCNT_dec(PAD_SVl(0));
+			PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
+		    }
 
 		    /* GvAV(PL_defgv) might have been modified on scope
 		       exit, so restore it. */
@@ -3020,7 +3048,7 @@ PP(pp_goto) /* also pp_dump */
 		    gotoprobe = CvROOT(cx->blk_sub.cv);
 		    break;
 		}
-		/* FALL THROUGH */
+		/* FALLTHROUGH */
 	    case CXt_FORMAT:
 	    case CXt_NULL:
 		DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
@@ -3075,7 +3103,7 @@ PP(pp_goto) /* also pp_dump */
 	    I32 oldsave;
 
 	    if (ix < 0)
-		ix = 0;
+		DIE(aTHX_ "panic: docatch: illegal ix=%ld", (long)ix);
 	    dounwind(ix);
 	    TOPBLOCK(cx);
 	    oldsave = PL_scopestack[PL_scopestack_ix];
@@ -3138,13 +3166,7 @@ PP(pp_exit)
 #endif
     }
     PL_exit_flags |= PERL_EXIT_EXPECTED;
-#ifdef PERL_MAD
-    /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
-    if (anum || !(PL_minus_c && PL_madskills))
-	my_exit(anum);
-#else
     my_exit(anum);
-#endif
     PUSHs(&PL_sv_undef);
     RETURN;
 }
@@ -3220,7 +3242,7 @@ S_docatch(pTHX_ OP *o)
 	    PL_restartop = 0;
 	    goto redo_body;
 	}
-	/* FALL THROUGH */
+	/* FALLTHROUGH */
     default:
 	JMPENV_POP;
 	PL_op = oldop;
@@ -3379,8 +3401,7 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
 
 
-    if (!PL_madskills)
-	SAVEMORTALIZESV(evalcv);	/* must remain until end of current statement */
+    SAVEMORTALIZESV(evalcv);	/* must remain until end of current statement */
 
     /* make sure we compile in the right package */
 
@@ -3398,10 +3419,6 @@ S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
     PL_unitcheckav = newAV();
     SAVEFREESV(PL_unitcheckav);
 
-#ifdef PERL_MAD
-    SAVEBOOL(PL_madskills);
-    PL_madskills = 0;
-#endif
 
     ENTER_with_name("evalcomp");
     SAVESPTR(PL_compcv);
@@ -3623,7 +3640,7 @@ S_doopen_pm(pTHX_ SV *name)
 	Stat_t pmcstat;
 
 	SvSetSV_nosteal(pmcsv,name);
-	sv_catpvn(pmcsv, "c", 1);
+	sv_catpvs(pmcsv, "c");
 
 	if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
 	    return check_type_and_open(pmcsv);
@@ -3671,9 +3688,7 @@ PP(pp_require)
     STRLEN unixlen;
 #ifdef VMS
     int vms_unixname = 0;
-    char *unixnamebuf;
     char *unixdir;
-    char *unixdirbuf;
 #endif
     const char *tryname = NULL;
     SV *namesv = NULL;
@@ -3714,7 +3729,7 @@ PP(pp_require)
 		first  = SvIV(*av_fetch(lav,0,0));
 		if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
 		    || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
-		    || av_len(lav) > 1               /* FP with > 3 digits */
+		    || av_tindex(lav) > 1            /* FP with > 3 digits */
 		    || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
 		   ) {
 		    DIE(aTHX_ "Perl %"SVf" required--this is only "
@@ -3727,7 +3742,7 @@ PP(pp_require)
 		    SV *hintsv;
 		    I32 second = 0;
 
-		    if (av_len(lav)>=1) 
+		    if (av_tindex(lav)>=1)
 			second = SvIV(*av_fetch(lav,1,0));
 
 		    second /= second >= 600  ? 100 : 10;
@@ -3768,8 +3783,9 @@ PP(pp_require)
      * name can be translated to UNIX.
      */
     
-    if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
-        && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
+    if ((unixname =
+	  tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
+	 != NULL) {
 	unixlen = strlen(unixname);
 	vms_unixname = 1;
     }
@@ -3815,17 +3831,17 @@ PP(pp_require)
 	    for (i = 0; i <= AvFILL(ar); i++) {
 		SV * const dirsv = *av_fetch(ar, i, TRUE);
 
-		if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
-		    mg_get(dirsv);
+		SvGETMAGIC(dirsv);
 		if (SvROK(dirsv)) {
 		    int count;
 		    SV **svp;
 		    SV *loader = dirsv;
 
 		    if (SvTYPE(SvRV(loader)) == SVt_PVAV
-			&& !sv_isobject(loader))
+			&& !SvOBJECT(SvRV(loader)))
 		    {
 			loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
+			SvGETMAGIC(loader);
 		    }
 
 		    Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
@@ -3833,18 +3849,24 @@ PP(pp_require)
 		    tryname = SvPVX_const(namesv);
 		    tryrsfp = NULL;
 
-		    ENTER_with_name("call_INC");
-		    SAVETMPS;
 		    if (SvPADTMP(nsv)) {
 			nsv = sv_newmortal();
 			SvSetSV_nosteal(nsv,sv);
 		    }
+
+		    ENTER_with_name("call_INC");
+		    SAVETMPS;
 		    EXTEND(SP, 2);
 
 		    PUSHMARK(SP);
 		    PUSHs(dirsv);
 		    PUSHs(nsv);
 		    PUTBACK;
+		    if (SvGMAGICAL(loader)) {
+			SV *l = sv_newmortal();
+			sv_setsv_nomg(l, loader);
+			loader = l;
+		    }
 		    if (sv_isobject(loader))
 			count = call_method("INC", G_ARRAY);
 		    else
@@ -3931,11 +3953,11 @@ PP(pp_require)
 		    filter_has_file = 0;
 		    filter_cache = NULL;
 		    if (filter_state) {
-			SvREFCNT_dec(filter_state);
+			SvREFCNT_dec_NN(filter_state);
 			filter_state = NULL;
 		    }
 		    if (filter_sub) {
-			SvREFCNT_dec(filter_sub);
+			SvREFCNT_dec_NN(filter_sub);
 			filter_sub = NULL;
 		    }
 		}
@@ -3945,7 +3967,7 @@ PP(pp_require)
 		    STRLEN dirlen;
 
 		    if (SvOK(dirsv)) {
-			dir = SvPV_const(dirsv, dirlen);
+			dir = SvPV_nomg_const(dirsv, dirlen);
 		    } else {
 			dir = "";
 			dirlen = 0;
@@ -3954,8 +3976,9 @@ PP(pp_require)
 		    if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
 			continue;
 #ifdef VMS
-		    if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
-			|| ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
+		    if ((unixdir =
+			  tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
+			 == NULL)
 			continue;
 		    sv_setpv(namesv, unixdir);
 		    sv_catpv(namesv, unixname);
@@ -3987,6 +4010,9 @@ PP(pp_require)
 			/* Avoid '<dir>//<file>' */
 			if (!dirlen || *(tmp-1) != '/') {
 			    *tmp++ = '/';
+			} else {
+			    /* So SvCUR_set reports the correct length below */
+			    dirlen--;
 			}
 
 			/* name came from an SV, so it will have a '\0' at the
@@ -4043,7 +4069,7 @@ PP(pp_require)
 			sv_catpv(msg, " (you may need to install the ");
 			for (c = name; c < e; c++) {
 			    if (*c == '/') {
-				sv_catpvn(msg, "::", 2);
+				sv_catpvs(msg, "::");
 			    }
 			    else {
 				sv_catpvn(msg, c, 1);
@@ -4312,8 +4338,8 @@ PP(pp_leaveeval)
 			SvPVX_const(namesv),
                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
 			G_DISCARD);
-	retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
-			       SVfARG(namesv));
+	Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
+        NOT_REACHED; /* NOTREACHED */
 	/* die_unwind() did LEAVE, or we won't be here */
     }
     else {
@@ -4603,7 +4629,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 	    SSize_t i;
 	    bool andedresults = TRUE;
 	    AV *av = (AV*) SvRV(d);
-	    const I32 len = av_len(av);
+	    const I32 len = av_tindex(av);
 	    DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
 	    if (len == -1)
 		RETPUSHYES;
@@ -4662,28 +4688,28 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 	    /* Check that the key-sets are identical */
 	    HE *he;
 	    HV *other_hv = MUTABLE_HV(SvRV(d));
-	    bool tied = FALSE;
-	    bool other_tied = FALSE;
+	    bool tied;
+	    bool other_tied;
 	    U32 this_key_count  = 0,
 	        other_key_count = 0;
 	    HV *hv = MUTABLE_HV(SvRV(e));
 
 	    DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
 	    /* Tied hashes don't know how many keys they have. */
-	    if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
-		tied = TRUE;
-	    }
-	    else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
-		HV * const temp = other_hv;
-		other_hv = hv;
-		hv = temp;
-		tied = TRUE;
+	    tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
+	    other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
+	    if (!tied ) {
+		if(other_tied) {
+		    /* swap HV sides */
+		    HV * const temp = other_hv;
+		    other_hv = hv;
+		    hv = temp;
+		    tied = TRUE;
+		    other_tied = FALSE;
+		}
+		else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
+		    RETPUSHNO;
 	    }
-	    if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
-		other_tied = TRUE;
-	    
-	    if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
-	    	RETPUSHNO;
 
 	    /* The hashes have the same number of keys, so it suffices
 	       to check that one is a subset of the other. */
@@ -4715,7 +4741,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 	}
 	else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
 	    AV * const other_av = MUTABLE_AV(SvRV(d));
-	    const SSize_t other_len = av_len(other_av) + 1;
+	    const SSize_t other_len = av_tindex(other_av) + 1;
 	    SSize_t i;
 	    HV *hv = MUTABLE_HV(SvRV(e));
 
@@ -4767,7 +4793,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 	}
 	else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
 	    AV * const other_av = MUTABLE_AV(SvRV(e));
-	    const SSize_t other_len = av_len(other_av) + 1;
+	    const SSize_t other_len = av_tindex(other_av) + 1;
 	    SSize_t i;
 
 	    DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
@@ -4785,11 +4811,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 	if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
 	    AV *other_av = MUTABLE_AV(SvRV(d));
 	    DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
-	    if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
+	    if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
 		RETPUSHNO;
 	    else {
 	    	SSize_t i;
-	    	const SSize_t other_len = av_len(other_av);
+                const SSize_t other_len = av_tindex(other_av);
 
 		if (NULL == seen_this) {
 		    seen_this = newHV();
@@ -4844,7 +4870,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 	  sm_regex_array:
 	    {
 		PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
-		const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
+		const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
 		SSize_t i;
 
 		for(i = 0; i <= this_len; ++i) {
@@ -4861,7 +4887,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 	}
 	else if (!SvOK(d)) {
 	    /* undef ~~ array */
-	    const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
+	    const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
 	    SSize_t i;
 
 	    DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
@@ -4877,7 +4903,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 	  sm_any_array:
 	    {
 		SSize_t i;
-		const SSize_t this_len = av_len(MUTABLE_AV(SvRV(e)));
+		const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
 
 		DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
 		for (i = 0; i <= this_len; ++i) {
@@ -5191,7 +5217,7 @@ S_doparseform(pTHX_ SV *sv)
 		s++;
 	    }
 	    noblank = TRUE;
-	    /* FALL THROUGH */
+	    /* FALLTHROUGH */
 	case ' ': case '\t':
 	    skipspaces++;
 	    continue;