# include <stdint.h>
#endif
-#define FCALL *f
-
#ifdef __Lynx__
/* Missing proto on LynxOS */
char *gconvert(double, int, int, char *);
&& (sv->sv_flags & mask) == flags
&& SvREFCNT(sv))
{
- (FCALL)(aTHX_ sv);
+ (*f)(aTHX_ sv);
++visited;
}
}
=cut
*/
+static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags);
+
char *
Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen)
{
PERL_ARGS_ASSERT_SV_GROW;
-#ifdef HAS_64K_LIMIT
- if (newlen >= 0x10000) {
- PerlIO_printf(Perl_debug_log,
- "Allocation too large: %"UVxf"\n", (UV)newlen);
- my_exit(1);
- }
-#endif /* HAS_64K_LIMIT */
if (SvROK(sv))
sv_unref(sv);
if (SvTYPE(sv) < SVt_PV) {
s = SvPVX_mutable(sv);
if (newlen > SvLEN(sv))
newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
-#ifdef HAS_64K_LIMIT
- if (newlen >= 0x10000)
- newlen = 0xFFFF;
-#endif
}
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 */
const char * const end = s + SvCUR(sv);
for ( ; s < end && d < limit; s++ ) {
int ch = *s & 0xFF;
- if (ch & 128 && !isPRINT_LC(ch)) {
+ if (! isASCII(ch) && !isPRINT_LC(ch)) {
*d++ = 'M';
*d++ = '-';
- ch &= 127;
+
+ /* Map to ASCII "equivalent" of Latin1 */
+ ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
}
if (ch == '\n') {
*d++ = '\\';
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. */
RESTORE_ERRNO;
while (*s) s++;
}
-#ifdef hcx
- if (s[-1] == '.')
- *--s = '\0';
-#endif
}
else if (isGV_with_GP(sv)) {
GV *const gv = MUTABLE_GV(sv);
*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)
*/
bool
-Perl_sv_2bool_flags(pTHX_ SV *const sv, const I32 flags)
+Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
{
dVAR;
PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
+ restart:
if(flags & SV_GMAGIC) SvGETMAGIC(sv);
if (!SvOK(sv))
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
- if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
- return cBOOL(SvTRUE(tmpsv));
+ if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
+ bool svb;
+ sv = tmpsv;
+ if(SvGMAGICAL(sv)) {
+ flags = SV_GMAGIC;
+ goto restart; /* call sv_2bool */
+ }
+ /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
+ else if(!SvOK(sv)) {
+ svb = 0;
+ }
+ else if(SvPOK(sv)) {
+ svb = SvPVXtrue(sv);
+ }
+ else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
+ svb = (SvIOK(sv) && SvIVX(sv) != 0)
+ || (SvNOK(sv) && SvNVX(sv) != 0.0);
+ }
+ else {
+ flags = 0;
+ goto restart; /* call sv_2bool_nomg */
+ }
+ return cBOOL(svb);
+ }
}
return SvRV(sv) != 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 U8 ch = *t++;
- if (NATIVE_IS_INVARIANT(ch)) continue;
+ if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
t--; /* t already incremented; re-point to first variant */
two_byte_count = 1;
}
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 */
while (d < e) {
const U8 chr = *d++;
- if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
+ if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
}
/* The string will expand by just the number of bytes that
e--;
while (e >= t) {
- const U8 ch = NATIVE8_TO_UNI(*e--);
- if (UNI_IS_INVARIANT(ch)) {
- *d-- = UNI_TO_NATIVE(ch);
+ if (NATIVE_BYTE_IS_INVARIANT(*e)) {
+ *d-- = *e;
} else {
- *d-- = (U8)UTF8_EIGHT_BIT_LO(ch);
- *d-- = (U8)UTF8_EIGHT_BIT_HI(ch);
+ *d-- = UTF8_EIGHT_BIT_LO(*e);
+ *d-- = UTF8_EIGHT_BIT_HI(*e);
}
+ e--;
}
}
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));
}
}
}
+ /* 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);
if (SvTYPE(tsv) == SVt_PVHV) {
svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
} else {
- if (! ((mg =
- (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
- {
- sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
- mg = mg_find(tsv, PERL_MAGIC_backref);
- }
+ if (SvMAGICAL(tsv))
+ mg = mg_find(tsv, PERL_MAGIC_backref);
+ if (!mg)
+ mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
svp = &(mg->mg_obj);
}
|| (*svp && SvTYPE(*svp) != SVt_PVAV)
) {
/* create array */
+ if (mg)
+ mg->mg_flags |= MGf_REFCOUNTED;
av = newAV();
AvREAL_off(av);
- SvREFCNT_inc_simple_void(av);
+ SvREFCNT_inc_simple_void_NN(av);
/* av now has a refcnt of 2; see discussion above */
+ av_extend(av, *svp ? 2 : 1);
if (*svp) {
/* move single existing backref to the array */
- av_extend(av, 1);
AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
}
*svp = (SV*)av;
- if (mg)
- mg->mg_flags |= MGf_REFCOUNTED;
}
- else
+ else {
av = MUTABLE_AV(*svp);
-
- if (!av) {
- /* optimisation: store single backref directly in HvAUX or mg_obj */
- *svp = sv;
- return;
+ if (!av) {
+ /* optimisation: store single backref directly in HvAUX or mg_obj */
+ *svp = sv;
+ return;
+ }
+ assert(SvTYPE(av) == SVt_PVAV);
+ if (AvFILLp(av) >= AvMAX(av)) {
+ av_extend(av, AvFILLp(av)+1);
+ }
}
/* push new backref */
- assert(SvTYPE(av) == SVt_PVAV);
- if (AvFILLp(av) >= AvMAX(av)) {
- av_extend(av, AvFILLp(av)+1);
- }
AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
}
if (PL_stashcache) {
DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
sv));
- (void)hv_delete(PL_stashcache, name,
- HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) : HvNAMELEN_get((HV*)sv), G_DISCARD);
+ (void)hv_deletehek(PL_stashcache,
+ HvNAME_HEK((HV*)sv), G_DISCARD);
}
hv_name_set((HV*)sv, NULL, 0, 0);
}
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);
STRLEN rslen;
STDCHAR rslast;
STDCHAR *bp;
- I32 cnt;
- I32 i = 0;
- I32 rspara = 0;
+ SSize_t cnt;
+ int i = 0;
+ int rspara = 0;
PERL_ARGS_ASSERT_SV_GETS;
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%zd, base=%"
+ UVuf"\n",
+ PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
for (;;) {
screamer:
cannot_be_shortbuffered:
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
- PTR2UV(ptr),(long)cnt));
+ "Screamer: going to getc, ptr=%"UVuf", cnt=%zd\n",
+ PTR2UV(ptr),cnt));
PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
DEBUG_Pv(PerlIO_printf(Perl_debug_log,
- "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n",
+ PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
/* This used to call 'filbuf' in stdio form, but as that behaves like
i = PerlIO_getc(fp); /* get more characters */
DEBUG_Pv(PerlIO_printf(Perl_debug_log,
- "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n",
+ PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
cnt = PerlIO_get_cnt(fp);
ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
+ "Screamer: after getc, ptr=%"UVuf", cnt=%zd\n",
+ PTR2UV(ptr),cnt));
if (i == EOF) /* all done for ever? */
goto thats_really_all_folks;
if (shortbuffered)
cnt += shortbuffered;
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
+ "Screamer: quitting, ptr=%"UVuf", cnt=%zd\n",PTR2UV(ptr),cnt));
PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf
+ "\n",
+ PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
*bp = '\0';
SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
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;
}
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 */
}
}
}
return sv;
}
+SV *
+Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible)
+{
+ SV * const lv = newSV_type(SVt_PVLV);
+ PERL_ARGS_ASSERT_NEWSVAVDEFELEM;
+ LvTYPE(lv) = 'y';
+ sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
+ LvTARG(lv) = SvREFCNT_inc_simple_NN(av);
+ LvSTARGOFF(lv) = ix;
+ LvTARGLEN(lv) = extendible ? 1 : (STRLEN)UV_MAX;
+ return lv;
+}
+
/*
=for apidoc sv_setref_pv
{
dVAR;
SV *tmpRef;
+ HV *oldstash = NULL;
PERL_ARGS_ASSERT_SV_BLESS;
if (SvREADONLY(tmpRef))
Perl_croak_no_modify();
if (SvOBJECT(tmpRef)) {
- SvREFCNT_dec(SvSTASH(tmpRef));
+ oldstash = SvSTASH(tmpRef);
}
}
SvOBJECT_on(tmpRef);
SvUPGRADE(tmpRef, SVt_PVMG);
SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
+ SvREFCNT_dec(oldstash);
if(SvSMAGICAL(tmpRef))
if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
char ebuf[IV_DIG * 4 + NV_DIG + 32];
/* large enough for "%#.#f" --chip */
/* what about long double NVs? --jhi */
+#ifdef USE_LOCALE_NUMERIC
+ SV* oldlocale = NULL;
+#endif
PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
PERL_UNUSED_ARG(maybe_tainted);
q++;
break;
#endif
-#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
+#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
case 'L': /* Ld */
/*FALLTHROUGH*/
-#ifdef HAS_QUAD
+#if IVSIZE >= 8
case 'q': /* qd */
#endif
intsize = 'q';
#endif
case 'l':
++q;
-#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
+#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
if (*q == 'l') { /* lld, llf */
intsize = 'q';
++q;
goto unknown;
uv = (args) ? va_arg(*args, int) : SvIV(argsv);
if ((uv > 255 ||
- (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
+ (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES) {
eptr = (char*)utf8buf;
elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
case 'j': iv = va_arg(*args, intmax_t); break;
#endif
case 'q':
-#ifdef HAS_QUAD
+#if IVSIZE >= 8
iv = va_arg(*args, Quad_t); break;
#else
goto unknown;
case 'V':
default: iv = tiv; break;
case 'q':
-#ifdef HAS_QUAD
+#if IVSIZE >= 8
iv = (Quad_t)tiv; break;
#else
goto unknown;
#endif
default: uv = va_arg(*args, unsigned); break;
case 'q':
-#ifdef HAS_QUAD
+#if IVSIZE >= 8
uv = va_arg(*args, Uquad_t); break;
#else
goto unknown;
case 'V':
default: uv = tuv; break;
case 'q':
-#ifdef HAS_QUAD
+#if IVSIZE >= 8
uv = (Uquad_t)tuv; break;
#else
goto unknown;
/* No taint. Otherwise we are in the strange situation
* where printf() taints but print($float) doesn't.
* --jhi */
+
+#ifdef USE_LOCALE_NUMERIC
+ if (! PL_numeric_standard && ! IN_SOME_LOCALE_FORM) {
+
+ /* We use a mortal SV, so that any failures (such as if
+ * warnings are made fatal) won't leak */
+ char *oldlocale_string = setlocale(LC_NUMERIC, NULL);
+ oldlocale = newSVpvn_flags(oldlocale_string,
+ strlen(oldlocale_string),
+ SVs_TEMP);
+ PL_numeric_standard = TRUE;
+ setlocale(LC_NUMERIC, "C");
+ }
+#endif
+
#if defined(HAS_LONG_DOUBLE)
elen = ((intsize == 'q')
? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
}
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;
case 'j': *(va_arg(*args, intmax_t*)) = i; break;
#endif
case 'q':
-#ifdef HAS_QUAD
+#if IVSIZE >= 8
*(va_arg(*args, Quad_t*)) = i; break;
#else
goto unknown;
}
}
SvTAINT(sv);
+
+#ifdef USE_LOCALE_NUMERIC /* Done outside loop, so don't have to save/restore
+ each iteration. */
+ if (oldlocale) {
+ setlocale(LC_NUMERIC, SvPVX(oldlocale));
+ PL_numeric_standard = FALSE;
+ }
+#endif
}
/* =========================================================================
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_last_swash_slen = 0;
PL_srand_called = proto_perl->Isrand_called;
+ Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE);
if (flags & CLONEf_COPY_STACKS) {
/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
PerlIO_clone(aTHX_ proto_perl, param);
#endif
- PL_envgv = gv_dup(proto_perl->Ienvgv, param);
- PL_incgv = gv_dup(proto_perl->Iincgv, param);
- PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
+ PL_envgv = gv_dup_inc(proto_perl->Ienvgv, param);
+ PL_incgv = gv_dup_inc(proto_perl->Iincgv, param);
+ PL_hintgv = gv_dup_inc(proto_perl->Ihintgv, param);
PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
PL_stdingv = gv_dup(proto_perl->Istdingv, param);
PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
PL_defgv = gv_dup(proto_perl->Idefgv, param);
- PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
+ PL_argvgv = gv_dup_inc(proto_perl->Iargvgv, param);
PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
/* shortcuts to regexp stuff */
- PL_replgv = gv_dup(proto_perl->Ireplgv, param);
+ PL_replgv = gv_dup_inc(proto_perl->Ireplgv, param);
/* shortcuts to misc objects */
PL_errgv = gv_dup(proto_perl->Ierrgv, param);
/* shortcuts to debugging objects */
- PL_DBgv = gv_dup(proto_perl->IDBgv, param);
- PL_DBline = gv_dup(proto_perl->IDBline, param);
- PL_DBsub = gv_dup(proto_perl->IDBsub, param);
+ PL_DBgv = gv_dup_inc(proto_perl->IDBgv, param);
+ PL_DBline = gv_dup_inc(proto_perl->IDBline, param);
+ PL_DBsub = gv_dup_inc(proto_perl->IDBsub, param);
PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
#endif /* !USE_LOCALE_NUMERIC */
/* Unicode inversion lists */
- PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
+ PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param);
PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
- PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
- PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
+ PL_firstgv = gv_dup_inc(proto_perl->Ifirstgv, param);
+ PL_secondgv = gv_dup_inc(proto_perl->Isecondgv, param);
PL_stashcache = newHV();
https://perl5.git.perl.org / perl5.git / blobdiff