const I32 flags = is_lvalue_sub();
if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (GIMME == G_SCALAR)
+ /* diag_listed_as: Can't return %s to lvalue scalar context */
Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
PUSHs(TARG);
RETURN;
const I32 flags = is_lvalue_sub();
if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (GIMME == G_SCALAR)
+ /* diag_listed_as: Can't return %s to lvalue scalar context */
Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
RETURN;
}
When noinit is true, the absence of a gv will cause a retval of undef.
This is unrelated to the cv-to-gv assignment case.
-
- Make sure to use SPAGAIN after calling this.
*/
static SV *
sv = SvRV(sv);
if (SvTYPE(sv) == SVt_PVIO) {
GV * const gv = MUTABLE_GV(sv_newmortal());
- gv_init(gv, 0, "$__ANONIO__", 11, 0);
+ gv_init(gv, 0, "__ANONIO__", 10, 0);
GvIOp(gv) = MUTABLE_IO(sv);
SvREFCNT_inc_void_NN(sv);
sv = MUTABLE_SV(gv);
SvFAKE_off(sv);
}
}
- if (SvFAKE(sv)) {
+ if (SvFAKE(sv) && !(PL_op->op_private & OPpALLOW_FAKE)) {
SV *newsv = sv_newmortal();
sv_setsv_flags(newsv, sv, 0);
SvFAKE_off(newsv);
((PL_op->op_flags & OPf_SPECIAL) && !(PL_op->op_flags & OPf_MOD))
|| PL_op->op_type == OP_READLINE
);
- SPAGAIN;
if (PL_op->op_private & OPpLVAL_INTRO)
save_gp(MUTABLE_GV(sv), !(PL_op->op_flags & OPf_SPECIAL));
SETs(sv);
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
sv = amagic_deref_call(sv, to_sv_amg);
- SPAGAIN;
}
sv = SvRV(sv);
if (cv) {
if (CvCLONE(cv))
cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
- if ((PL_op->op_private & OPpLVAL_INTRO)) {
- if (gv && GvCV(gv) == cv && (gv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
- cv = GvCV(gv);
- if (!CvLVALUE(cv))
- DIE(aTHX_ "Can't modify non-lvalue subroutine call");
- }
}
else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
cv = MUTABLE_CV(gv);
const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
if (!code || code == -KEY_CORE)
DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
- if (code < 0) { /* Overridable. */
+ {
SV * const sv = core_prototype(NULL, s + 6, code, NULL);
if (sv) ret = sv;
}
RETPUSHNO;
}
+ /* Make study a no-op. It's no longer useful and its existence
+ complicates matters elsewhere. This is a low-impact band-aid.
+ The relevant code will be neatly removed in a future release. */
+ RETPUSHYES;
+
if (len < 0xFF) {
quanta = 1;
} else if (len < 0xFFFF) {
}
TARG = sv_newmortal();
if(PL_op->op_type == OP_TRANSR) {
- SV * const newsv = newSVsv(sv);
+ STRLEN len;
+ const char * const pv = SvPV(sv,len);
+ SV * const newsv = newSVpvn_flags(pv, len, SVs_TEMP|SvUTF8(sv));
do_trans(newsv);
- mPUSHs(newsv);
+ PUSHs(newsv);
}
else PUSHi(do_trans(sv));
RETURN;
/* SV is copy-on-write */
sv_force_normal_flags(sv, 0);
}
- if (SvREADONLY(sv))
+ else
Perl_croak_no_modify(aTHX);
}
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);
const UV u = SvUV_nomg(left) & SvUV_nomg(right);
SETu(u);
}
- if (left_ro_nonnum) SvNIOK_off(left);
+ if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
if (right_ro_nonnum) SvNIOK_off(right);
}
else {
const UV result = op_type == OP_BIT_OR ? (l | r) : (l ^ r);
SETu(result);
}
- if (left_ro_nonnum) SvNIOK_off(left);
+ if (left_ro_nonnum && left != TARG) SvNIOK_off(left);
if (right_ro_nonnum) SvNIOK_off(right);
}
else {
if (neg_report) {
if (op_type == OP_LOG ? (value <= 0.0) : (value < 0.0)) {
SET_NUMERIC_STANDARD();
+ /* diag_listed_as: Can't take log of %g */
DIE(aTHX_ "Can't take %s of %"NVgf, neg_report, value);
}
}
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;
+ STRLEN pos, len, byte_len, byte_pos;
- if (lvalue && !repl) {
- SV * ret;
+ if (!translate_substr_offsets(
+ curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
+ )) goto bound_fail;
- 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 */
- }
-
- 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;
-
- 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;
if (PL_encoding && !IN_BYTES) {
sv_recode_to_utf8(TARG, PL_encoding);
tmps = SvPVX(TARG);
- if (SvCUR(TARG) == 0 || !is_utf8_string((U8*)tmps, SvCUR(TARG)) ||
- UNICODE_IS_REPLACEMENT(utf8_to_uvchr((U8*)tmps, NULL))) {
+ if (SvCUR(TARG) == 0
+ || ! is_utf8_string((U8*)tmps, SvCUR(TARG))
+ || UTF8_IS_REPLACEMENT((U8*) tmps, (U8*) tmps + SvCUR(TARG)))
+ {
SvGROW(TARG, 2);
tmps = SvPVX(TARG);
SvCUR_set(TARG, 1);
STRLEN tculen; /* tculen is the byte length of the freshly titlecased (or
* lowercased) character stored in tmpbuf. May be either
* UTF-8 or not, but in either case is the number of bytes */
+ bool tainted = FALSE;
SvGETMAGIC(source);
if (SvOK(source)) {
else if (DO_UTF8(source)) { /* Is the source utf8? */
doing_utf8 = TRUE;
ulen = UTF8SKIP(s);
- if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
- else toLOWER_utf8(s, tmpbuf, &tculen);
+ if (op_type == OP_UCFIRST) {
+ _to_utf8_title_flags(s, tmpbuf, &tculen,
+ cBOOL(IN_LOCALE_RUNTIME), &tainted);
+ }
+ else {
+ _to_utf8_lower_flags(s, tmpbuf, &tculen,
+ cBOOL(IN_LOCALE_RUNTIME), &tainted);
+ }
/* we can't do in-place if the length changes. */
if (ulen != tculen) inplace = FALSE;
Copy(tmpbuf, d, tculen, U8);
SvCUR_set(dest, need - 1);
}
+
+ if (tainted) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
}
else { /* Neither source nor dest are in or need to be UTF-8 */
if (slen) {
if (DO_UTF8(source)) {
const U8 *const send = s + len;
U8 tmpbuf[UTF8_MAXBYTES+1];
+ bool tainted = FALSE;
/* All occurrences of these are to be moved to follow any other marks.
* This is context-dependent. We may not be passed enough context to
* and copy it to the output buffer */
u = UTF8SKIP(s);
- uv = toUPPER_utf8(s, tmpbuf, &ulen);
+ uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
+ cBOOL(IN_LOCALE_RUNTIME), &tainted);
if (uv == GREEK_CAPITAL_LETTER_IOTA
- && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
+ && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
{
in_iota_subscript = TRUE;
}
}
SvUTF8_on(dest);
*d = '\0';
+
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
+ if (tainted) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
}
else { /* Not UTF-8 */
if (len) {
if (DO_UTF8(source)) {
const U8 *const send = s + len;
U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
+ bool tainted = FALSE;
while (s < send) {
const STRLEN u = UTF8SKIP(s);
STRLEN ulen;
- toLOWER_utf8(s, tmpbuf, &ulen);
+ _to_utf8_lower_flags(s, tmpbuf, &ulen,
+ cBOOL(IN_LOCALE_RUNTIME), &tainted);
/* Here is where we would do context-sensitive actions. See the
* commit message for this comment for why there isn't any */
SvUTF8_on(dest);
*d = '\0';
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
+ if (tainted) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
} else { /* Not utf8 */
if (len) {
const U8 *const send = s + len;
d = SvPVX(TARG);
if (DO_UTF8(sv)) {
while (len) {
- if (UTF8_IS_CONTINUED(*s)) {
- STRLEN ulen = UTF8SKIP(s);
- if (ulen > len)
- ulen = len;
- len -= ulen;
- while (ulen--)
- *d++ = *s++;
+ STRLEN ulen = UTF8SKIP(s);
+ bool to_quote = FALSE;
+
+ if (UTF8_IS_INVARIANT(*s)) {
+ if (_isQUOTEMETA(*s)) {
+ to_quote = TRUE;
+ }
}
- else {
- if (!isALNUM(*s))
- *d++ = '\\';
- *d++ = *s++;
- len--;
+ else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
+
+ /* In locale, we quote all non-ASCII Latin1 chars.
+ * Otherwise use the quoting rules */
+ if (IN_LOCALE_RUNTIME
+ || _isQUOTEMETA(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1))))
+ {
+ to_quote = TRUE;
+ }
}
+ else if (_is_utf8_quotemeta((U8 *) s)) {
+ to_quote = TRUE;
+ }
+
+ if (to_quote) {
+ *d++ = '\\';
+ }
+ if (ulen > len)
+ ulen = len;
+ len -= ulen;
+ while (ulen--)
+ *d++ = *s++;
}
SvUTF8_on(TARG);
}
+ else if (IN_UNI_8_BIT) {
+ while (len--) {
+ if (_isQUOTEMETA(*s))
+ *d++ = '\\';
+ *d++ = *s++;
+ }
+ }
else {
+ /* For non UNI_8_BIT (and hence in locale) just quote all \W
+ * including everything above ASCII */
while (len--) {
- if (!isALNUM(*s))
+ if (!isWORDCHAR_A(*s))
*d++ = '\\';
*d++ = *s++;
}
RETURN;
}
+PP(pp_fc)
+{
+ dVAR;
+ dTARGET;
+ dSP;
+ SV *source = TOPs;
+ STRLEN len;
+ STRLEN min;
+ SV *dest;
+ const U8 *s;
+ const U8 *send;
+ U8 *d;
+ U8 tmpbuf[UTF8_MAXBYTES * UTF8_MAX_FOLD_CHAR_EXPAND + 1];
+ const bool full_folding = TRUE;
+ const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
+ | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
+
+ /* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
+ * You are welcome(?) -Hugmeir
+ */
+
+ SvGETMAGIC(source);
+
+ dest = TARG;
+
+ if (SvOK(source)) {
+ s = (const U8*)SvPV_nomg_const(source, len);
+ } else {
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit(source);
+ s = (const U8*)"";
+ len = 0;
+ }
+
+ min = len + 1;
+
+ SvUPGRADE(dest, SVt_PV);
+ d = (U8*)SvGROW(dest, min);
+ (void)SvPOK_only(dest);
+
+ SETs(dest);
+
+ send = s + len;
+ if (DO_UTF8(source)) { /* UTF-8 flagged string. */
+ bool tainted = FALSE;
+ while (s < send) {
+ const STRLEN u = UTF8SKIP(s);
+ STRLEN ulen;
+
+ _to_utf8_fold_flags(s, tmpbuf, &ulen, flags, &tainted);
+
+ if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
+ const UV o = d - (U8*)SvPVX_const(dest);
+ SvGROW(dest, min);
+ d = (U8*)SvPVX(dest) + o;
+ }
+
+ Copy(tmpbuf, d, ulen, U8);
+ d += ulen;
+ s += u;
+ }
+ SvUTF8_on(dest);
+ if (tainted) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
+ } /* Unflagged string */
+ else if (len) {
+ /* For locale, bytes, and nothing, the behavior is supposed to be the
+ * same as lc().
+ */
+ if ( IN_LOCALE_RUNTIME ) { /* Under locale */
+ TAINT;
+ SvTAINTED_on(dest);
+ for (; s < send; d++, s++)
+ *d = toLOWER_LC(*s);
+ }
+ else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
+ for (; s < send; d++, s++)
+ *d = toLOWER(*s);
+ }
+ else {
+ /* For ASCII and the Latin-1 range, there's only two troublesome folds,
+ * \x{DF} (\N{LATIN SMALL LETTER SHARP S}), which under full casefolding
+ * becomes 'ss', and \x{B5} (\N{MICRO SIGN}), which under any fold becomes
+ * \x{3BC} (\N{GREEK SMALL LETTER MU}) -- For the rest, the casefold is
+ * their lowercase.
+ */
+ for (; s < send; d++, s++) {
+ if (*s == MICRO_SIGN) {
+ /* \N{MICRO SIGN}'s casefold is \N{GREEK SMALL LETTER MU}, which
+ * is outside of the latin-1 range. There's a couple of ways to
+ * deal with this -- khw discusses them in pp_lc/uc, so go there :)
+ * What we do here is upgrade what we had already casefolded,
+ * then enter an inner loop that appends the rest of the characters
+ * as UTF-8.
+ */
+ len = d - (U8*)SvPVX_const(dest);
+ SvCUR_set(dest, len);
+ len = sv_utf8_upgrade_flags_grow(dest,
+ SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
+ /* The max expansion for latin1
+ * chars is 1 byte becomes 2 */
+ (send -s) * 2 + 1);
+ d = (U8*)SvPVX(dest) + len;
+
+ CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_SMALL_LETTER_MU);
+ s++;
+ for (; s < send; s++) {
+ STRLEN ulen;
+ UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
+ if UNI_IS_INVARIANT(fc) {
+ if ( full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
+ *d++ = 's';
+ *d++ = 's';
+ }
+ else
+ *d++ = (U8)fc;
+ }
+ else {
+ Copy(tmpbuf, d, ulen, U8);
+ d += ulen;
+ }
+ }
+ break;
+ }
+ else if (full_folding && *s == LATIN_SMALL_LETTER_SHARP_S) {
+ /* Under full casefolding, LATIN SMALL LETTER SHARP S becomes "ss",
+ * which may require growing the SV.
+ */
+ if (SvLEN(dest) < ++min) {
+ const UV o = d - (U8*)SvPVX_const(dest);
+ SvGROW(dest, min);
+ d = (U8*)SvPVX(dest) + o;
+ }
+ *(d)++ = 's';
+ *d = 's';
+ }
+ else { /* If it's not one of those two, the fold is their lower case */
+ *d = toLOWER_LATIN1(*s);
+ }
+ }
+ }
+ }
+ *d = '\0';
+ SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
+
+ if (SvTAINTED(source))
+ SvTAINT(dest);
+ SvSETMAGIC(dest);
+ RETURN;
+}
+
/* Arrays. */
PP(pp_aslice)
svp = he ? &HeVAL(he) : NULL;
if (lval) {
- if (!svp || *svp == &PL_sv_undef) {
+ if (!svp || !*svp || *svp == &PL_sv_undef) {
DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
}
if (localizing) {
SAVEHDELETE(hv, keysv);
}
}
- *MARK = svp ? *svp : &PL_sv_undef;
+ *MARK = svp && *svp ? *svp : &PL_sv_undef;
}
if (GIMME != G_ARRAY) {
MARK = ORIGMARK;
continue;
}
else {
- if (!utf8_to_uvchr(s, 0))
+ if (!utf8_to_uvchr_buf(s, send, 0))
break;
up = (char*)s;
s += UTF8SKIP(s);
pm = (PMOP*)POPs;
#endif
if (!pm || !s)
- DIE(aTHX_ "panic: pp_split");
+ DIE(aTHX_ "panic: pp_split, pm=%p, s=%p", pm, s);
rx = PM_GETRE(pm);
TAINT_IF(get_regex_charset(RX_EXTFLAGS(rx)) == REGEX_LOCALE_CHARSET &&
{
dSP;
int opnum = SvIOK(cSVOP_sv) ? (int)SvUV(cSVOP_sv) : 0;
- int defgv = PL_opargs[opnum] & OA_DEFGV, whicharg = 0;
+ int defgv = PL_opargs[opnum] & OA_DEFGV ||opnum==OP_GLOB, whicharg = 0;
AV * const at_ = GvAV(PL_defgv);
- SV **svp = AvARRAY(at_);
- I32 minargs = 0, maxargs = 0, numargs = AvFILLp(at_)+1;
+ SV **svp = at_ ? AvARRAY(at_) : NULL;
+ I32 minargs = 0, maxargs = 0, numargs = at_ ? AvFILLp(at_)+1 : 0;
I32 oa = opnum ? PL_opargs[opnum] >> OASHIFT : 0;
bool seen_question = 0;
const char *err = NULL;
/* diag_listed_as: Too many arguments for %s */
Perl_croak(aTHX_
"%s arguments for %s", err,
- opnum ? OP_DESC(PL_op->op_next) : SvPV_nolen_const(cSVOP_sv)
+ opnum ? PL_op_desc[opnum] : SvPV_nolen_const(cSVOP_sv)
);
/* Reset the stack pointer. Without this, we end up returning our own
whicharg++;
switch (oa & 7) {
case OA_SCALAR:
+ try_defsv:
if (!numargs && defgv && whicharg == minargs + 1) {
PERL_SI * const oldsi = PL_curstackinfo;
I32 const oldcxix = oldsi->si_cxix;
}
break;
case OA_SCALARREF:
- {
+ if (!numargs) goto try_defsv;
+ else {
const bool wantscalar =
PL_op->op_private & OPpCOREARGS_SCALARMOD;
if (!svp || !*svp || !SvROK(*svp)
: "reference to one of [$@%*]"
);
PUSHs(SvRV(*svp));
- break;
}
+ break;
default:
DIE(aTHX_ "panic: unknown OA_*: %x", (unsigned)(oa&7));
}
RETURN;
}
+PP(pp_runcv)
+{
+ dSP;
+ CV *cv;
+ if (PL_op->op_private & OPpOFFBYONE) {
+ PERL_SI * const oldsi = PL_curstackinfo;
+ I32 const oldcxix = oldsi->si_cxix;
+ if (oldcxix) oldsi->si_cxix--;
+ else PL_curstackinfo = oldsi->si_prev;
+ cv = find_runcv(NULL);
+ PL_curstackinfo = oldsi;
+ oldsi->si_cxix = oldcxix;
+ }
+ else cv = find_runcv(NULL);
+ XPUSHs(CvUNIQUE(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
+ RETURN;
+}
+
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff