SvIVX(retval) += rs_charlen;
}
}
- s = SvPV_force_nolen(sv);
+ s = SvPV_force_nomg_nolen(sv);
SvCUR_set(sv, len);
*SvEND(sv) = '\0';
SvNIOK_off(sv);
RETURN;
}
+/* Returns false if substring is completely outside original string.
+ No length is indicated by len_iv = 0 and len_is_uv = 0. len_is_uv must
+ always be true for an explicit 0.
+*/
+bool
+Perl_translate_substr_offsets(pTHX_ STRLEN curlen, IV pos1_iv,
+ bool pos1_is_uv, IV len_iv,
+ bool len_is_uv, STRLEN *posp,
+ STRLEN *lenp)
+{
+ IV pos2_iv;
+ int pos2_is_uv;
+
+ PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
+
+ if (!pos1_is_uv && pos1_iv < 0 && curlen) {
+ pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
+ pos1_iv += curlen;
+ }
+ if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
+ return FALSE;
+
+ if (len_iv || len_is_uv) {
+ if (!len_is_uv && len_iv < 0) {
+ pos2_iv = curlen + len_iv;
+ if (curlen)
+ pos2_is_uv = curlen-1 > ~(UV)len_iv;
+ else
+ pos2_is_uv = 0;
+ } else { /* len_iv >= 0 */
+ if (!pos1_is_uv && pos1_iv < 0) {
+ pos2_iv = pos1_iv + len_iv;
+ pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
+ } else {
+ if ((UV)len_iv > curlen-(UV)pos1_iv)
+ pos2_iv = curlen;
+ else
+ pos2_iv = pos1_iv+len_iv;
+ pos2_is_uv = 1;
+ }
+ }
+ }
+ else {
+ pos2_iv = curlen;
+ pos2_is_uv = 1;
+ }
+
+ if (!pos2_is_uv && pos2_iv < 0) {
+ if (!pos1_is_uv && pos1_iv < 0)
+ return FALSE;
+ pos2_iv = 0;
+ }
+ else if (!pos1_is_uv && pos1_iv < 0)
+ pos1_iv = 0;
+
+ if ((UV)pos2_iv < (UV)pos1_iv)
+ pos2_iv = pos1_iv;
+ if ((UV)pos2_iv > curlen)
+ pos2_iv = curlen;
+
+ /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
+ *posp = (STRLEN)( (UV)pos1_iv );
+ *lenp = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
+
+ return TRUE;
+}
+
PP(pp_substr)
{
dVAR; dSP; dTARGET;
SV * pos_sv;
IV pos1_iv;
int pos1_is_uv;
- IV pos2_iv;
- int pos2_is_uv;
SV * len_sv;
IV len_iv = 0;
- int len_is_uv = 1;
- const I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
+ int len_is_uv = 0;
+ I32 lvalue = PL_op->op_flags & OPf_MOD || LVRET;
const bool rvalue = (GIMME_V != G_VOID);
const char *tmps;
SV *repl_sv = NULL;
if (num_args > 2) {
if (num_args > 3) {
- if((repl_sv = POPs)) {
- repl = SvPV_const(repl_sv, repl_len);
- repl_is_utf8 = DO_UTF8(repl_sv) && repl_len;
- }
- else num_args--;
+ if(!(repl_sv = POPs)) num_args--;
}
if ((len_sv = POPs)) {
len_iv = SvIV(len_sv);
- len_is_uv = SvIOK_UV(len_sv);
+ len_is_uv = len_iv ? SvIOK_UV(len_sv) : 1;
}
else num_args--;
}
pos1_iv = SvIV(pos_sv);
pos1_is_uv = SvIOK_UV(pos_sv);
sv = POPs;
+ if (PL_op->op_private & OPpSUBSTR_REPL_FIRST) {
+ assert(!repl_sv);
+ repl_sv = POPs;
+ }
PUTBACK;
if (repl_sv) {
+ repl = SvPV_const(repl_sv, repl_len);
+ repl_is_utf8 = DO_UTF8(repl_sv) && repl_len;
if (repl_is_utf8) {
if (!DO_UTF8(sv))
sv_utf8_upgrade(sv);
else if (DO_UTF8(sv))
repl_need_utf8_upgrade = TRUE;
}
+ else if (lvalue) {
+ SV * ret;
+ ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
+ sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
+ LvTYPE(ret) = 'x';
+ LvTARG(ret) = SvREFCNT_inc_simple(sv);
+ LvTARGOFF(ret) =
+ pos1_is_uv || pos1_iv >= 0
+ ? (STRLEN)(UV)pos1_iv
+ : (LvFLAGS(ret) |= 1, (STRLEN)(UV)-pos1_iv);
+ LvTARGLEN(ret) =
+ len_is_uv || len_iv > 0
+ ? (STRLEN)(UV)len_iv
+ : (LvFLAGS(ret) |= 2, (STRLEN)(UV)-len_iv);
+
+ SPAGAIN;
+ PUSHs(ret); /* avoid SvSETMAGIC here */
+ RETURN;
+ }
tmps = SvPV_const(sv, curlen);
if (DO_UTF8(sv)) {
utf8_curlen = sv_len_utf8(sv);
else
utf8_curlen = 0;
- if (!pos1_is_uv && pos1_iv < 0 && curlen) {
- pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
- pos1_iv += curlen;
- }
- if ((pos1_is_uv || pos1_iv > 0) && (UV)pos1_iv > curlen)
- goto bound_fail;
-
- if (num_args > 2) {
- if (!len_is_uv && len_iv < 0) {
- pos2_iv = curlen + len_iv;
- if (curlen)
- pos2_is_uv = curlen-1 > ~(UV)len_iv;
- else
- pos2_is_uv = 0;
- } else { /* len_iv >= 0 */
- if (!pos1_is_uv && pos1_iv < 0) {
- pos2_iv = pos1_iv + len_iv;
- pos2_is_uv = (UV)len_iv > (UV)IV_MAX;
- } else {
- if ((UV)len_iv > curlen-(UV)pos1_iv)
- pos2_iv = curlen;
- else
- pos2_iv = pos1_iv+len_iv;
- pos2_is_uv = 1;
- }
- }
- }
- else {
- pos2_iv = curlen;
- pos2_is_uv = 1;
- }
-
- if (!pos2_is_uv && pos2_iv < 0) {
- if (!pos1_is_uv && pos1_iv < 0)
- goto bound_fail;
- pos2_iv = 0;
- }
- else if (!pos1_is_uv && pos1_iv < 0)
- pos1_iv = 0;
-
- if ((UV)pos2_iv < (UV)pos1_iv)
- pos2_iv = pos1_iv;
- if ((UV)pos2_iv > curlen)
- pos2_iv = curlen;
-
{
- /* pos1_iv and pos2_iv both in 0..curlen, so the cast is safe */
- const STRLEN pos = (STRLEN)( (UV)pos1_iv );
- const STRLEN len = (STRLEN)( (UV)pos2_iv - (UV)pos1_iv );
- STRLEN byte_len = len;
- STRLEN byte_pos = utf8_curlen
- ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
-
- if (lvalue && !repl) {
- SV * ret;
-
- if (!SvGMAGICAL(sv)) {
- if (SvROK(sv)) {
- SvPV_force_nolen(sv);
- Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
- "Attempt to use reference as lvalue in substr");
- }
- if (isGV_with_GP(sv))
- SvPV_force_nolen(sv);
- else if (SvOK(sv)) /* is it defined ? */
- (void)SvPOK_only_UTF8(sv);
- else
- sv_setpvs(sv, ""); /* avoid lexical reincarnation */
- }
+ STRLEN pos, len, byte_len, byte_pos;
- ret = sv_2mortal(newSV_type(SVt_PVLV)); /* Not TARG RT#67838 */
- sv_magic(ret, NULL, PERL_MAGIC_substr, NULL, 0);
- LvTYPE(ret) = 'x';
- LvTARG(ret) = SvREFCNT_inc_simple(sv);
- LvTARGOFF(ret) = pos;
- LvTARGLEN(ret) = len;
+ if (!translate_substr_offsets(
+ curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
+ )) goto bound_fail;
- SPAGAIN;
- PUSHs(ret); /* avoid SvSETMAGIC here */
- RETURN;
- }
+ byte_len = len;
+ byte_pos = utf8_curlen
+ ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
tmps += byte_pos;
repl = SvPV_const(repl_sv_copy, repl_len);
repl_is_utf8 = DO_UTF8(repl_sv_copy) && repl_len;
}
+ if (SvROK(sv))
+ Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR),
+ "Attempt to use reference as lvalue in substr"
+ );
if (!SvOK(sv))
sv_setpvs(sv, "");
sv_insert_flags(sv, byte_pos, byte_len, repl, repl_len, 0);
RETURN;
bound_fail:
- if (lvalue || repl)
+ if (repl)
Perl_croak(aTHX_ "substr outside of string");
Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string");
RETPUSHUNDEF;
https://perl5.git.perl.org / perl5.git / blobdiff