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, "", 0, 0);
+ gv_init(gv, 0, "__ANONIO__", 10, 0);
GvIOp(gv) = MUTABLE_IO(sv);
SvREFCNT_inc_void_NN(sv);
sv = MUTABLE_SV(gv);
(SV *)Perl_die(aTHX_
S_no_symref_sv,
sv,
- (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""),
+ (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""),
"a symbol"
);
if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_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 (PL_op->op_private & HINT_STRICT_REFS) {
if (SvOK(sv))
- Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what);
+ Perl_die(aTHX_ S_no_symref_sv, sv,
+ (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
else
Perl_die(aTHX_ PL_no_usym, what);
}
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
sv = amagic_deref_call(sv, to_sv_amg);
- SPAGAIN;
}
sv = SvRV(sv);
/* (But not in defined().) */
CV *cv = sv_2cv(TOPs, &stash_unused, &gv, flags);
- 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");
- }
- }
+ if (cv) NOOP;
else if ((flags == (GV_ADD|GV_NOEXPAND)) && gv && SvROK(gv)) {
cv = MUTABLE_CV(gv);
}
GV *gv;
SV *ret = &PL_sv_undef;
+ if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs));
if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) {
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)
- DIE(aTHX_ "Can't find an opnumber for \"%s\"", s+6);
- if (code < 0) { /* Overridable. */
+ DIE(aTHX_ "Can't find an opnumber for \"%"SVf"\"",
+ SVfARG(newSVpvn_flags(
+ s+6, SvCUR(TOPs)-6, SvFLAGS(TOPs) & SVf_UTF8
+ )));
+ {
SV * const sv = core_prototype(NULL, s + 6, code, NULL);
if (sv) ret = sv;
}
}
cv = sv_2cv(TOPs, &stash, &gv, 0);
if (cv && SvPOK(cv))
- ret = newSVpvn_flags(SvPVX_const(cv), SvCUR(cv), SVs_TEMP);
+ ret = newSVpvn_flags(
+ CvPROTO(cv), CvPROTOLEN(cv), SVs_TEMP | SvUTF8(cv)
+ );
set:
SETs(ret);
RETURN;
dVAR; dSP;
SV *sv = POPs;
- const char * const elem = SvPV_nolen_const(sv);
+ STRLEN len;
+ const char * const elem = SvPV_const(sv, len);
GV * const gv = MUTABLE_GV(POPs);
SV * tmpRef = NULL;
const char * const second_letter = elem + 1;
switch (*elem) {
case 'A':
- if (strEQ(second_letter, "RRAY"))
+ if (len == 5 && strEQ(second_letter, "RRAY"))
tmpRef = MUTABLE_SV(GvAV(gv));
break;
case 'C':
- if (strEQ(second_letter, "ODE"))
+ if (len == 4 && strEQ(second_letter, "ODE"))
tmpRef = MUTABLE_SV(GvCVu(gv));
break;
case 'F':
- if (strEQ(second_letter, "ILEHANDLE")) {
+ if (len == 10 && strEQ(second_letter, "ILEHANDLE")) {
/* finally deprecated in 5.8.0 */
deprecate("*glob{FILEHANDLE}");
tmpRef = MUTABLE_SV(GvIOp(gv));
}
else
- if (strEQ(second_letter, "ORMAT"))
+ if (len == 6 && strEQ(second_letter, "ORMAT"))
tmpRef = MUTABLE_SV(GvFORM(gv));
break;
case 'G':
- if (strEQ(second_letter, "LOB"))
+ if (len == 4 && strEQ(second_letter, "LOB"))
tmpRef = MUTABLE_SV(gv);
break;
case 'H':
- if (strEQ(second_letter, "ASH"))
+ if (len == 4 && strEQ(second_letter, "ASH"))
tmpRef = MUTABLE_SV(GvHV(gv));
break;
case 'I':
- if (*second_letter == 'O' && !elem[2])
+ if (*second_letter == 'O' && !elem[2] && len == 2)
tmpRef = MUTABLE_SV(GvIOp(gv));
break;
case 'N':
- if (strEQ(second_letter, "AME"))
+ if (len == 4 && strEQ(second_letter, "AME"))
sv = newSVhek(GvNAME_HEK(gv));
break;
case 'P':
- if (strEQ(second_letter, "ACKAGE")) {
+ if (len == 7 && strEQ(second_letter, "ACKAGE")) {
const HV * const stash = GvSTASH(gv);
const HEK * const hek = stash ? HvNAME_HEK(stash) : NULL;
sv = hek ? newSVhek(hek) : newSVpvs("__ANON__");
}
break;
case 'S':
- if (strEQ(second_letter, "CALAR"))
+ if (len == 6 && strEQ(second_letter, "CALAR"))
tmpRef = GvSVn(gv);
break;
}
{
dVAR; dSP; dPOPss;
register unsigned char *s;
- char *sfirst_raw;
STRLEN len;
- MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_study) : NULL;
- U8 quanta;
- STRLEN size;
-
- if (mg && SvSCREAM(sv))
- RETPUSHYES;
s = (unsigned char*)(SvPV(sv, len));
if (len == 0 || len > I32_MAX || !SvPOK(sv) || SvUTF8(sv) || SvVALID(sv)) {
- /* No point in studying a zero length string, and not safe to study
- anything that doesn't appear to be a simple scalar (and hence might
- change between now and when the regexp engine runs without our set
- magic ever running) such as a reference to an object with overloaded
- stringification. Also refuse to study an FBM scalar, as this gives
- more flexibility in SV flag usage. No real-world code would ever
- end up studying an FBM scalar, so this isn't a real pessimisation.
- Endemic use of I32 in Perl_screaminstr makes it hard to safely push
- the study length limit from I32_MAX to U32_MAX - 1.
- */
+ /* Historically, study was skipped in these cases. */
RETPUSHNO;
}
- if (len < 0xFF) {
- quanta = 1;
- } else if (len < 0xFFFF) {
- quanta = 2;
- } else
- quanta = 4;
-
- size = (256 + len) * quanta;
- sfirst_raw = (char *)safemalloc(size);
-
- if (!sfirst_raw)
- DIE(aTHX_ "do_study: out of memory");
-
- SvSCREAM_on(sv);
- if (!mg)
- mg = sv_magicext(sv, NULL, PERL_MAGIC_study, &PL_vtbl_regexp, NULL, 0);
- mg->mg_ptr = sfirst_raw;
- mg->mg_len = size;
- mg->mg_private = quanta;
-
- memset(sfirst_raw, ~0, 256 * quanta);
-
- /* The assumption here is that most studied strings are fairly short, hence
- the pain of the extra code is worth it, given the memory savings.
- 80 character string, 336 bytes as U8, down from 1344 as U32
- 800 character string, 2112 bytes as U16, down from 4224 as U32
- */
-
- if (quanta == 1) {
- U8 *const sfirst = (U8 *)sfirst_raw;
- U8 *const snext = sfirst + 256;
- while (len-- > 0) {
- const U8 ch = s[len];
- snext[len] = sfirst[ch];
- sfirst[ch] = len;
- }
- } else if (quanta == 2) {
- U16 *const sfirst = (U16 *)sfirst_raw;
- U16 *const snext = sfirst + 256;
- while (len-- > 0) {
- const U8 ch = s[len];
- snext[len] = sfirst[ch];
- sfirst[ch] = len;
- }
- } else {
- U32 *const sfirst = (U32 *)sfirst_raw;
- U32 *const snext = sfirst + 256;
- while (len-- > 0) {
- const U8 ch = s[len];
- snext[len] = sfirst[ch];
- sfirst[ch] = len;
- }
- }
-
+ /* Make study a no-op. It's no longer useful and its existence
+ complicates matters elsewhere. */
RETPUSHYES;
}
}
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);
break;
case SVt_PVCV:
if (cv_const_sv((const CV *)sv))
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Constant subroutine %s undefined",
- CvANON((const CV *)sv) ? "(anonymous)"
- : GvENAME(CvGV((const CV *)sv)));
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Constant subroutine %"SVf" undefined",
+ SVfARG(CvANON((const CV *)sv)
+ ? newSVpvs_flags("(anonymous)", SVs_TEMP)
+ : sv_2mortal(newSVhek(GvENAME_HEK(CvGV((const CV *)sv))))));
/* FALLTHROUGH */
case SVt_PVFM:
{
/* For integer to integer power, we do the calculation by hand wherever
we're sure it is safe; otherwise we call pow() and try to convert to
integer afterwards. */
- {
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
UV power;
bool baseuok;
UV baseuv;
RETURN;
}
}
- }
- }
}
float_it:
#endif
svr = TOPs;
svl = TOPm1s;
#ifdef PERL_PRESERVE_IVUV
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
+ if (SvIV_please_nomg(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
/* Left operand is defined, so is it IV? */
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svl)) {
bool auvok = SvUOK(svl);
bool buvok = SvUOK(svr);
const UV topmask = (~ (UV)0) << (4 * sizeof (UV));
#endif
#ifdef PERL_TRY_UV_DIVIDE
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) {
bool left_non_neg = SvUOK(svl);
bool right_non_neg = SvUOK(svr);
UV left;
RETURN;
} /* tried integer divide but it was not an integer result */
} /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */
- } /* left wasn't SvIOK */
- } /* right wasn't SvIOK */
+ } /* one operand wasn't SvIOK */
#endif /* PERL_TRY_UV_DIVIDE */
{
NV right = SvNV_nomg(svr);
NV dleft = 0.0;
SV * const svr = TOPs;
SV * const svl = TOPm1s;
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
+ if (SvIV_please_nomg(svr)) {
right_neg = !SvUOK(svr);
if (!right_neg) {
right = SvUVX(svr);
/* At this point use_double is only true if right is out of range for
a UV. In range NV has been rounded down to nearest UV and
use_double false. */
- SvIV_please_nomg(svl);
- if (!use_double && SvIOK(svl)) {
- if (SvIOK(svl)) {
+ if (!use_double && SvIV_please_nomg(svl)) {
left_neg = !SvUOK(svl);
if (!left_neg) {
left = SvUVX(svl);
left = -aiv;
}
}
- }
}
else {
dleft = SvNV_nomg(svl);
#ifdef PERL_PRESERVE_IVUV
/* See comments in pp_add (in pp_hot.c) about Overflow, and how
"bad things" happen if you rely on signed integers wrapping. */
- SvIV_please_nomg(svr);
- if (SvIOK(svr)) {
+ if (SvIV_please_nomg(svr)) {
/* Unless the left argument is integer in range we are going to have to
use NV maths. Hence only attempt to coerce the right argument if
we know the left is integer. */
/* left operand is undef, treat as zero. */
} else {
/* Left operand is defined, so is it IV? */
- SvIV_please_nomg(svl);
- if (SvIOK(svl)) {
+ if (SvIV_please_nomg(svl)) {
if ((auvok = SvUOK(svl)))
auv = SvUVX(svl);
else {
PERL_ARGS_ASSERT_DO_NCMP;
#ifdef PERL_PRESERVE_IVUV
- SvIV_please_nomg(right);
/* Fortunately it seems NaN isn't IOK */
- if (SvIOK(right)) {
- SvIV_please_nomg(left);
- if (SvIOK(left)) {
+ if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
if (!SvUOK(left)) {
const IV leftiv = SvIVX(left);
if (!SvUOK(right)) {
return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
}
}
- /* NOTREACHED */
- }
+ assert(0); /* NOTREACHED */
}
#endif
{
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 {
tryAMAGICun_MG(neg_amg, AMGf_numeric);
{
SV * const sv = TOPs;
- const int flags = SvFLAGS(sv);
- if( !SvNIOK( sv ) && looks_like_number( sv ) ){
- SvIV_please( sv );
- }
-
- if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
- /* It's publicly an integer, or privately an integer-not-float */
+ if (SvIOK(sv) || (SvGMAGICAL(sv) && SvIOKp(sv))) {
+ /* It's publicly an integer */
oops_its_an_int:
if (SvIsUV(sv)) {
if (SvIVX(sv) == IV_MIN) {
}
#endif
}
- if (SvNIOKp(sv))
+ if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv)))
SETn(-SvNV_nomg(sv));
else if (SvPOKp(sv)) {
STRLEN len;
sv_setpvs(TARG, "-");
sv_catsv(TARG, sv);
}
- else if (*s == '+' || *s == '-') {
+ else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) {
sv_setsv_nomg(TARG, sv);
*SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-';
}
- else if (DO_UTF8(sv)) {
- SvIV_please_nomg(sv);
- if (SvIOK(sv))
- goto oops_its_an_int;
- if (SvNOK(sv))
- sv_setnv(TARG, -SvNV_nomg(sv));
- else {
- sv_setpvs(TARG, "-");
- sv_catsv(TARG, sv);
- }
- }
- else {
- SvIV_please_nomg(sv);
- if (SvIOK(sv))
+ else if (SvIV_please_nomg(sv))
goto oops_its_an_int;
+ else
sv_setnv(TARG, -SvNV_nomg(sv));
- }
SETTARG;
}
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;
const char *repl = 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 (!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;
- }
+ if (!translate_substr_offsets(
+ curlen, pos1_iv, pos1_is_uv, len_iv, len_is_uv, &pos, &len
+ )) goto bound_fail;
- SvTAINTED_off(TARG); /* decontaminate */
- SvUTF8_off(TARG); /* decontaminate */
+ byte_len = len;
+ byte_pos = utf8_curlen
+ ? sv_pos_u2b_flags(sv, pos, &byte_len, SV_CONST_RETURN) : pos;
tmps += byte_pos;
- sv_setpvn(TARG, tmps, byte_len);
+
+ if (rvalue) {
+ SvTAINTED_off(TARG); /* decontaminate */
+ SvUTF8_off(TARG); /* decontaminate */
+ sv_setpvn(TARG, tmps, byte_len);
#ifdef USE_LOCALE_COLLATE
- sv_unmagic(TARG, PERL_MAGIC_collxfrm);
+ sv_unmagic(TARG, PERL_MAGIC_collxfrm);
#endif
- if (utf8_curlen)
- SvUTF8_on(TARG);
+ if (utf8_curlen)
+ SvUTF8_on(TARG);
+ }
if (repl) {
SV* repl_sv_copy = NULL;
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);
}
}
SPAGAIN;
- SvSETMAGIC(TARG);
- PUSHs(TARG);
+ if (rvalue) {
+ SvSETMAGIC(TARG);
+ PUSHs(TARG);
+ }
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);
/* Generally UTF-8 and UTF-EBCDIC are indistinguishable at this level. So
* most comments below say UTF-8, when in fact they mean UTF-EBCDIC as well */
-/* Below are several macros that generate code */
/* Generates code to store a unicode codepoint c that is known to occupy
- * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1. */
-#define STORE_UNI_TO_UTF8_TWO_BYTE(p, c) \
- STMT_START { \
- *(p) = UTF8_TWO_BYTE_HI(c); \
- *((p)+1) = UTF8_TWO_BYTE_LO(c); \
- } STMT_END
-
-/* Like STORE_UNI_TO_UTF8_TWO_BYTE, but advances p to point to the next
- * available byte after the two bytes */
+ * exactly two UTF-8 and UTF-EBCDIC bytes; it is stored into p and p+1,
+ * and p is advanced to point to the next available byte after the two bytes */
#define CAT_UNI_TO_UTF8_TWO_BYTE(p, c) \
STMT_START { \
*(p)++ = UTF8_TWO_BYTE_HI(c); \
*((p)++) = UTF8_TWO_BYTE_LO(c); \
} STMT_END
-/* Generates code to store the upper case of latin1 character l which is known
- * to have its upper case be non-latin1 into the two bytes p and p+1. There
- * are only two characters that fit this description, and this macro knows
- * about them, and that the upper case values fit into two UTF-8 or UTF-EBCDIC
- * bytes */
-#define STORE_NON_LATIN1_UC(p, l) \
-STMT_START { \
- if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
- STORE_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
- } else { /* Must be the following letter */ \
- STORE_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
- } \
-} STMT_END
-
-/* Like STORE_NON_LATIN1_UC, but advances p to point to the next available byte
- * after the character stored */
-#define CAT_NON_LATIN1_UC(p, l) \
-STMT_START { \
- if ((l) == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
- CAT_UNI_TO_UTF8_TWO_BYTE((p), LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS); \
- } else { \
- CAT_UNI_TO_UTF8_TWO_BYTE((p), GREEK_CAPITAL_LETTER_MU); \
- } \
-} STMT_END
-
-/* Generates code to add the two UTF-8 bytes (probably u) that are the upper
- * case of l into p and p+1. u must be the result of toUPPER_LATIN1_MOD(l),
- * and must require two bytes to store it. Advances p to point to the next
- * available position */
-#define CAT_TWO_BYTE_UNI_UPPER_MOD(p, l, u) \
-STMT_START { \
- if ((u) != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) { \
- CAT_UNI_TO_UTF8_TWO_BYTE((p), (u)); /* not special, just save it */ \
- } else if (l == LATIN_SMALL_LETTER_SHARP_S) { \
- *(p)++ = 'S'; *(p)++ = 'S'; /* upper case is 'SS' */ \
- } else {/* else is one of the other two special cases */ \
- CAT_NON_LATIN1_UC((p), (l)); \
- } \
-} STMT_END
-
PP(pp_ucfirst)
{
/* Actually is both lcfirst() and ucfirst(). Only the first character
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)) {
if (! slen) { /* If empty */
need = 1; /* still need a trailing NUL */
+ ulen = 0;
}
else if (DO_UTF8(source)) { /* Is the source utf8? */
doing_utf8 = TRUE;
-
- if (UTF8_IS_INVARIANT(*s)) {
-
- /* An invariant source character is either ASCII or, in EBCDIC, an
- * ASCII equivalent or a caseless C1 control. In both these cases,
- * the lower and upper cases of any character are also invariants
- * (and title case is the same as upper case). So it is safe to
- * use the simple case change macros which avoid the overhead of
- * the general functions. Note that if perl were to be extended to
- * do locale handling in UTF-8 strings, this wouldn't be true in,
- * for example, Lithuanian or Turkic. */
- *tmpbuf = (op_type == OP_LCFIRST) ? toLOWER(*s) : toUPPER(*s);
- tculen = ulen = 1;
- need = slen + 1;
- }
- else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
- U8 chr;
-
- /* Similarly, if the source character isn't invariant but is in the
- * latin1 range (or EBCDIC equivalent thereof), we have the case
- * changes compiled into perl, and can avoid the overhead of the
- * general functions. In this range, the characters are stored as
- * two UTF-8 bytes, and it so happens that any changed-case version
- * is also two bytes (in both ASCIIish and EBCDIC machines). */
- tculen = ulen = 2;
- need = slen + 1;
-
- /* Convert the two source bytes to a single Unicode code point
- * value, change case and save for below */
- chr = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
- if (op_type == OP_LCFIRST) { /* lower casing is easy */
- U8 lower = toLOWER_LATIN1(chr);
- STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, lower);
- }
- else { /* ucfirst */
- U8 upper = toUPPER_LATIN1_MOD(chr);
-
- /* Most of the latin1 range characters are well-behaved. Their
- * title and upper cases are the same, and are also in the
- * latin1 range. The macro above returns their upper (hence
- * title) case, and all that need be done is to save the result
- * for below. However, several characters are problematic, and
- * have to be handled specially. The MOD in the macro name
- * above means that these tricky characters all get mapped to
- * the single character LATIN_SMALL_LETTER_Y_WITH_DIAERESIS.
- * This mapping saves some tests for the majority of the
- * characters */
-
- if (upper != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
-
- /* Not tricky. Just save it. */
- STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf, upper);
- }
- else if (chr == LATIN_SMALL_LETTER_SHARP_S) {
-
- /* This one is tricky because it is two characters long,
- * though the UTF-8 is still two bytes, so the stored
- * length doesn't change */
- *tmpbuf = 'S'; /* The UTF-8 is 'Ss' */
- *(tmpbuf + 1) = 's';
- }
- else {
-
- /* The other two have their title and upper cases the same,
- * but are tricky because the changed-case characters
- * aren't in the latin1 range. They, however, do fit into
- * two UTF-8 bytes */
- STORE_NON_LATIN1_UC(tmpbuf, chr);
- }
- }
+ ulen = UTF8SKIP(s);
+ if (op_type == OP_UCFIRST) {
+ _to_utf8_title_flags(s, tmpbuf, &tculen,
+ cBOOL(IN_LOCALE_RUNTIME), &tainted);
}
- else {
-
- /* Here, can't short-cut the general case */
-
- utf8_to_uvchr(s, &ulen);
- if (op_type == OP_UCFIRST) toTITLE_utf8(s, tmpbuf, &tculen);
- else toLOWER_utf8(s, tmpbuf, &tculen);
-
- /* we can't do in-place if the length changes. */
- if (ulen != tculen) inplace = FALSE;
- need = slen + 1 - ulen + tculen;
+ 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;
+ need = slen + 1 - ulen + tculen;
}
else { /* Non-zero length, non-UTF-8, Need to consider locale and if
* latin1 is treated as caseless. Note that a locale takes
* precedence */
+ ulen = 1; /* Original character is 1 byte */
tculen = 1; /* Most characters will require one byte, but this will
* need to be overridden for the tricky ones */
need = slen + 1;
* native function does */
}
else { /* is ucfirst non-UTF-8, not in locale, and cased latin1 */
- *tmpbuf = toUPPER_LATIN1_MOD(*s);
-
- /* tmpbuf now has the correct title case for all latin1 characters
- * except for the several ones that have tricky handling. All
- * of these are mapped by the MOD to the letter below. */
- if (*tmpbuf == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) {
-
- /* The length is going to change, with all three of these, so
- * can't replace just the first character */
- inplace = FALSE;
-
- /* We use the original to distinguish between these tricky
- * cases */
- if (*s == LATIN_SMALL_LETTER_SHARP_S) {
- /* Two character title case 'Ss', but can remain non-UTF-8 */
- need = slen + 2;
- *tmpbuf = 'S';
- *(tmpbuf + 1) = 's'; /* Assert: length(tmpbuf) >= 2 */
- tculen = 2;
+ UV title_ord = _to_upper_title_latin1(*s, tmpbuf, &tculen, 's');
+ if (tculen > 1) {
+ assert(tculen == 2);
+
+ /* If the result is an upper Latin1-range character, it can
+ * still be represented in one byte, which is its ordinal */
+ if (UTF8_IS_DOWNGRADEABLE_START(*tmpbuf)) {
+ *tmpbuf = (U8) title_ord;
+ tculen = 1;
}
else {
-
- /* The other two tricky ones have their title case outside
- * latin1. It is the same as their upper case. */
- doing_utf8 = TRUE;
- STORE_NON_LATIN1_UC(tmpbuf, *s);
-
- /* The UTF-8 and UTF-EBCDIC lengths of both these characters
- * and their upper cases is 2. */
- tculen = ulen = 2;
-
- /* The entire result will have to be in UTF-8. Assume worst
- * case sizing in conversion. (all latin1 characters occupy
- * at most two bytes in utf8) */
- convert_source_to_utf8 = TRUE;
- need = slen * 2 + 1;
+ /* Otherwise it became more than one ASCII character (in
+ * the case of LATIN_SMALL_LETTER_SHARP_S) or changed to
+ * beyond Latin1, so the number of bytes changed, so can't
+ * replace just the first character in place. */
+ inplace = FALSE;
+
+ /* If the result won't fit in a byte, the entire result will
+ * have to be in UTF-8. Assume worst case sizing in
+ * conversion. (all latin1 characters occupy at most two bytes
+ * in utf8) */
+ if (title_ord > 255) {
+ doing_utf8 = TRUE;
+ convert_source_to_utf8 = TRUE;
+ need = slen * 2 + 1;
+
+ /* The (converted) UTF-8 and UTF-EBCDIC lengths of all
+ * (both) characters whose title case is above 255 is
+ * 2. */
+ ulen = 2;
+ }
+ else { /* LATIN_SMALL_LETTER_SHARP_S expands by 1 byte */
+ need = slen + 1 + 1;
+ }
}
- } /* End of is one of the three special chars */
+ }
} /* End of use Unicode (Latin1) semantics */
} /* End of changing the case of the first character */
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
bool in_iota_subscript = FALSE;
while (s < send) {
+ STRLEN u;
+ STRLEN ulen;
+ UV uv;
if (in_iota_subscript && ! is_utf8_mark(s)) {
+
/* A non-mark. Time to output the iota subscript */
#define GREEK_CAPITAL_LETTER_IOTA 0x0399
#define COMBINING_GREEK_YPOGEGRAMMENI 0x0345
CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
in_iota_subscript = FALSE;
- }
-
- /* If the UTF-8 character is invariant, then it is in the range
- * known by the standard macro; result is only one byte long */
- if (UTF8_IS_INVARIANT(*s)) {
- *d++ = toUPPER(*s);
- s++;
- }
- else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
-
- /* Likewise, if it fits in a byte, its case change is in our
- * table */
- U8 orig = TWO_BYTE_UTF8_TO_UNI(*s, *(s+1));
- U8 upper = toUPPER_LATIN1_MOD(orig);
- CAT_TWO_BYTE_UNI_UPPER_MOD(d, orig, upper);
- s += 2;
- }
- else {
-
- /* Otherwise, need the general UTF-8 case. Get the changed
- * case value and copy it to the output buffer */
+ }
- const STRLEN u = UTF8SKIP(s);
- STRLEN ulen;
+ /* Then handle the current character. Get the changed case value
+ * and copy it to the output buffer */
- const UV uv = toUPPER_utf8(s, tmpbuf, &ulen);
- if (uv == GREEK_CAPITAL_LETTER_IOTA
- && utf8_to_uvchr(s, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
- {
- in_iota_subscript = TRUE;
- }
- else {
- if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
- /* If the eventually required minimum size outgrows
- * the available space, we need to grow. */
- const UV o = d - (U8*)SvPVX_const(dest);
-
- /* If someone uppercases one million U+03B0s we
- * SvGROW() one million times. Or we could try
- * guessing how much to allocate without allocating too
- * much. Such is life. See corresponding comment in
- * lc code for another option */
- SvGROW(dest, min);
- d = (U8*)SvPVX(dest) + o;
- }
- Copy(tmpbuf, d, ulen, U8);
- d += ulen;
- }
- s += u;
- }
+ u = UTF8SKIP(s);
+ uv = _to_utf8_upper_flags(s, tmpbuf, &ulen,
+ cBOOL(IN_LOCALE_RUNTIME), &tainted);
+ if (uv == GREEK_CAPITAL_LETTER_IOTA
+ && utf8_to_uvchr_buf(s, send, 0) == COMBINING_GREEK_YPOGEGRAMMENI)
+ {
+ in_iota_subscript = TRUE;
+ }
+ else {
+ if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
+ /* If the eventually required minimum size outgrows the
+ * available space, we need to grow. */
+ const UV o = d - (U8*)SvPVX_const(dest);
+
+ /* If someone uppercases one million U+03B0s we SvGROW()
+ * one million times. Or we could try guessing how much to
+ * allocate without allocating too much. Such is life.
+ * See corresponding comment in lc code for another option
+ * */
+ SvGROW(dest, min);
+ d = (U8*)SvPVX(dest) + o;
+ }
+ Copy(tmpbuf, d, ulen, U8);
+ d += ulen;
+ }
+ s += u;
}
if (in_iota_subscript) {
CAT_UNI_TO_UTF8_TWO_BYTE(d, GREEK_CAPITAL_LETTER_IOTA);
}
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) {
else {
for (; s < send; d++, s++) {
*d = toUPPER_LATIN1_MOD(*s);
- if (*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS) continue;
+ if (LIKELY(*d != LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) continue;
/* The mainstream case is the tight loop above. To avoid
* extra tests in that, all three characters that require
(send -s) * 2 + 1);
d = (U8*)SvPVX(dest) + len;
- /* And append the current character's upper case in UTF-8 */
- CAT_NON_LATIN1_UC(d, *s);
-
/* Now process the remainder of the source, converting to
* upper and UTF-8. If a resulting byte is invariant in
* UTF-8, output it as-is, otherwise convert to UTF-8 and
* append it to the output. */
-
- s++;
for (; s < send; s++) {
- U8 upper = toUPPER_LATIN1_MOD(*s);
- if UTF8_IS_INVARIANT(upper) {
- *d++ = upper;
- }
- else {
- CAT_TWO_BYTE_UNI_UPPER_MOD(d, *s, upper);
- }
+ (void) _to_upper_title_latin1(*s, d, &len, 'S');
+ d += len;
}
/* Here have processed the whole source; no need to continue
if (DO_UTF8(source)) {
const U8 *const send = s + len;
U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
+ bool tainted = FALSE;
while (s < send) {
- if (UTF8_IS_INVARIANT(*s)) {
+ const STRLEN u = UTF8SKIP(s);
+ STRLEN ulen;
- /* Invariant characters use the standard mappings compiled in.
- */
- *d++ = toLOWER(*s);
- s++;
- }
- else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
-
- /* As do the ones in the Latin1 range */
- U8 lower = toLOWER_LATIN1(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1)));
- CAT_UNI_TO_UTF8_TWO_BYTE(d, lower);
- s += 2;
- }
- else {
- /* Here, is utf8 not in Latin-1 range, have to go out and get
- * the mappings from the tables. */
+ _to_utf8_lower_flags(s, tmpbuf, &ulen,
+ cBOOL(IN_LOCALE_RUNTIME), &tainted);
- const STRLEN u = UTF8SKIP(s);
- STRLEN ulen;
+ /* Here is where we would do context-sensitive actions. See the
+ * commit message for this comment for why there isn't any */
-#ifndef CONTEXT_DEPENDENT_CASING
- toLOWER_utf8(s, tmpbuf, &ulen);
-#else
-/* This is ifdefd out because it probably is the wrong thing to do. The right
- * thing is probably to have an I/O layer that converts final sigma to regular
- * on input and vice versa (under the correct circumstances) on output. In
- * effect, the final sigma is just a glyph variation when the regular one
- * occurs at the end of a word. And we don't really know what's going to be
- * the end of the word until it is finally output, as splitting and joining can
- * occur at any time and change what once was the word end to be in the middle,
- * and vice versa. */
-
- const UV uv = toLOWER_utf8(s, tmpbuf, &ulen);
-
- /* If the lower case is a small sigma, it may be that we need
- * to change it to a final sigma. This happens at the end of
- * a word that contains more than just this character, and only
- * when we started with a capital sigma. */
- if (uv == UNICODE_GREEK_SMALL_LETTER_SIGMA &&
- s > send - len && /* Makes sure not the first letter */
- utf8_to_uvchr(s, 0) == UNICODE_GREEK_CAPITAL_LETTER_SIGMA
- ) {
-
- /* We use the algorithm in:
- * http://www.unicode.org/versions/Unicode5.0.0/ch03.pdf (C
- * is a CAPITAL SIGMA): If C is preceded by a sequence
- * consisting of a cased letter and a case-ignorable
- * sequence, and C is not followed by a sequence consisting
- * of a case ignorable sequence and then a cased letter,
- * then when lowercasing C, C becomes a final sigma */
-
- /* To determine if this is the end of a word, need to peek
- * ahead. Look at the next character */
- const U8 *peek = s + u;
-
- /* Skip any case ignorable characters */
- while (peek < send && is_utf8_case_ignorable(peek)) {
- peek += UTF8SKIP(peek);
- }
+ if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
- /* If we reached the end of the string without finding any
- * non-case ignorable characters, or if the next such one
- * is not-cased, then we have met the conditions for it
- * being a final sigma with regards to peek ahead, and so
- * must do peek behind for the remaining conditions. (We
- * know there is stuff behind to look at since we tested
- * above that this isn't the first letter) */
- if (peek >= send || ! is_utf8_cased(peek)) {
- peek = utf8_hop(s, -1);
-
- /* Here are at the beginning of the first character
- * before the original upper case sigma. Keep backing
- * up, skipping any case ignorable characters */
- while (is_utf8_case_ignorable(peek)) {
- peek = utf8_hop(peek, -1);
- }
+ /* If the eventually required minimum size outgrows the
+ * available space, we need to grow. */
+ const UV o = d - (U8*)SvPVX_const(dest);
- /* Here peek points to the first byte of the closest
- * non-case-ignorable character before the capital
- * sigma. If it is cased, then by the Unicode
- * algorithm, we should use a small final sigma instead
- * of what we have */
- if (is_utf8_cased(peek)) {
- STORE_UNI_TO_UTF8_TWO_BYTE(tmpbuf,
- UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA);
- }
- }
- }
- else { /* Not a context sensitive mapping */
-#endif /* End of commented out context sensitive */
- if (ulen > u && (SvLEN(dest) < (min += ulen - u))) {
-
- /* If the eventually required minimum size outgrows
- * the available space, we need to grow. */
- const UV o = d - (U8*)SvPVX_const(dest);
-
- /* If someone lowercases one million U+0130s we
- * SvGROW() one million times. Or we could try
- * guessing how much to allocate without allocating too
- * much. Such is life. Another option would be to
- * grow an extra byte or two more each time we need to
- * grow, which would cut down the million to 500K, with
- * little waste */
- SvGROW(dest, min);
- d = (U8*)SvPVX(dest) + o;
- }
-#ifdef CONTEXT_DEPENDENT_CASING
- }
-#endif
- /* Copy the newly lowercased letter to the output buffer we're
- * building */
- Copy(tmpbuf, d, ulen, U8);
- d += ulen;
- s += u;
+ /* If someone lowercases one million U+0130s we SvGROW() one
+ * million times. Or we could try guessing how much to
+ * allocate without allocating too much. Such is life.
+ * Another option would be to grow an extra byte or two more
+ * each time we need to grow, which would cut down the million
+ * to 500K, with little waste */
+ SvGROW(dest, min);
+ d = (U8*)SvPVX(dest) + o;
}
+
+ /* Copy the newly lowercased letter to the output buffer we're
+ * building */
+ Copy(tmpbuf, d, ulen, U8);
+ d += ulen;
+ s += u;
} /* End of looping through the source string */
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)
SV * const osv = POPs;
const bool tied = SvRMAGICAL(osv)
&& mg_find((const SV *)osv, PERL_MAGIC_tied);
- const bool can_preserve = SvCANEXISTDELETE(osv)
- || mg_find((const SV *)osv, PERL_MAGIC_env);
+ const bool can_preserve = SvCANEXISTDELETE(osv);
const U32 type = SvTYPE(osv);
if (type == SVt_PVHV) { /* hash element */
HV * const hv = MUTABLE_HV(osv);
SV * const osv = POPs;
const bool tied = SvRMAGICAL(osv)
&& mg_find((const SV *)osv, PERL_MAGIC_tied);
- const bool can_preserve = SvCANEXISTDELETE(osv)
- || mg_find((const SV *)osv, PERL_MAGIC_env);
+ const bool can_preserve = SvCANEXISTDELETE(osv);
const U32 type = SvTYPE(osv);
SV *sv = NULL;
if (type == SVt_PVHV) {
MAGIC *mg;
HV *stash;
- if (SvCANEXISTDELETE(hv) || mg_find((const SV *)hv, PERL_MAGIC_env))
+ if (SvCANEXISTDELETE(hv))
can_preserve = TRUE;
}
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 &&
I32 rex_return;
PUTBACK;
rex_return = CALLREGEXEC(rx, (char*)s, (char*)strend, (char*)orig, 1 ,
- sv, NULL, SvSCREAM(sv) ? REXEC_SCREAM : 0);
+ sv, NULL, 0);
SPAGAIN;
if (rex_return == 0)
break;
{
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
arguments in list context, in addition to the values we are supposed
to return. nextstate usually does this on sub entry, but we need
- to run the next op with the caller’s hints, so we cannot have a
+ to run the next op with the caller's hints, so we cannot have a
nextstate. */
SP = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
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)
type permits the latter. */
|| SvTYPE(SvRV(*svp)) > (
wantscalar ? SVt_PVLV
- : opnum == OP_LOCK ? SVt_PVCV
+ : opnum == OP_LOCK || opnum == OP_UNDEF
+ ? SVt_PVCV
: SVt_PVHV
)
)
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, OP_DESC(PL_op->op_next),
+ whicharg, PL_op_name[opnum],
wantscalar
? "scalar reference"
- : opnum == OP_LOCK
+ : opnum == OP_LOCK || opnum == OP_UNDEF
? "reference to one of [$@%&*]"
: "reference to one of [$@%*]"
);
PUSHs(SvRV(*svp));
- break;
+ if (opnum == OP_UNDEF && SvRV(*svp) == (SV *)PL_defgv
+ && cxstack[cxstack_ix].cx_type & CXp_HASARGS) {
+ /* Undo @_ localisation, so that sub exit does not undo
+ part of our undeffing. */
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix];
+ POP_SAVEARRAY();
+ cx->cx_type &= ~ CXp_HASARGS;
+ assert(!AvREAL(cx->blk_sub.argarray));
+ }
}
+ 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(CvEVAL(cv) ? &PL_sv_undef : sv_2mortal(newRV((SV *)cv)));
+ RETURN;
+}
+
+
/*
* 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:
*/
https://perl5.git.perl.org / perl5.git / blobdiff