=cut
*/
+static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
+
char *
Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
{
}
else
{
- if (SvIsCOW(sv)) sv_force_normal(sv);
+ if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0);
s = SvPVX_mutable(sv);
}
SvSETMAGIC(sv);
}
-/* Print an "isn't numeric" warning, using a cleaned-up,
- * printable version of the offending string
+/* Return a cleaned-up, printable version of sv, for non-numeric, or
+ * not incrementable warning display.
+ * Originally part of S_not_a_number().
+ * The return value may be != tmpbuf.
*/
-STATIC void
-S_not_a_number(pTHX_ SV *const sv)
-{
- dVAR;
- SV *dsv;
- char tmpbuf[64];
- const char *pv;
+STATIC const char *
+S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
+ const char *pv;
- PERL_ARGS_ASSERT_NOT_A_NUMBER;
+ PERL_ARGS_ASSERT_SV_DISPLAY;
if (DO_UTF8(sv)) {
- dsv = newSVpvs_flags("", SVs_TEMP);
+ SV *dsv = newSVpvs_flags("", SVs_TEMP);
pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
} else {
char *d = tmpbuf;
- const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
+ const char * const limit = tmpbuf + tmpbuf_size - 8;
/* each *s can expand to 4 chars + "...\0",
i.e. need room for 8 chars */
pv = tmpbuf;
}
+ return pv;
+}
+
+/* Print an "isn't numeric" warning, using a cleaned-up,
+ * printable version of the offending string
+ */
+
+STATIC void
+S_not_a_number(pTHX_ SV *const sv)
+{
+ dVAR;
+ char tmpbuf[64];
+ const char *pv;
+
+ PERL_ARGS_ASSERT_NOT_A_NUMBER;
+
+ pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
+
if (PL_op)
Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
/* diag_listed_as: Argument "%s" isn't numeric%s */
"Argument \"%s\" isn't numeric", pv);
}
+STATIC void
+S_not_incrementable(pTHX_ SV *const sv) {
+ dVAR;
+ char tmpbuf[64];
+ const char *pv;
+
+ PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
+
+ pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
+
+ Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+ "Argument \"%s\" treated as 0 in increment (++)", pv);
+}
+
/*
=for apidoc looks_like_number
if (isGV_with_GP(sv))
return glob_2number(MUTABLE_GV(sv));
- if (!SvPADTMP(sv)) {
- if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
+ if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
- }
if (SvTYPE(sv) < SVt_IV)
/* Typically the caller expects that sv_any is not NULL now. */
sv_upgrade(sv, SVt_IV);
return 0.0;
}
- if (!PL_localizing && !SvPADTMP(sv) && ckWARN(WARN_UNINITIALIZED))
+ if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
assert (SvTYPE(sv) >= SVt_NV);
/* Typically the caller expects that sv_any is not NULL now. */
*lp = 0;
if (flags & SV_UNDEF_RETURNS_NULL)
return NULL;
- if (!PL_localizing && !SvPADTMP(sv) && ckWARN(WARN_UNINITIALIZED))
+ if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
/* Typically the caller expects that sv_any is not NULL now. */
if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV)
{
PERL_ARGS_ASSERT_SV_2PVBYTE;
+ SvGETMAGIC(sv);
if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv))
|| isGV_with_GP(sv) || SvROK(sv)) {
SV *sv2 = sv_newmortal();
- sv_copypv(sv2,sv);
+ sv_copypv_nomg(sv2,sv);
sv = sv2;
}
- else SvGETMAGIC(sv);
sv_utf8_downgrade(sv,0);
return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv);
}
}
return SvRV(sv) != 0;
}
+ if (isREGEXP(sv))
+ return
+ RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
}
*/
-static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
-
STRLEN
Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
{
}
while (t < e) {
- const UV uv = NATIVE8_TO_UNI(*t++);
- if (UNI_IS_INVARIANT(uv))
- *d++ = (U8)UNI_TO_NATIVE(uv);
- else {
- *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
- *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
- }
+ append_utf8_from_native_byte(*t, &d);
+ t++;
}
*d = '\0';
SvPV_free(sv); /* No longer using pre-existing string */
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
/* Update pos. We do it at the end rather than during
* the upgrade, to avoid slowing down the common case
- * (upgrade without pos) */
+ * (upgrade without pos).
+ * pos can be stored as either bytes or characters. Since
+ * this was previously a byte string we can just turn off
+ * the bytes flag. */
MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
if (mg) {
- I32 pos = mg->mg_len;
- if (pos > 0 && (U32)pos > invariant_head) {
- U8 *d = (U8*) SvPVX(sv) + invariant_head;
- STRLEN n = (U32)pos - invariant_head;
- while (n > 0) {
- if (UTF8_IS_START(*d))
- d++;
- d++;
- n--;
- }
- mg->mg_len = d - (U8*)SvPVX(sv);
- }
+ mg->mg_flags &= ~MGf_BYTES;
}
if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
magic_setutf8(sv,mg); /* clear UTF8 cache */
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
/* update pos */
MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
- if (mg) {
- I32 pos = mg->mg_len;
- if (pos > 0) {
- sv_pos_b2u(sv, &pos);
+ if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
+ mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
+ SV_GMAGIC|SV_CONST_RETURN);
mg_flags = 0; /* sv_pos_b2u does get magic */
- mg->mg_len = pos;
- }
}
if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
magic_setutf8(sv,mg); /* clear UTF8 cache */
}
}
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC
+ after this, clearing pos. Does anything on CPAN
+ need this? */
/* adjust pos to the start of a UTF8 char sequence */
MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
if (mg) {
d = (U8 *)SvPVX(dsv) + dlen;
while (sstr < send) {
- const UV uv = NATIVE_TO_ASCII((U8)*sstr++);
- if (UNI_IS_INVARIANT(uv))
- *d++ = (U8)UTF_TO_NATIVE(uv);
- else {
- *d++ = (U8)UTF8_EIGHT_BIT_HI(uv);
- *d++ = (U8)UTF8_EIGHT_BIT_LO(uv);
- }
+ append_utf8_from_native_byte(*sstr, &d);
+ sstr++;
}
SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv));
}
#endif
if (SvREADONLY(sv)) {
if (
- IN_PERL_RUNTIME
- && !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
+ !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how)
)
{
Perl_croak_no_modify();
}
}
+ /* Force pos to be stored as characters, not bytes. */
+ if (SvMAGICAL(sv) && DO_UTF8(sv)
+ && (mg = mg_find(sv, PERL_MAGIC_regex_global))
+ && mg->mg_len != -1
+ && mg->mg_flags & MGf_BYTES) {
+ mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
+ SV_CONST_RETURN);
+ mg->mg_flags &= ~MGf_BYTES;
+ }
+
/* Rest of work is done else where */
mg = sv_magicext(sv,obj,how,vtable,name,namlen);
assert(SvTYPE(stash) == SVt_PVHV);
if (HvNAME(stash)) {
CV* destructor = NULL;
+ assert (SvOOK(stash));
if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
- if (!destructor) {
+ if (!destructor || HvMROMETA(stash)->destroy_gen
+ != PL_sub_generation)
+ {
GV * const gv =
gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
if (gv) destructor = GvCV(gv);
if (!SvOBJECT(stash))
+ {
SvSTASH(stash) =
destructor ? (HV *)destructor : ((HV *)0)+1;
+ HvAUX(stash)->xhv_mro_meta->destroy_gen =
+ PL_sub_generation;
+ }
}
assert(!destructor || destructor == ((CV *)0)+1
|| SvTYPE(destructor) == SVt_PVCV);
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvIsCOW(sv) || isGV_with_GP(sv))
- sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
- if (IN_PERL_RUNTIME)
Perl_croak_no_modify();
}
if (SvROK(sv)) {
sv_unref(sv);
sv_setiv(sv, i);
}
+ else sv_force_normal_flags(sv, 0);
}
flags = SvFLAGS(sv);
if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
while (isALPHA(*d)) d++;
while (isDIGIT(*d)) d++;
if (d < SvEND(sv)) {
+ const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
#ifdef PERL_PRESERVE_IVUV
/* Got to punt this as an integer if needs be, but we don't issue
warnings. Probably ought to make the sv_iv_please() that does
the conversion if possible, and silently. */
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
/* Need to try really hard to see if it's an integer.
9.22337203685478e+18 is an integer.
#endif
}
#endif /* PERL_PRESERVE_IVUV */
+ if (!numtype && ckWARN(WARN_NUMERIC))
+ not_incrementable(sv);
sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
return;
}
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvIsCOW(sv) || isGV_with_GP(sv))
- sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
- if (IN_PERL_RUNTIME)
Perl_croak_no_modify();
}
if (SvROK(sv)) {
sv_unref(sv);
sv_setiv(sv, i);
}
+ else sv_force_normal_flags(sv, 0);
}
/* Unlike sv_inc we don't have to worry about string-never-numbers
and keeping them magic. But we mustn't warn on punting */
continue;
gv = MUTABLE_GV(HeVAL(entry));
sv = GvSV(gv);
- if (sv) {
- if (SvTHINKFIRST(sv)) {
- if (!SvREADONLY(sv) && SvROK(sv))
- sv_unref(sv);
- /* XXX Is this continue a bug? Why should THINKFIRST
- exempt us from resetting arrays and hashes? */
- continue;
- }
- SvOK_off(sv);
- if (SvTYPE(sv) >= SVt_PV) {
- SvCUR_set(sv, 0);
- if (SvPVX_const(sv) != NULL)
- *SvPVX(sv) = '\0';
- SvTAINT(sv);
- }
+ if (sv && !SvREADONLY(sv)) {
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
+ if (!isGV(sv)) SvOK_off(sv);
}
if (GvAV(gv)) {
av_clear(GvAV(gv));
}
if (GvHV(gv) && !HvNAME_get(GvHV(gv))) {
-#if defined(VMS)
- Perl_die(aTHX_ "Can't reset %%ENV on this system");
-#else /* ! VMS */
hv_clear(GvHV(gv));
-# if defined(USE_ENVIRON_ARRAY)
- if (gv == PL_envgv)
- my_clearenv();
-# endif /* USE_ENVIRON_ARRAY */
-#endif /* VMS */
}
}
}
PERL_ARGS_ASSERT_SV_BLESS;
+ SvGETMAGIC(sv);
if (!SvROK(sv))
Perl_croak(aTHX_ "Can't bless non-reference value");
tmpRef = SvRV(sv);
if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
- if (SvREADONLY(tmpRef) && !SvIsCOW(tmpRef))
+ if (SvREADONLY(tmpRef))
Perl_croak_no_modify();
if (SvOBJECT(tmpRef)) {
SvREFCNT_dec(SvSTASH(tmpRef));
}
float_converted:
eptr = PL_efloatbuf;
+
+#ifdef USE_LOCALE_NUMERIC
if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
&& instr(eptr, SvPVX_const(PL_numeric_radix_sv)))
{
is_utf8 = TRUE;
}
+#endif
break;
daux->xhv_mro_meta = saux->xhv_mro_meta
? mro_meta_dup(saux->xhv_mro_meta, param)
: 0;
- daux->xhv_super = NULL;
/* Record stashes for possible cloning in Perl_clone(). */
if (HvNAME(sstr))
TOPINT(nss,ix) = i;
break;
case SAVEt_IV: /* IV reference */
+ case SAVEt_STRLEN: /* STRLEN/size_t ref */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
iv = POPIV(ss,ix);
PL_cryptseen = proto_perl->Icryptseen;
#endif
- PL_hints = proto_perl->Ihints;
-
#ifdef USE_LOCALE_COLLATE
PL_collation_ix = proto_perl->Icollation_ix;
PL_collation_standard = proto_perl->Icollation_standard;
https://perl5.git.perl.org / perl5.git / blobdiff