dVAR; dSP; dTARGET;
I32 gimme;
assert(SvTYPE(TARG) == SVt_PVAV);
- if (PL_op->op_private & OPpLVAL_INTRO)
- if (!(PL_op->op_private & OPpPAD_STATE))
+ if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
+ if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
SAVECLEARSV(PAD_SVl(PL_op->op_targ));
EXTEND(SP, 1);
if (PL_op->op_flags & OPf_REF) {
gimme = GIMME_V;
if (gimme == G_ARRAY) {
/* XXX see also S_pushav in pp_hot.c */
- const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
+ const Size_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
EXTEND(SP, maxarg);
if (SvMAGICAL(TARG)) {
- U32 i;
- for (i=0; i < (U32)maxarg; i++) {
+ Size_t i;
+ for (i=0; i < maxarg; i++) {
SV * const * const svp = av_fetch(MUTABLE_AV(TARG), i, FALSE);
SP[i+1] = (svp) ? *svp : &PL_sv_undef;
}
}
else {
- Copy(AvARRAY((const AV *)TARG), SP+1, maxarg, SV*);
+ PADOFFSET i;
+ for (i=0; i < (PADOFFSET)maxarg; i++) {
+ SV * const sv = AvARRAY((const AV *)TARG)[i];
+ SP[i+1] = sv ? sv : &PL_sv_undef;
+ }
}
SP += maxarg;
}
else if (gimme == G_SCALAR) {
SV* const sv = sv_newmortal();
- const I32 maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
+ const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
sv_setiv(sv, maxarg);
PUSHs(sv);
}
assert(SvTYPE(TARG) == SVt_PVHV);
XPUSHs(TARG);
- if (PL_op->op_private & OPpLVAL_INTRO)
- if (!(PL_op->op_private & OPpPAD_STATE))
+ if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
+ if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
SAVECLEARSV(PAD_SVl(PL_op->op_targ));
if (PL_op->op_flags & OPf_REF)
RETURN;
RETURN;
}
else {
- if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
- const MAGIC * const mg = mg_find(sv, PERL_MAGIC_regex_global);
- if (mg && mg->mg_len >= 0) {
+ const MAGIC * const mg = mg_find_mglob(sv);
+ if (mg && mg->mg_len != -1) {
dTARGET;
- I32 i = mg->mg_len;
- if (DO_UTF8(sv))
- sv_pos_b2u(sv, &i);
- PUSHi(i);
+ STRLEN i = mg->mg_len;
+ if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
+ i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
+ PUSHu(i);
RETURN;
}
- }
- RETPUSHUNDEF;
+ RETPUSHUNDEF;
}
}
const char * s = SvPVX_const(TOPs);
if (strnEQ(s, "CORE::", 6)) {
const int code = keyword(s + 6, SvCUR(TOPs) - 6, 1);
- if (!code || code == -KEY_CORE)
+ if (!code)
DIE(aTHX_ "Can't find an opnumber for \"%"UTF8f"\"",
UTF8fARG(SvFLAGS(TOPs) & SVf_UTF8, SvCUR(TOPs)-6, s+6));
{
SvTEMP_off(sv);
SvREFCNT_inc_void_NN(sv);
}
- else if (SvPADTMP(sv) && !IS_PADGV(sv))
+ else if (SvPADTMP(sv)) {
+ assert(!IS_PADGV(sv));
sv = newSVsv(sv);
+ }
else {
SvTEMP_off(sv);
SvREFCNT_inc_void_NN(sv);
const char *ptr;
if (!ssv) goto curstash;
- if (!SvGMAGICAL(ssv) && !SvAMAGIC(ssv) && SvROK(ssv))
+ SvGETMAGIC(ssv);
+ if (SvROK(ssv)) {
+ if (!SvAMAGIC(ssv)) {
+ frog:
Perl_croak(aTHX_ "Attempt to bless into a reference");
- ptr = SvPV_const(ssv,len);
+ }
+ /* SvAMAGIC is on here, but it only means potentially overloaded,
+ so after stringification: */
+ ptr = SvPV_nomg_const(ssv,len);
+ /* We need to check the flag again: */
+ if (!SvAMAGIC(ssv)) goto frog;
+ }
+ else ptr = SvPV_nomg_const(ssv,len);
if (len == 0)
Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
"Explicit blessing to '' (assuming package main)");
else stash = NULL;
}
+ SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
gp_free(MUTABLE_GV(sv));
Newxz(gp, 1, GP);
GvGP_set(sv, gp_ref(gp));
+#ifndef PERL_DONT_CREATE_GVSV
GvSV(sv) = newSV(0);
+#endif
GvLINE(sv) = CopLINE(PL_curcop);
GvEGV(sv) = MUTABLE_GV(sv);
GvMULTI_on(sv);
static const char* const oom_list_extend = "Out of memory during list extend";
const I32 items = SP - MARK;
const I32 max = items * count;
+ const U8 mod = PL_op->op_flags & OPf_MOD;
MEM_WRAP_CHECK_1(max, SV*, oom_list_extend);
/* Did the max computation overflow? */
SvREADONLY_on(*SP);
}
#else
- if (*SP)
+ if (*SP) {
+ if (mod && SvPADTMP(*SP)) {
+ assert(!IS_PADGV(*SP));
+ *SP = sv_mortalcopy(*SP);
+ }
SvTEMP_off((*SP));
+ }
#endif
SP--;
}
tryAMAGICbin_MG(amg_type, AMGf_set);
{
dPOPTOPssrl;
- const int cmp = (IN_LOCALE_RUNTIME
- ? sv_cmp_locale_flags(left, right, 0)
- : sv_cmp_flags(left, right, 0));
+ const int cmp =
+#ifdef USE_LC_COLLATE
+ (IN_LC_RUNTIME(LC_COLLATE))
+ ? sv_cmp_locale_flags(left, right, 0)
+ :
+#endif
+ sv_cmp_flags(left, right, 0);
SETs(boolSV(cmp * multiplier < rhs));
RETURN;
}
tryAMAGICbin_MG(scmp_amg, 0);
{
dPOPTOPssrl;
- const int cmp = (IN_LOCALE_RUNTIME
- ? sv_cmp_locale_flags(left, right, 0)
- : sv_cmp_flags(left, right, 0));
+ const int cmp =
+#ifdef USE_LC_COLLATE
+ (IN_LC_RUNTIME(LC_COLLATE))
+ ? sv_cmp_locale_flags(left, right, 0)
+ :
+#endif
+ sv_cmp_flags(left, right, 0);
SETi( cmp );
RETURN;
}
I32 anum;
STRLEN len;
- (void)SvPV_nomg_const(sv,len); /* force check for uninit var */
- sv_setsv_nomg(TARG, sv);
- tmps = (U8*)SvPV_force_nomg(TARG, len);
+ sv_copypv_nomg(TARG, sv);
+ tmps = (U8*)SvPV_nomg(TARG, len);
anum = len;
if (SvUTF8(TARG)) {
/* Calculate exact length, let's not estimate. */
--Jarkko Hietaniemi 27 September 1998
*/
-#ifndef HAS_DRAND48_PROTO
-extern double drand48 (void);
-#endif
-
PP(pp_rand)
{
dVAR;
int pos2_is_uv;
PERL_ARGS_ASSERT_TRANSLATE_SUBSTR_OFFSETS;
+ PERL_UNUSED_CONTEXT;
if (!pos1_is_uv && pos1_iv < 0 && curlen) {
pos1_is_uv = curlen-1 > ~(UV)pos1_iv;
SV *temp = NULL;
STRLEN biglen;
STRLEN llen = 0;
- I32 offset;
- I32 retval;
+ SSize_t offset = 0;
+ SSize_t retval;
const char *big_p;
const char *little_p;
bool big_utf8;
offset = is_index ? 0 : biglen;
else {
if (big_utf8 && offset > 0)
- sv_pos_u2b(big, &offset, 0);
+ offset = sv_pos_u2b_flags(big, offset, 0, SV_CONST_RETURN);
if (!is_index)
offset += llen;
}
if (offset < 0)
offset = 0;
- else if (offset > (I32)biglen)
+ else if (offset > (SSize_t)biglen)
offset = biglen;
if (!(little_p = is_index
? fbm_instr((unsigned char*)big_p + offset,
else {
retval = little_p - big_p;
if (retval > 0 && big_utf8)
- sv_pos_b2u(big, &retval);
+ retval = sv_pos_b2u_flags(big, retval, SV_CONST_RETURN);
}
SvREFCNT_dec(temp);
fail:
if (PL_encoding && SvPOK(argsv) && !DO_UTF8(argsv)) {
SV * const tmpsv = sv_2mortal(newSVsv(argsv));
s = (U8*)sv_recode_to_utf8(tmpsv, PL_encoding);
+ len = UTF8SKIP(s); /* Should be well-formed; so this is its length */
argsv = tmpsv;
}
- XPUSHu(DO_UTF8(argsv) ?
- utf8n_to_uvchr(s, UTF8_MAXBYTES, 0, UTF8_ALLOW_ANYUV) :
- (UV)(*s & 0xff));
+ XPUSHu(DO_UTF8(argsv)
+ ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV)
+ : (UV)(*s));
RETURN;
}
top = top2;
}
Perl_warner(aTHX_ packWARN(WARN_UTF8),
- "Invalid negative number (%"SVf") in chr", top);
+ "Invalid negative number (%"SVf") in chr", SVfARG(top));
}
value = UNICODE_REPLACEMENT;
} else {
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)) {
- s = (const U8*)SvPV_nomg_const(source, slen);
- } else {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(source);
- s = (const U8*)"";
- slen = 0;
- }
+ s = (const U8*)SvPV_const(source, slen);
/* We may be able to get away with changing only the first character, in
* place, but not if read-only, etc. Later we may discover more reasons to
* not convert in-place. */
- inplace = SvPADTMP(source) && !SvREADONLY(source) && SvTEMP(source);
+ inplace = !SvREADONLY(source)
+ && ( SvPADTMP(source)
+ || ( SvTEMP(source) && !SvSMAGICAL(source)
+ && SvREFCNT(source) == 1));
/* First calculate what the changed first character should be. This affects
* whether we can just swap it out, leaving the rest of the string unchanged,
doing_utf8 = TRUE;
ulen = UTF8SKIP(s);
if (op_type == OP_UCFIRST) {
- _to_utf8_title_flags(s, tmpbuf, &tculen,
- cBOOL(IN_LOCALE_RUNTIME), &tainted);
+#ifdef USE_LOCALE_CTYPE
+ _to_utf8_title_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
+#else
+ _to_utf8_title_flags(s, tmpbuf, &tculen, 0);
+#endif
}
else {
- _to_utf8_lower_flags(s, tmpbuf, &tculen,
- cBOOL(IN_LOCALE_RUNTIME), &tainted);
+#ifdef USE_LOCALE_CTYPE
+ _to_utf8_lower_flags(s, tmpbuf, &tculen, IN_LC_RUNTIME(LC_CTYPE));
+#else
+ _to_utf8_lower_flags(s, tmpbuf, &tculen, 0);
+#endif
}
/* we can't do in-place if the length changes. */
if (op_type == OP_LCFIRST) {
/* lower case the first letter: no trickiness for any character */
- *tmpbuf = (IN_LOCALE_RUNTIME) ? toLOWER_LC(*s) :
- ((IN_UNI_8_BIT) ? toLOWER_LATIN1(*s) : toLOWER(*s));
+ *tmpbuf =
+#ifdef USE_LOCALE_CTYPE
+ (IN_LC_RUNTIME(LC_CTYPE))
+ ? toLOWER_LC(*s)
+ :
+#endif
+ (IN_UNI_8_BIT)
+ ? toLOWER_LATIN1(*s)
+ : toLOWER(*s);
}
/* is ucfirst() */
- else if (IN_LOCALE_RUNTIME) {
- *tmpbuf = toUPPER_LC(*s); /* This would be a bug if any locales
- * have upper and title case different
- */
+#ifdef USE_LOCALE_CTYPE
+ else if (IN_LC_RUNTIME(LC_CTYPE)) {
+ if (IN_UTF8_CTYPE_LOCALE) {
+ goto do_uni_rules;
+ }
+
+ *tmpbuf = (U8) toUPPER_LC(*s); /* This would be a bug if any
+ locales have upper and title case
+ different */
}
+#endif
else if (! IN_UNI_8_BIT) {
*tmpbuf = toUPPER(*s); /* Returns caseless for non-ascii, or
* on EBCDIC machines whatever the
* native function does */
}
- else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
- UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
+ else {
+ /* Here, is ucfirst non-UTF-8, not in locale (unless that locale is
+ * UTF-8, which we treat as not in locale), and cased latin1 */
+ UV title_ord;
+#ifdef USE_LOCALE_CTYPE
+ do_uni_rules:
+#endif
+
+ title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
if (tculen > 1) {
assert(tculen == 2);
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 (IN_LOCALE_RUNTIME) {
- TAINT;
- SvTAINTED_on(dest);
- }
if (inplace) { /* in-place, only need to change the 1st char */
*d = *tmpbuf;
}
/* In a "use bytes" we don't treat the source as UTF-8, but, still want
* the destination to retain that flag */
- if (SvUTF8(source))
+ if (SvUTF8(source) && ! IN_BYTES)
SvUTF8_on(dest);
if (!inplace) { /* Finish the rest of the string, unchanged */
SvCUR_set(dest, need - 1);
}
}
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
+#endif
if (dest != source && SvTAINTED(source))
SvTAINT(dest);
SvSETMAGIC(dest);
SvGETMAGIC(source);
- if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
- && SvTEMP(source) && !DO_UTF8(source)
- && (IN_LOCALE_RUNTIME || ! IN_UNI_8_BIT)) {
-
- /* We can convert in place. The reason we can't if in UNI_8_BIT is to
- * make the loop tight, so we overwrite the source with the dest before
- * looking at it, and we need to look at the original source
- * afterwards. There would also need to be code added to handle
- * switching to not in-place in midstream if we run into characters
- * that change the length.
- */
+ if ((SvPADTMP(source)
+ ||
+ (SvTEMP(source) && !SvSMAGICAL(source) && SvREFCNT(source) == 1))
+ && !SvREADONLY(source) && SvPOK(source)
+ && !DO_UTF8(source)
+ && (
+#ifdef USE_LOCALE_CTYPE
+ (IN_LC_RUNTIME(LC_CTYPE))
+ ? ! IN_UTF8_CTYPE_LOCALE
+ :
+#endif
+ ! IN_UNI_8_BIT))
+ {
+
+ /* We can convert in place. The reason we can't if in UNI_8_BIT is to
+ * make the loop tight, so we overwrite the source with the dest before
+ * looking at it, and we need to look at the original source
+ * afterwards. There would also need to be code added to handle
+ * switching to not in-place in midstream if we run into characters
+ * that change the length. Since being in locale overrides UNI_8_BIT,
+ * that latter becomes irrelevant in the above test; instead for
+ * locale, the size can't normally change, except if the locale is a
+ * UTF-8 one */
dest = source;
s = d = (U8*)SvPV_force_nomg(source, len);
min = len + 1;
dest = TARG;
- /* The old implementation would copy source into TARG at this point.
- This had the side effect that if source was undef, TARG was now
- an undefined SV with PADTMP set, and they don't warn inside
- sv_2pv_flags(). However, we're now getting the PV direct from
- source, which doesn't have PADTMP set, so it would warn. Hence the
- little games. */
-
- if (SvOK(source)) {
- s = (const U8*)SvPV_nomg_const(source, len);
- } else {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(source);
- s = (const U8*)"";
- len = 0;
- }
+ s = (const U8*)SvPV_nomg_const(source, len);
min = len + 1;
SvUPGRADE(dest, SVt_PV);
if (DO_UTF8(source)) {
const U8 *const send = s + len;
U8 tmpbuf[UTF8_MAXBYTES_CASE+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 = _to_utf8_upper_flags(s, tmpbuf, &ulen,
- cBOOL(IN_LOCALE_RUNTIME), &tainted);
+#ifdef USE_LOCALE_CTYPE
+ uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
+#else
+ uv = _to_utf8_upper_flags(s, tmpbuf, &ulen, 0);
+#endif
#define GREEK_CAPITAL_LETTER_IOTA 0x0399
#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
if (uv == GREEK_CAPITAL_LETTER_IOTA
*d = '\0';
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
- if (tainted) {
- TAINT;
- SvTAINTED_on(dest);
- }
}
else { /* Not UTF-8 */
if (len) {
/* Use locale casing if in locale; regular style if not treating
* latin1 as having case; otherwise the latin1 casing. Do the
* whole thing in a tight loop, for speed, */
- if (IN_LOCALE_RUNTIME) {
- TAINT;
- SvTAINTED_on(dest);
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
+ if (IN_UTF8_CTYPE_LOCALE) {
+ goto do_uni_rules;
+ }
for (; s < send; d++, s++)
- *d = toUPPER_LC(*s);
+ *d = (U8) toUPPER_LC(*s);
}
- else if (! IN_UNI_8_BIT) {
+ else
+#endif
+ if (! IN_UNI_8_BIT) {
for (; s < send; d++, s++) {
*d = toUPPER(*s);
}
}
else {
+#ifdef USE_LOCALE_CTYPE
+ do_uni_rules:
+#endif
for (; s < send; d++, s++) {
*d = toUPPER_LATIN1_MOD(*s);
if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
}
} /* End of isn't utf8 */
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
+#endif
if (dest != source && SvTAINTED(source))
SvTAINT(dest);
SvSETMAGIC(dest);
SvGETMAGIC(source);
- if (SvPADTMP(source) && !SvREADONLY(source) && !SvAMAGIC(source)
- && SvTEMP(source) && !DO_UTF8(source)) {
+ if ( ( SvPADTMP(source)
+ || ( SvTEMP(source) && !SvSMAGICAL(source)
+ && SvREFCNT(source) == 1 )
+ )
+ && !SvREADONLY(source) && SvPOK(source)
+ && !DO_UTF8(source)) {
/* We can convert in place, as lowercasing anything in the latin1 range
* (or else DO_UTF8 would have been on) doesn't lengthen it */
dest = TARG;
- /* The old implementation would copy source into TARG at this point.
- This had the side effect that if source was undef, TARG was now
- an undefined SV with PADTMP set, and they don't warn inside
- sv_2pv_flags(). However, we're now getting the PV direct from
- source, which doesn't have PADTMP set, so it would warn. Hence the
- little games. */
-
- if (SvOK(source)) {
- s = (const U8*)SvPV_nomg_const(source, len);
- } else {
- if (ckWARN(WARN_UNINITIALIZED))
- report_uninit(source);
- s = (const U8*)"";
- len = 0;
- }
+ s = (const U8*)SvPV_nomg_const(source, len);
min = len + 1;
SvUPGRADE(dest, SVt_PV);
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;
- _to_utf8_lower_flags(s, tmpbuf, &ulen,
- cBOOL(IN_LOCALE_RUNTIME), &tainted);
+#ifdef USE_LOCALE_CTYPE
+ _to_utf8_lower_flags(s, tmpbuf, &ulen, IN_LC_RUNTIME(LC_CTYPE));
+#else
+ _to_utf8_lower_flags(s, tmpbuf, &ulen, 0);
+#endif
/* Here is where we would do context-sensitive actions. See the
- * commit message for this comment for why there isn't any */
+ * commit message for 86510fb15 for why there isn't any */
if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
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;
/* Use locale casing if in locale; regular style if not treating
* latin1 as having case; otherwise the latin1 casing. Do the
* whole thing in a tight loop, for speed, */
- if (IN_LOCALE_RUNTIME) {
- TAINT;
- SvTAINTED_on(dest);
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
for (; s < send; d++, s++)
*d = toLOWER_LC(*s);
- }
- else if (! IN_UNI_8_BIT) {
+ }
+ else
+#endif
+ if (! IN_UNI_8_BIT) {
for (; s < send; d++, s++) {
*d = toLOWER(*s);
}
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
}
}
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
+#endif
if (dest != source && SvTAINTED(source))
SvTAINT(dest);
SvSETMAGIC(dest);
}
}
else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
-
+#ifdef USE_LOCALE_CTYPE
/* 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))))
+ if (IN_LC_RUNTIME(LC_CTYPE)
+ || _isQUOTEMETA(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s + 1))))
{
to_quote = TRUE;
}
+#endif
}
else if (is_QUOTEMETA_high(s)) {
to_quote = TRUE;
const U8 *send;
U8 *d;
U8 tmpbuf[UTF8_MAXBYTES_CASE + 1];
- const bool full_folding = TRUE;
+ const bool full_folding = TRUE; /* This variable is here so we can easily
+ move to more generality later */
const U8 flags = ( full_folding ? FOLD_FLAGS_FULL : 0 )
- | ( IN_LOCALE_RUNTIME ? FOLD_FLAGS_LOCALE : 0 );
+#ifdef USE_LOCALE_CTYPE
+ | ( IN_LC_RUNTIME(LC_CTYPE) ? FOLD_FLAGS_LOCALE : 0 )
+#endif
+ ;
/* This is a facsimile of pp_lc, but with a thousand bugs thanks to me.
* You are welcome(?) -Hugmeir
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);
+ _to_utf8_fold_flags(s, tmpbuf, &ulen, flags);
if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
const UV o = d - (U8*)SvPVX_const(dest);
s += u;
}
SvUTF8_on(dest);
- if (tainted) {
- TAINT;
- SvTAINTED_on(dest);
- }
} /* Unflagged string */
else if (len) {
- if ( IN_LOCALE_RUNTIME ) { /* Under locale */
- TAINT;
- SvTAINTED_on(dest);
+#ifdef USE_LOCALE_CTYPE
+ if ( IN_LC_RUNTIME(LC_CTYPE) ) { /* Under locale */
+ if (IN_UTF8_CTYPE_LOCALE) {
+ goto do_uni_folding;
+ }
for (; s < send; d++, s++)
- *d = toFOLD_LC(*s);
+ *d = (U8) toFOLD_LC(*s);
}
- else if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
+ else
+#endif
+ if ( !IN_UNI_8_BIT ) { /* Under nothing, or bytes */
for (; s < send; d++, s++)
*d = toFOLD(*s);
}
else {
+#ifdef USE_LOCALE_CTYPE
+ do_uni_folding:
+#endif
/* 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
for (; s < send; s++) {
STRLEN ulen;
UV fc = _to_uni_fold_flags(*s, tmpbuf, &ulen, flags);
- if UNI_IS_INVARIANT(fc) {
+ if UVCHR_IS_INVARIANT(fc) {
if (full_folding
&& *s == LATIN_SMALL_LETTER_SHARP_S)
{
*d = '\0';
SvCUR_set(dest, d - (U8*)SvPVX_const(dest));
+#ifdef USE_LOCALE_CTYPE
+ if (IN_LC_RUNTIME(LC_CTYPE)) {
+ TAINT;
+ SvTAINTED_on(dest);
+ }
+#endif
if (SvTAINTED(source))
SvTAINT(dest);
SvSETMAGIC(dest);
if (lval && localizing) {
SV **svp;
- I32 max = -1;
+ SSize_t max = -1;
for (svp = MARK + 1; svp <= SP; svp++) {
- const I32 elem = SvIV(*svp);
+ const SSize_t elem = SvIV(*svp);
if (elem > max)
max = elem;
}
while (++MARK <= SP) {
SV **svp;
- I32 elem = SvIV(*MARK);
+ SSize_t elem = SvIV(*MARK);
bool preeminent = TRUE;
if (localizing && can_preserve) {
svp = av_fetch(av, elem, lval);
if (lval) {
- if (!svp || *svp == &PL_sv_undef)
+ if (!svp || !*svp)
DIE(aTHX_ PL_no_aelem, elem);
if (localizing) {
if (preeminent)
RETURN;
}
+PP(pp_kvaslice)
+{
+ dVAR; dSP; dMARK;
+ AV *const av = MUTABLE_AV(POPs);
+ I32 lval = (PL_op->op_flags & OPf_MOD);
+ SSize_t items = SP - MARK;
+
+ if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags) {
+ if (!(flags & OPpENTERSUB_INARGS))
+ /* diag_listed_as: Can't modify %s in %s */
+ Perl_croak(aTHX_ "Can't modify index/value array slice in list assignment");
+ lval = flags;
+ }
+ }
+
+ MEXTEND(SP,items);
+ while (items > 1) {
+ *(MARK+items*2-1) = *(MARK+items);
+ items--;
+ }
+ items = SP-MARK;
+ SP += items;
+
+ while (++MARK <= SP) {
+ SV **svp;
+
+ svp = av_fetch(av, SvIV(*MARK), lval);
+ if (lval) {
+ if (!svp || !*svp || *svp == &PL_sv_undef) {
+ DIE(aTHX_ PL_no_aelem, SvIV(*MARK));
+ }
+ *MARK = sv_mortalcopy(*MARK);
+ }
+ *++MARK = svp ? *svp : &PL_sv_undef;
+ }
+ if (GIMME != G_ARRAY) {
+ MARK = SP - items*2;
+ *++MARK = items > 0 ? *SP : &PL_sv_undef;
+ SP = MARK;
+ }
+ RETURN;
+}
+
/* Smart dereferencing for keys, values and each */
PP(pp_rkeys)
{
IV *iterp = Perl_av_iter_p(aTHX_ array);
const IV current = (*iterp)++;
- if (current > av_len(array)) {
+ if (current > av_tindex(array)) {
*iterp = 0;
if (gimme == G_SCALAR)
RETPUSHUNDEF;
if (gimme == G_SCALAR) {
dTARGET;
- PUSHi(av_len(array) + 1);
+ PUSHi(av_tindex(array) + 1);
}
else if (gimme == G_ARRAY) {
IV n = Perl_av_len(aTHX_ array);
const MAGIC *mg;
HV *stash;
const bool sliced = !!(PL_op->op_private & OPpSLICE);
- SV *unsliced_keysv = sliced ? NULL : POPs;
+ SV **unsliced_keysv = sliced ? NULL : sp--;
SV * const osv = POPs;
- SV **mark = sliced ? PL_stack_base + POPMARK : &unsliced_keysv-1;
+ SV **mark = sliced ? PL_stack_base + POPMARK : unsliced_keysv-1;
dORIGMARK;
const bool tied = SvRMAGICAL(osv)
&& mg_find((const SV *)osv, PERL_MAGIC_tied);
const bool can_preserve = SvCANEXISTDELETE(osv);
const U32 type = SvTYPE(osv);
- SV ** const end = sliced ? SP : &unsliced_keysv;
+ SV ** const end = sliced ? SP : unsliced_keysv;
if (type == SVt_PVHV) { /* hash element */
HV * const hv = MUTABLE_HV(osv);
if (PL_op->op_flags & OPf_SPECIAL) {
AV * const av = MUTABLE_AV(osv);
while (++MARK <= end) {
- I32 idx = SvIV(*MARK);
+ SSize_t idx = SvIV(*MARK);
SV *sv = NULL;
bool preeminent = TRUE;
if (can_preserve)
}
}
else if (gimme != G_VOID)
- PUSHs(unsliced_keysv);
+ PUSHs(*unsliced_keysv);
RETURN;
}
SV *tmpsv;
HV *hv;
- if (PL_op->op_private & OPpEXISTS_SUB) {
+ if (UNLIKELY( PL_op->op_private & OPpEXISTS_SUB )) {
GV *gv;
SV * const sv = POPs;
CV * const cv = sv_2cv(sv, &hv, &gv, 0);
}
tmpsv = POPs;
hv = MUTABLE_HV(POPs);
- if (SvTYPE(hv) == SVt_PVHV) {
+ if (LIKELY( SvTYPE(hv) == SVt_PVHV )) {
if (hv_exists_ent(hv, tmpsv, 0))
RETPUSHYES;
}
RETURN;
}
+PP(pp_kvhslice)
+{
+ dVAR; dSP; dMARK;
+ HV * const hv = MUTABLE_HV(POPs);
+ I32 lval = (PL_op->op_flags & OPf_MOD);
+ SSize_t items = SP - MARK;
+
+ if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags) {
+ if (!(flags & OPpENTERSUB_INARGS))
+ /* diag_listed_as: Can't modify %s in %s */
+ Perl_croak(aTHX_ "Can't modify key/value hash slice in list assignment");
+ lval = flags;
+ }
+ }
+
+ MEXTEND(SP,items);
+ while (items > 1) {
+ *(MARK+items*2-1) = *(MARK+items);
+ items--;
+ }
+ items = SP-MARK;
+ SP += items;
+
+ while (++MARK <= SP) {
+ SV * const keysv = *MARK;
+ SV **svp;
+ HE *he;
+
+ he = hv_fetch_ent(hv, keysv, lval, 0);
+ svp = he ? &HeVAL(he) : NULL;
+
+ if (lval) {
+ if (!svp || !*svp || *svp == &PL_sv_undef) {
+ DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
+ }
+ *MARK = sv_mortalcopy(*MARK);
+ }
+ *++MARK = svp && *svp ? *svp : &PL_sv_undef;
+ }
+ if (GIMME != G_ARRAY) {
+ MARK = SP - items*2;
+ *++MARK = items > 0 ? *SP : &PL_sv_undef;
+ SP = MARK;
+ }
+ RETURN;
+}
+
/* List operators. */
PP(pp_list)
{
- dVAR; dSP; dMARK;
+ dVAR;
+ I32 markidx = POPMARK;
if (GIMME != G_ARRAY) {
+ SV **mark = PL_stack_base + markidx;
+ dSP;
if (++MARK <= SP)
*MARK = *SP; /* unwanted list, return last item */
else
*MARK = &PL_sv_undef;
SP = MARK;
+ PUTBACK;
}
- RETURN;
+ return NORMAL;
}
PP(pp_lslice)
SV ** const firstlelem = PL_stack_base + POPMARK + 1;
SV ** const firstrelem = lastlelem + 1;
I32 is_something_there = FALSE;
+ const U8 mod = PL_op->op_flags & OPf_MOD;
const I32 max = lastrelem - lastlelem;
SV **lelem;
is_something_there = TRUE;
if (!(*lelem = firstrelem[ix]))
*lelem = &PL_sv_undef;
+ else if (mod && SvPADTMP(*lelem)) {
+ assert(!IS_PADGV(*lelem));
+ *lelem = firstrelem[ix] = sv_mortalcopy(*lelem);
+ }
}
}
if (is_something_there)
PP(pp_anonhash)
{
dVAR; dSP; dMARK; dORIGMARK;
- HV* const hv = (HV *)sv_2mortal((SV *)newHV());
+ HV* const hv = newHV();
+ SV* const retval = sv_2mortal( PL_op->op_flags & OPf_SPECIAL
+ ? newRV_noinc(MUTABLE_SV(hv))
+ : MUTABLE_SV(hv) );
while (MARK < SP) {
SV * const key =
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
- if (PL_op->op_flags & OPf_SPECIAL)
- mXPUSHs(newRV_inc(MUTABLE_SV(hv)));
- else XPUSHs(MUTABLE_SV(hv));
+ XPUSHs(retval);
RETURN;
}
AV *ary = DEREF_PLAIN_ARRAY(MUTABLE_AV(*++MARK));
SV **src;
SV **dst;
- I32 i;
- I32 offset;
- I32 length;
- I32 newlen;
- I32 after;
- I32 diff;
+ SSize_t i;
+ SSize_t offset;
+ SSize_t length;
+ SSize_t newlen;
+ SSize_t after;
+ SSize_t diff;
const MAGIC * const mg = SvTIED_mg((const SV *)ary, PERL_MAGIC_tied);
if (mg) {
MARK = ORIGMARK + 1;
if (GIMME == G_ARRAY) { /* copy return vals to stack */
+ const bool real = cBOOL(AvREAL(ary));
MEXTEND(MARK, length);
- Copy(AvARRAY(ary)+offset, MARK, length, SV*);
- if (AvREAL(ary)) {
+ if (real)
EXTEND_MORTAL(length);
- for (i = length, dst = MARK; i; i--) {
+ for (i = 0, dst = MARK; i < length; i++) {
+ if ((*dst = AvARRAY(ary)[i+offset])) {
+ if (real)
sv_2mortal(*dst); /* free them eventually */
- dst++;
}
+ else
+ *dst = &PL_sv_undef;
+ dst++;
}
MARK += length - 1;
}
}
i = -diff;
while (i)
- dst[--i] = &PL_sv_undef;
+ dst[--i] = NULL;
if (newlen) {
Copy( tmparyval, AvARRAY(ary) + offset, newlen, SV* );
MARK = ORIGMARK + 1;
if (GIMME == G_ARRAY) { /* copy return vals to stack */
if (length) {
- Copy(tmparyval, MARK, length, SV*);
- if (AvREAL(ary)) {
+ const bool real = cBOOL(AvREAL(ary));
+ if (real)
EXTEND_MORTAL(length);
- for (i = length, dst = MARK; i; i--) {
+ for (i = 0, dst = MARK; i < length; i++) {
+ if ((*dst = tmparyval[i])) {
+ if (real)
sv_2mortal(*dst); /* free them eventually */
- dst++;
}
+ else *dst = &PL_sv_undef;
+ dst++;
}
}
MARK += length - 1;
SPAGAIN;
}
else {
- I32 i = 0;
+ SSize_t i = 0;
av_unshift(ary, SP - MARK);
while (MARK < SP) {
SV * const sv = newSVsv(*++MARK);
SP = MARK;
if (SvMAGICAL(av)) {
- I32 i, j;
+ SSize_t i, j;
SV *tmp = sv_newmortal();
/* For SvCANEXISTDELETE */
HV *stash;
const MAGIC *mg;
bool can_preserve = SvCANEXISTDELETE(av);
- for (i = 0, j = av_len(av); i < j; ++i, --j) {
+ for (i = 0, j = av_tindex(av); i < j; ++i, --j) {
SV *begin, *end;
if (can_preserve) {
do_join(TARG, &PL_sv_no, MARK, SP);
else {
sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
- if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
- report_uninit(TARG);
}
up = SvPV_force(TARG, len);
REGEXP *rx;
SV *dstr;
const char *m;
- I32 iters = 0;
+ SSize_t iters = 0;
const STRLEN slen = do_utf8
? utf8_length((U8*)s, (U8*)strend)
: (STRLEN)(strend - s);
- I32 maxiters = slen + 10;
+ SSize_t maxiters = slen + 10;
I32 trailing_empty = 0;
const char *orig;
const I32 origlimit = limit;
else if (do_utf8 == (RX_UTF8(rx) != 0) &&
(RX_EXTFLAGS(rx) & RXf_USE_INTUIT) && !RX_NPARENS(rx)
&& (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
- && !(RX_EXTFLAGS(rx) & RXf_ANCH)) {
+ && !(RX_EXTFLAGS(rx) & RXf_IS_ANCHORED)) {
const int tail = (RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL);
SV * const csv = CALLREG_INTUIT_STRING(rx);
LEAVE_with_name("call_PUSH");
SPAGAIN;
if (gimme == G_ARRAY) {
- I32 i;
+ SSize_t i;
/* EXTEND should not be needed - we just popped them */
EXTEND(SP, iters);
for (i=0; i < iters; i++) {
const bool constr = PL_op->op_private & whicharg;
PUSHs(S_rv2gv(aTHX_
svp && *svp ? *svp : &PL_sv_undef,
- constr, CopHINTS_get(PL_curcop) & HINT_STRICT_REFS,
+ constr, cBOOL(CopHINTS_get(PL_curcop) & HINT_STRICT_REFS),
!constr
));
}
)
)
DIE(aTHX_
- /* diag_listed_as: Type of arg %d to &CORE::%s must be %s*/
"Type of arg %d to &CORE::%s must be %s",
whicharg, PL_op_name[opnum],
wantscalar
https://perl5.git.perl.org / perl5.git / blobdiff