X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e37778c28ba4f7032e74888c10d3a8b367d2b4c4..a39c66b9916c518396f68150e865c9d8e4d14018:/doop.c

diff --git a/doop.c b/doop.c
index 5cce7ed..dd6add2 100644
--- a/doop.c
+++ b/doop.c
@@ -33,7 +33,7 @@ S_do_trans_simple(pTHX_ SV * const sv)
     dVAR;
     I32 matches = 0;
     STRLEN len;
-    U8 *s = (U8*)SvPV(sv,len);
+    U8 *s = (U8*)SvPV_nomg(sv,len);
     U8 * const send = s+len;
     const short * const tbl = (short*)cPVOP->op_pv;
 
@@ -101,7 +101,7 @@ S_do_trans_count(pTHX_ SV * const sv)
 {
     dVAR;
     STRLEN len;
-    const U8 *s = (const U8*)SvPV_const(sv, len);
+    const U8 *s = (const U8*)SvPV_nomg_const(sv, len);
     const U8 * const send = s + len;
     I32 matches = 0;
     const short * const tbl = (short*)cPVOP->op_pv;
@@ -139,7 +139,7 @@ S_do_trans_complex(pTHX_ SV * const sv)
 {
     dVAR;
     STRLEN len;
-    U8 *s = (U8*)SvPV(sv, len);
+    U8 *s = (U8*)SvPV_nomg(sv, len);
     U8 * const send = s+len;
     I32 matches = 0;
     const short * const tbl = (short*)cPVOP->op_pv;
@@ -325,7 +325,7 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv)
 
     PERL_ARGS_ASSERT_DO_TRANS_SIMPLE_UTF8;
 
-    s = (U8*)SvPV(sv, len);
+    s = (U8*)SvPV_nomg(sv, len);
     if (!SvUTF8(sv)) {
 	const U8 *t = s;
 	const U8 * const e = s + len;
@@ -426,7 +426,7 @@ S_do_trans_count_utf8(pTHX_ SV * const sv)
 
     PERL_ARGS_ASSERT_DO_TRANS_COUNT_UTF8;
 
-    s = (const U8*)SvPV_const(sv, len);
+    s = (const U8*)SvPV_nomg_const(sv, len);
     if (!SvUTF8(sv)) {
 	const U8 *t = s;
 	const U8 * const e = s + len;
@@ -478,7 +478,7 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv)
     STRLEN len;
     U8 *dstart, *dend;
     U8 hibit = 0;
-    U8 *s = (U8*)SvPV(sv, len);
+    U8 *s = (U8*)SvPV_nomg(sv, len);
 
     PERL_ARGS_ASSERT_DO_TRANS_COMPLEX_UTF8;
 
@@ -635,14 +635,14 @@ Perl_do_trans(pTHX_ SV *sv)
         if (SvIsCOW(sv))
             sv_force_normal_flags(sv, 0);
         if (SvREADONLY(sv))
-            Perl_croak(aTHX_ "%s", PL_no_modify);
+            Perl_croak_no_modify(aTHX);
     }
     (void)SvPV_const(sv, len);
     if (!len)
 	return 0;
     if (!(PL_op->op_private & OPpTRANS_IDENTICAL)) {
 	if (!SvPOKp(sv))
-	    (void)SvPV_force(sv, len);
+	    (void)SvPV_force_nomg(sv, len);
 	(void)SvPOK_only_UTF8(sv);
     }
 
@@ -720,7 +720,7 @@ Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV *
 
     if (delimlen) {
 	for (; items > 0; items--,mark++) {
-	    sv_catsv(sv,delim);
+	    sv_catsv_nomg(sv,delim);
 	    sv_catsv(sv,*mark);
 	}
     }
@@ -741,6 +741,14 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
 
     PERL_ARGS_ASSERT_DO_SPRINTF;
 
+    if (SvTAINTED(*sarg))
+	TAINT_PROPER(
+		(PL_op && PL_op->op_type < OP_max)
+		    ? (PL_op->op_type == OP_PRTF)
+			? "printf"
+			: PL_op_name[PL_op->op_type]
+		    : "(unknown)"
+	);
     SvUTF8_off(sv);
     if (DO_UTF8(*sarg))
         SvUTF8_on(sv);
@@ -752,13 +760,19 @@ Perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
 
 /* currently converts input to bytes if possible, but doesn't sweat failure */
 UV
-Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
+Perl_do_vecget(pTHX_ SV *sv, SSize_t offset, int size)
 {
     dVAR;
     STRLEN srclen, len, uoffset, bitoffs = 0;
-    const unsigned char *s = (const unsigned char *) SvPV_const(sv, srclen);
+    const unsigned char *s = (const unsigned char *) SvPV_flags_const(sv, srclen,
+                             SV_GMAGIC | ((PL_op->op_flags & OPf_MOD || LVRET)
+                                          ? SV_UNDEF_RETURNS_NULL : 0));
     UV retnum = 0;
 
+    if (!s) {
+      s = (const unsigned char *)"";
+    }
+    
     PERL_ARGS_ASSERT_DO_VECGET;
 
     if (offset < 0)
@@ -807,9 +821,8 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
 	    }
 #ifdef UV_IS_QUAD
 	    else if (size == 64) {
-		if (ckWARN(WARN_PORTABLE))
-		    Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
-				"Bit vector size > 32 non-portable");
+		Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
+			       "Bit vector size > 32 non-portable");
 		if (uoffset >= srclen)
 		    retnum = 0;
 		else if (uoffset + 1 >= srclen)
@@ -875,9 +888,8 @@ Perl_do_vecget(pTHX_ SV *sv, I32 offset, I32 size)
 		      s[uoffset + 3];
 #ifdef UV_IS_QUAD
 	else if (size == 64) {
-	    if (ckWARN(WARN_PORTABLE))
-		Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
-			    "Bit vector size > 32 non-portable");
+	    Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
+			   "Bit vector size > 32 non-portable");
 	    retnum =
 		((UV) s[uoffset    ] << 56) +
 		((UV) s[uoffset + 1] << 48) +
@@ -902,8 +914,8 @@ void
 Perl_do_vecset(pTHX_ SV *sv)
 {
     dVAR;
-    register I32 offset, bitoffs = 0;
-    register I32 size;
+    register SSize_t offset, bitoffs = 0;
+    register int size;
     register unsigned char *s;
     register UV lval;
     I32 mask;
@@ -915,7 +927,8 @@ Perl_do_vecset(pTHX_ SV *sv)
 
     if (!targ)
 	return;
-    s = (unsigned char*)SvPV_force(targ, targlen);
+    s = (unsigned char*)SvPV_force_flags(targ, targlen,
+                                         SV_GMAGIC | SV_UNDEF_RETURNS_NULL);
     if (SvUTF8(targ)) {
 	/* This is handled by the SvPOK_only below...
 	if (!Perl_sv_utf8_downgrade(aTHX_ targ, TRUE))
@@ -968,9 +981,8 @@ Perl_do_vecset(pTHX_ SV *sv)
 	}
 #ifdef UV_IS_QUAD
 	else if (size == 64) {
-	    if (ckWARN(WARN_PORTABLE))
-		Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
-			    "Bit vector size > 32 non-portable");
+	    Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
+			   "Bit vector size > 32 non-portable");
 	    s[offset  ] = (U8)((lval >> 56) & 0xff);
 	    s[offset+1] = (U8)((lval >> 48) & 0xff);
 	    s[offset+2] = (U8)((lval >> 40) & 0xff);
@@ -986,222 +998,6 @@ Perl_do_vecset(pTHX_ SV *sv)
 }
 
 void
-Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
-{
-    dVAR;
-    STRLEN len;
-    char *s;
-
-    PERL_ARGS_ASSERT_DO_CHOP;
-
-    if (SvTYPE(sv) == SVt_PVAV) {
-	register I32 i;
-	AV *const av = MUTABLE_AV(sv);
-	const I32 max = AvFILL(av);
-
-	for (i = 0; i <= max; i++) {
-	    sv = MUTABLE_SV(av_fetch(av, i, FALSE));
-	    if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
-		do_chop(astr, sv);
-	}
-        return;
-    }
-    else if (SvTYPE(sv) == SVt_PVHV) {
-	HV* const hv = MUTABLE_HV(sv);
-	HE* entry;
-        (void)hv_iterinit(hv);
-        while ((entry = hv_iternext(hv)))
-            do_chop(astr,hv_iterval(hv,entry));
-        return;
-    }
-    else if (SvREADONLY(sv)) {
-        if (SvFAKE(sv)) {
-            /* SV is copy-on-write */
-	    sv_force_normal_flags(sv, 0);
-        }
-        if (SvREADONLY(sv))
-            Perl_croak(aTHX_ "%s", PL_no_modify);
-    }
-
-    if (PL_encoding && !SvUTF8(sv)) {
-	/* like in do_chomp(), utf8-ize the sv as a side-effect
-	 * if we're using encoding. */
-	sv_recode_to_utf8(sv, PL_encoding);
-    }
-
-    s = SvPV(sv, len);
-    if (len && !SvPOK(sv))
-	s = SvPV_force_nomg(sv, len);
-    if (DO_UTF8(sv)) {
-	if (s && len) {
-	    char * const send = s + len;
-	    char * const start = s;
-	    s = send - 1;
-	    while (s > start && UTF8_IS_CONTINUATION(*s))
-		s--;
-	    if (is_utf8_string((U8*)s, send - s)) {
-		sv_setpvn(astr, s, send - s);
-		*s = '\0';
-		SvCUR_set(sv, s - start);
-		SvNIOK_off(sv);
-		SvUTF8_on(astr);
-	    }
-	}
-	else
-	    sv_setpvs(astr, "");
-    }
-    else if (s && len) {
-	s += --len;
-	sv_setpvn(astr, s, 1);
-	*s = '\0';
-	SvCUR_set(sv, len);
-	SvUTF8_off(sv);
-	SvNIOK_off(sv);
-    }
-    else
-	sv_setpvs(astr, "");
-    SvSETMAGIC(sv);
-}
-
-I32
-Perl_do_chomp(pTHX_ register SV *sv)
-{
-    dVAR;
-    register I32 count;
-    STRLEN len;
-    char *s;
-    char *temp_buffer = NULL;
-    SV* svrecode = NULL;
-
-    PERL_ARGS_ASSERT_DO_CHOMP;
-
-    if (RsSNARF(PL_rs))
-	return 0;
-    if (RsRECORD(PL_rs))
-      return 0;
-    count = 0;
-    if (SvTYPE(sv) == SVt_PVAV) {
-	register I32 i;
-	AV *const av = MUTABLE_AV(sv);
-	const I32 max = AvFILL(av);
-
-	for (i = 0; i <= max; i++) {
-	    sv = MUTABLE_SV(av_fetch(av, i, FALSE));
-	    if (sv && ((sv = *(SV**)sv), sv != &PL_sv_undef))
-		count += do_chomp(sv);
-	}
-        return count;
-    }
-    else if (SvTYPE(sv) == SVt_PVHV) {
-	HV* const hv = MUTABLE_HV(sv);
-	HE* entry;
-        (void)hv_iterinit(hv);
-        while ((entry = hv_iternext(hv)))
-            count += do_chomp(hv_iterval(hv,entry));
-        return count;
-    }
-    else if (SvREADONLY(sv)) {
-        if (SvFAKE(sv)) {
-            /* SV is copy-on-write */
-	    sv_force_normal_flags(sv, 0);
-        }
-        if (SvREADONLY(sv))
-            Perl_croak(aTHX_ "%s", PL_no_modify);
-    }
-
-    if (PL_encoding) {
-	if (!SvUTF8(sv)) {
-	/* XXX, here sv is utf8-ized as a side-effect!
-	   If encoding.pm is used properly, almost string-generating
-	   operations, including literal strings, chr(), input data, etc.
-	   should have been utf8-ized already, right?
-	*/
-	    sv_recode_to_utf8(sv, PL_encoding);
-	}
-    }
-
-    s = SvPV(sv, len);
-    if (s && len) {
-	s += --len;
-	if (RsPARA(PL_rs)) {
-	    if (*s != '\n')
-		goto nope;
-	    ++count;
-	    while (len && s[-1] == '\n') {
-		--len;
-		--s;
-		++count;
-	    }
-	}
-	else {
-	    STRLEN rslen, rs_charlen;
-	    const char *rsptr = SvPV_const(PL_rs, rslen);
-
-	    rs_charlen = SvUTF8(PL_rs)
-		? sv_len_utf8(PL_rs)
-		: rslen;
-
-	    if (SvUTF8(PL_rs) != SvUTF8(sv)) {
-		/* Assumption is that rs is shorter than the scalar.  */
-		if (SvUTF8(PL_rs)) {
-		    /* RS is utf8, scalar is 8 bit.  */
-		    bool is_utf8 = TRUE;
-		    temp_buffer = (char*)bytes_from_utf8((U8*)rsptr,
-							 &rslen, &is_utf8);
-		    if (is_utf8) {
-			/* Cannot downgrade, therefore cannot possibly match
-			 */
-			assert (temp_buffer == rsptr);
-			temp_buffer = NULL;
-			goto nope;
-		    }
-		    rsptr = temp_buffer;
-		}
-		else if (PL_encoding) {
-		    /* RS is 8 bit, encoding.pm is used.
-		     * Do not recode PL_rs as a side-effect. */
-		   svrecode = newSVpvn(rsptr, rslen);
-		   sv_recode_to_utf8(svrecode, PL_encoding);
-		   rsptr = SvPV_const(svrecode, rslen);
-		   rs_charlen = sv_len_utf8(svrecode);
-		}
-		else {
-		    /* RS is 8 bit, scalar is utf8.  */
-		    temp_buffer = (char*)bytes_to_utf8((U8*)rsptr, &rslen);
-		    rsptr = temp_buffer;
-		}
-	    }
-	    if (rslen == 1) {
-		if (*s != *rsptr)
-		    goto nope;
-		++count;
-	    }
-	    else {
-		if (len < rslen - 1)
-		    goto nope;
-		len -= rslen - 1;
-		s -= rslen - 1;
-		if (memNE(s, rsptr, rslen))
-		    goto nope;
-		count += rs_charlen;
-	    }
-	}
-	s = SvPV_force_nolen(sv);
-	SvCUR_set(sv, len);
-	*SvEND(sv) = '\0';
-	SvNIOK_off(sv);
-	SvSETMAGIC(sv);
-    }
-  nope:
-
-    if (svrecode)
-	 SvREFCNT_dec(svrecode);
-
-    Safefree(temp_buffer);
-    return count;
-}
-
-void
 Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 {
     dVAR;
@@ -1225,7 +1021,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right)
 
     PERL_ARGS_ASSERT_DO_VOP;
 
-    if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv)))
+    if (sv != left || (optype != OP_BIT_AND && !SvOK(sv)))
 	sv_setpvs(sv, "");	/* avoid undef warning on |= and ^= */
     if (sv == left) {
 	lsave = lc = SvPV_force_nomg(left, leftlen);
@@ -1435,62 +1231,44 @@ Perl_do_kv(pTHX)
 {
     dVAR;
     dSP;
-    HV * const hv = MUTABLE_HV(POPs);
-    HV *keys;
+    HV * const keys = MUTABLE_HV(POPs);
     register HE *entry;
     const I32 gimme = GIMME_V;
     const I32 dokv =     (PL_op->op_type == OP_RV2HV || PL_op->op_type == OP_PADHV);
-    const I32 dokeys =   dokv || (PL_op->op_type == OP_KEYS);
-    const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES);
-
-    if (!hv) {
-	if (PL_op->op_flags & OPf_MOD || LVRET) {	/* lvalue */
-	    dTARGET;		/* make sure to clear its target here */
-	    if (SvTYPE(TARG) == SVt_PVLV)
-		LvTARG(TARG) = NULL;
-	    PUSHs(TARG);
-	}
-	RETURN;
-    }
+    /* op_type is OP_RKEYS/OP_RVALUES if pp_rkeys delegated to here */
+    const I32 dokeys =   dokv || (PL_op->op_type == OP_KEYS || PL_op->op_type == OP_RKEYS);
+    const I32 dovalues = dokv || (PL_op->op_type == OP_VALUES || PL_op->op_type == OP_RVALUES);
 
-    keys = hv;
     (void)hv_iterinit(keys);	/* always reset iterator regardless */
 
     if (gimme == G_VOID)
 	RETURN;
 
     if (gimme == G_SCALAR) {
-	IV i;
-	dTARGET;
-
 	if (PL_op->op_flags & OPf_MOD || LVRET) {	/* lvalue */
-	    if (SvTYPE(TARG) < SVt_PVLV) {
-		sv_upgrade(TARG, SVt_PVLV);
-		sv_magic(TARG, NULL, PERL_MAGIC_nkeys, NULL, 0);
-	    }
-	    LvTYPE(TARG) = 'k';
-	    if (LvTARG(TARG) != (const SV *)keys) {
-		if (LvTARG(TARG))
-		    SvREFCNT_dec(LvTARG(TARG));
-		LvTARG(TARG) = SvREFCNT_inc_simple(keys);
-	    }
-	    PUSHs(TARG);
-	    RETURN;
-	}
-
-	if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) )
-	{
-	    i = HvKEYS(keys);
+	    SV * const ret = sv_2mortal(newSV_type(SVt_PVLV));  /* Not TARG RT#67838 */
+	    sv_magic(ret, NULL, PERL_MAGIC_nkeys, NULL, 0);
+	    LvTYPE(ret) = 'k';
+	    LvTARG(ret) = SvREFCNT_inc_simple(keys);
+	    PUSHs(ret);
 	}
 	else {
-	    i = 0;
-	    while (hv_iternext(keys)) i++;
+	    IV i;
+	    dTARGET;
+
+	    if (! SvTIED_mg((const SV *)keys, PERL_MAGIC_tied) ) {
+		i = HvUSEDKEYS(keys);
+	    }
+	    else {
+		i = 0;
+		while (hv_iternext(keys)) i++;
+	    }
+	    PUSHi( i );
 	}
-	PUSHi( i );
 	RETURN;
     }
 
-    EXTEND(SP, HvKEYS(keys) * (dokeys + dovalues));
+    EXTEND(SP, HvUSEDKEYS(keys) * (dokeys + dovalues));
 
     PUTBACK;	/* hv_iternext and hv_iterval might clobber stack_sp */
     while ((entry = hv_iternext(keys))) {
@@ -1502,7 +1280,7 @@ Perl_do_kv(pTHX)
 	if (dovalues) {
 	    SV *tmpstr;
 	    PUTBACK;
-	    tmpstr = hv_iterval(hv,entry);
+	    tmpstr = hv_iterval(keys,entry);
 	    DEBUG_H(Perl_sv_setpvf(aTHX_ tmpstr, "%lu%%%d=%lu",
 			    (unsigned long)HeHASH(entry),
 			    (int)HvMAX(keys)+1,
@@ -1519,8 +1297,8 @@ Perl_do_kv(pTHX)
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
  * End:
  *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
  */