no route from NV to PVIV, NOK can never be true */
assert(!SvNOKp(sv));
assert(!SvNOK(sv));
+ /* FALLTHROUGH */
case SVt_PVIO:
case SVt_PVFM:
case SVt_PVGV:
* make more strings COW-able.
* If the new size is a big power of two, don't bother: we assume the
* caller wanted a nice 2^N sized block and will be annoyed at getting
- * 2^N+1 */
- if (newlen & 0xff)
+ * 2^N+1.
+ * Only increment if the allocation isn't MEM_SIZE_MAX,
+ * otherwise it will wrap to 0.
+ */
+ if (newlen & 0xff && newlen != MEM_SIZE_MAX)
newlen++;
#endif
/* Don't round up on the first allocation, as odds are pretty good that
* the initial request is accurate as to what is really needed */
if (SvLEN(sv)) {
- newlen = PERL_STRLEN_ROUNDUP(newlen);
+ STRLEN rounded = PERL_STRLEN_ROUNDUP(newlen);
+ if (rounded > newlen)
+ newlen = rounded;
}
#endif
if (SvLEN(sv) && s) {
{
const char *sbegin;
STRLEN len;
+ int numtype;
PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER;
}
else
return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
- return grok_number(sbegin, len, NULL);
+ numtype = grok_number(sbegin, len, NULL);
+ return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype;
}
STATIC bool
/* If numtype is infnan, set the NV of the sv accordingly.
* If numtype is anything else, try setting the NV using Atof(PV). */
+#ifdef USING_MSVC6
+# pragma warning(push)
+# pragma warning(disable:4756;disable:4056)
+#endif
static void
S_sv_setnv(pTHX_ SV* sv, int numtype)
{
SvPOK_on(sv); /* PV is okay, though. */
}
}
+#ifdef USING_MSVC6
+# pragma warning(pop)
+#endif
STATIC bool
S_sv_2iuv_common(pTHX_ SV *const sv)
SvIV_set(sv, I_V(SvNVX(sv)));
if (SvNVX(sv) == (NV) SvIVX(sv)
#ifndef NV_PRESERVES_UV
+ && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */
&& (((UV)1 << NV_PRESERVES_UV_BITS) >
(UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
/* Don't flag it as "accurately an integer" if the number
sv_upgrade(sv, SVt_PVNV);
if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) {
+ if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING)))
+ not_a_number(sv);
S_sv_setnv(aTHX_ sv, numtype);
return FALSE;
}
} else {
/* 2s complement assumption */
if (value <= (UV)IV_MIN) {
- SvIV_set(sv, -(IV)value);
+ SvIV_set(sv, value == (UV)IV_MIN
+ ? IV_MIN : -(IV)value);
} else {
/* Too negative for an IV. This is a double upgrade, but
I'm assuming it will be rare. */
SvNOK_on(sv);
} else {
/* value has been set. It may not be precise. */
- if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
+ if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) {
/* 2s complement assumption for (UV)IV_MIN */
SvNOK_on(sv); /* Integer is too negative. */
} else {
SvIOKp_on(sv);
if (numtype & IS_NUMBER_NEG) {
+ /* -IV_MIN is undefined, but we should never reach
+ * this point with both IS_NUMBER_NEG and value ==
+ * (UV)IV_MIN */
+ assert(value != (UV)IV_MIN);
SvIV_set(sv, -(IV)value);
} else if (value <= (UV)IV_MAX) {
SvIV_set(sv, (IV)value);
uv = iv;
sign = 0;
} else {
- uv = -iv;
+ uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
sign = 1;
}
do {
* shared string constants we point to, instead of generating a new
* string for each instance. */
STATIC size_t
-S_infnan_2pv(NV nv, char* buffer, size_t maxlen) {
+S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) {
assert(maxlen >= 4);
if (maxlen < 4) /* "Inf\0", "NaN\0" */
return 0;
if (maxlen < 5) /* "-Inf\0" */
return 0;
*s++ = '-';
+ } else if (plus) {
+ *s++ = '+';
}
*s++ = 'I';
*s++ = 'n';
STRLEN size = 5; /* "-Inf\0" */
s = SvGROW_mutable(sv, size);
- len = S_infnan_2pv(SvNVX(sv), s, size);
+ len = S_infnan_2pv(SvNVX(sv), s, size, 0);
if (len > 0) {
s += len;
SvPOK_on(sv);
#else
{
bool local_radix;
- DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
local_radix =
PL_numeric_local &&
*/
void
-Perl_sv_copypv(pTHX_ SV *const dsv, SV *const ssv)
-{
- PERL_ARGS_ASSERT_SV_COPYPV;
-
- sv_copypv_flags(dsv, ssv, 0);
-}
-
-void
Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
{
STRLEN len;
if (extra) SvGROW(sv, SvCUR(sv) + extra);
return SvCUR(sv);
-must_be_utf8:
+ must_be_utf8:
/* Here, the string should be converted to utf8, either because of an
* input flag (two_byte_count = 0), or because a character that
/*
=for apidoc sv_get_backrefs
-If the sv is the target of a weakrefence then return
-the backrefs structure associated with the sv, otherwise
-return NULL.
+If the sv is the target of a weak reference then it returns the back
+references structure associated with the sv; otherwise return NULL.
-When returning a non-null result the type of the return
-is relevant. If it is an AV then the contents of the AV
-are the weakrefs which point at this item. If it is any
-other type then the item itself is the weakref.
+When returning a non-null result the type of the return is relevant. If it
+is an AV then the elements of the AV are the weak reference RVs which
+point at this item. If it is any other type then the item itself is the
+weak reference.
See also Perl_sv_add_backref(), Perl_sv_del_backref(),
Perl_sv_kill_backrefs()
*/
SV *
-Perl_sv_get_backrefs(pTHX_ SV *const sv)
+Perl_sv_get_backrefs(SV *const sv)
{
- SV **svp= NULL;
- MAGIC *mg = NULL;
+ SV *backrefs= NULL;
PERL_ARGS_ASSERT_SV_GET_BACKREFS;
/* find slot to store array or singleton backref */
if (SvTYPE(sv) == SVt_PVHV) {
- if (SvOOK(sv))
- svp = (SV**)Perl_hv_backreferences_p(aTHX_ sv);
- } else {
- if (SvMAGICAL(sv))
- mg = mg_find(sv, PERL_MAGIC_backref);
+ if (SvOOK(sv)) {
+ struct xpvhv_aux * const iter = HvAUX((HV *)sv);
+ backrefs = (SV *)iter->xhv_backreferences;
+ }
+ } else if (SvMAGICAL(sv)) {
+ MAGIC *mg = mg_find(sv, PERL_MAGIC_backref);
if (mg)
- svp = &(mg->mg_obj);
+ backrefs = mg->mg_obj;
}
- if (svp)
- return *svp;
- else
- return NULL;
+ return backrefs;
}
/* Give tsv backref magic if it hasn't already got it, then push a
PERL_ARGS_ASSERT_SV_INSERT_FLAGS;
- if (!bigstr)
- Perl_croak(aTHX_ "Can't modify nonexistent substring");
SvPV_force_flags(bigstr, curlen, flags);
(void)SvPOK_only_UTF8(bigstr);
if (offset + len > curlen) {
SV* iter_sv = NULL;
SV* next_sv = NULL;
SV *sv = orig_sv;
- STRLEN hash_index;
+ STRLEN hash_index = 0; /* initialise to make Coverity et al happy.
+ Not strictly necessary */
PERL_ARGS_ASSERT_SV_CLEAR;
PL_last_swash_hv = NULL;
}
if (HvTOTALKEYS((HV*)sv) > 0) {
- const char *name;
+ const HEK *hek;
/* this statement should match the one at the beginning of
* hv_undef_flags() */
if ( PL_phase != PERL_PHASE_DESTRUCT
- && (name = HvNAME((HV*)sv)))
+ && (hek = HvNAME_HEK((HV*)sv)))
{
if (PL_stashcache) {
- DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
- SVfARG(sv)));
+ DEBUG_o(Perl_deb(aTHX_
+ "sv_clear clearing PL_stashcache for '%"HEKf
+ "'\n",
+ HEKfARG(hek)));
(void)hv_deletehek(PL_stashcache,
- HvNAME_HEK((HV*)sv), G_DISCARD);
+ hek, G_DISCARD);
}
hv_name_set((HV*)sv, NULL, 0, 0);
}
else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
SvREFCNT_dec(LvTARG(sv));
if (isREGEXP(sv)) goto freeregexp;
+ /* FALLTHROUGH */
case SVt_PVGV:
if (isGV_with_GP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
PL_statgv = NULL;
else if ((const GV *)sv == PL_stderrgv)
PL_stderrgv = NULL;
+ /* FALLTHROUGH */
case SVt_PVMG:
case SVt_PVNV:
case SVt_PVIV:
goto thats_all_folks;
}
-thats_all_folks:
+ thats_all_folks:
/* check if we have actually found the separator - only really applies
* when rslen > 1 */
if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) ||
memNE((char*)bp - rslen, rsptr, rslen))
goto screamer; /* go back to the fray */
-thats_really_all_folks:
+ thats_really_all_folks:
if (shortbuffered)
cnt += shortbuffered;
DEBUG_P(PerlIO_printf(Perl_debug_log,
STDCHAR buf[8192];
#endif
-screamer2:
+ screamer2:
if (rslen) {
const STDCHAR * const bpe = buf + sizeof(buf);
bp = buf;
PERL_ARGS_ASSERT_F0CONVERT;
if (UNLIKELY(Perl_isinfnan(nv))) {
- STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len);
+ STRLEN n = S_infnan_2pv(nv, endbuf - *len, *len, 0);
*len = n;
return endbuf - n;
}
sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
}
-#if DOUBLEKIND == DOUBLE_IS_IEEE_754_32_BIT_LITTLE_ENDIAN || \
- DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_LITTLE_ENDIAN || \
- DOUBLEKIND == DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
-# define DOUBLE_LITTLE_ENDIAN
-#endif
-
-#ifdef HAS_LONG_DOUBLEKIND
-
-# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN
-# define LONGDOUBLE_LITTLE_ENDIAN
-# endif
-
-# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
-# define LONGDOUBLE_BIG_ENDIAN
-# endif
-
-# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
-# define LONGDOUBLE_X86_80_BIT
-# endif
-
-# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN || \
- LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
-# define LONGDOUBLE_DOUBLEDOUBLE
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
/* The first double can be as large as 2**1023, or '1' x '0' x 1023.
* The second double can be as small as 2**-1074, or '0' x 1073 . '1'.
* The sum of them can be '1' . '0' x 2096 . '1', with implied radix point
* of dynamically growing buffer might be better, start at just 16 bytes
* (for example) and grow only when necessary. Or maybe just by looking
* at the exponents of the two doubles? */
-# define DOUBLEDOUBLE_MAXBITS 2098
-# endif
-
-#endif /* HAS_LONG_DOUBLE */
+# define DOUBLEDOUBLE_MAXBITS 2098
+#endif
/* vhex will contain the values (0..15) of the hex digits ("nybbles"
* of 4 bits); 1 for the implicit 1, and the mantissa bits, four bits
bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */
bool hexfp = FALSE; /* hexadecimal floating point? */
- DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED;
+ DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
PERL_UNUSED_ARG(maybe_tainted);
#ifndef FV_ISFINITE
# define FV_ISFINITE(x) Perl_isfinite((NV)(x))
#endif
+ NV nv;
STRLEN have;
STRLEN need;
STRLEN gap;
esignbuf[esignlen++] = plus;
}
else {
- uv = -iv;
+ uv = (iv == IV_MIN) ? (UV)iv : (UV)(-iv);
esignbuf[esignlen++] = '-';
}
}
#ifdef USE_QUADMATH
fv = intsize == 'q' ?
va_arg(*args, NV) : va_arg(*args, double);
+ nv = fv;
#elif LONG_DOUBLESIZE > DOUBLESIZE
- if (intsize == 'q')
+ if (intsize == 'q') {
fv = va_arg(*args, long double);
- else
- NV_TO_FV(va_arg(*args, double), fv);
+ nv = fv;
+ } else {
+ nv = va_arg(*args, double);
+ NV_TO_FV(nv, fv);
+ }
#else
- fv = va_arg(*args, double);
+ nv = va_arg(*args, double);
+ fv = nv;
#endif
}
else
{
if (!infnan) SvGETMAGIC(argsv);
- NV_TO_FV(SvNV_nomg(argsv), fv);
+ nv = SvNV_nomg(argsv);
+ NV_TO_FV(nv, fv);
}
need = 0;
goto float_converted;
}
} else if ( c == 'f' && !precis ) {
- if ((eptr = F0convert(fv, ebuf + sizeof ebuf, &elen)))
+ if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen)))
break;
}
}
* should be output as 0x0.0000000000001p-1022 to
* match its internal structure. */
- /* Note: fv can be (and often is) long double.
- * Here it is explicitly cast to NV. */
- vend = S_hextract(aTHX_ (NV)fv, &exponent, vhex, NULL);
- S_hextract(aTHX_ (NV)fv, &exponent, vhex, vend);
+ vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL);
+ S_hextract(aTHX_ nv, &exponent, vhex, vend);
#if NVSIZE > DOUBLESIZE
# ifdef HEXTRACT_HAS_IMPLICIT_BIT
#endif
if (precis > 0) {
- v = vhex + precis + 1;
- if (v < vend) {
+ if ((SSize_t)(precis + 1) < vend - vhex) {
+ bool round;
+
+ v = vhex + precis + 1;
/* Round away from zero: if the tail
* beyond the precis xdigits is equal to
* or greater than 0x8000... */
- bool round = *v > 0x8;
+ round = *v > 0x8;
if (!round && *v == 0x8) {
for (v++; v < vend; v++) {
if (*v) {
elen = width;
}
}
- else
- elen = S_infnan_2pv(fv, PL_efloatbuf, PL_efloatsize);
+ else {
+ elen = S_infnan_2pv(nv, PL_efloatbuf, PL_efloatsize, plus);
+ if (elen) {
+ /* Not affecting infnan output: precision, alt, fill. */
+ if (elen < width) {
+ if (left) {
+ /* Pack the back with spaces. */
+ memset(PL_efloatbuf + elen, ' ', width - elen);
+ } else {
+ /* Move it to the right. */
+ Move(PL_efloatbuf, PL_efloatbuf + width - elen,
+ elen, char);
+ /* Pad the front with spaces. */
+ memset(PL_efloatbuf, ' ', width - elen);
+ }
+ elen = width;
+ }
+ }
+ }
if (elen == 0) {
char *ptr = ebuf + sizeof ebuf;
if (!qfmt)
Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr);
elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
- qfmt, fv);
+ qfmt, nv);
if ((IV)elen == -1)
Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s|'", qfmt);
if (qfmt != ptr)
}
items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr);
while (items-- > 0) {
- *dst_ary++ = &PL_sv_undef;
+ *dst_ary++ = NULL;
}
}
else {
case CXt_LOOP_LAZYSV:
ncx->blk_loop.state_u.lazysv.end
= sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param);
- /* We are taking advantage of av_dup_inc and sv_dup_inc
- actually being the same function, and order equivalence of
- the two unions.
+ /* Fallthrough: duplicate lazysv.cur by using the ary.ary
+ duplication code instead.
+ We are taking advantage of (1) av_dup_inc and sv_dup_inc
+ actually being the same function, and (2) order
+ equivalence of the two unions.
We can assert the later [but only at run time :-(] */
assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
(void *) &ncx->blk_loop.state_u.lazysv.cur);
+ /* FALLTHROUGH */
case CXt_LOOP_FOR:
ncx->blk_loop.state_u.ary.ary
= av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
+ /* FALLTHROUGH */
case CXt_LOOP_LAZYIV:
case CXt_LOOP_PLAIN:
+ /* code common to all CXt_LOOP_* types */
if (CxPADLOOP(ncx)) {
ncx->blk_loop.itervar_u.oldcomppad
= (PAD*)ptr_table_fetch(PL_ptr_table,
# ifdef DEBUG_LEAKING_SCALARS
PL_sv_serial = (((UV)my_perl >> 2) & 0xfff) * 1000000;
# endif
+# ifdef PERL_TRACE_OPS
+ Zero(PL_op_exec_cnt, OP_max+2, UV);
+# endif
#else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
#endif /* DEBUGGING */
PL_subline = proto_perl->Isubline;
+ PL_cv_has_eval = proto_perl->Icv_has_eval;
+
#ifdef FCRYPT
PL_cryptseen = proto_perl->Icryptseen;
#endif
PL_endav = av_dup_inc(proto_perl->Iendav, param);
PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
PL_initav = av_dup_inc(proto_perl->Iinitav, param);
+ PL_savebegin = proto_perl->Isavebegin;
PL_isarev = hv_dup_inc(proto_perl->Iisarev, param);
PL_subname = sv_dup_inc(proto_perl->Isubname, param);
+#ifdef USE_LOCALE_CTYPE
+ /* Should we warn if uses locale? */
+ PL_warn_locale = sv_dup_inc(proto_perl->Iwarn_locale, param);
+#endif
+
#ifdef USE_LOCALE_COLLATE
PL_collation_name = SAVEPV(proto_perl->Icollation_name);
#endif /* USE_LOCALE_COLLATE */
for (i = 0; i < POSIX_CC_COUNT; i++) {
PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
}
+ PL_GCB_invlist = sv_dup_inc(proto_perl->IGCB_invlist, param);
+ PL_SB_invlist = sv_dup_inc(proto_perl->ISB_invlist, param);
+ PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param);
PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
- PL_utf8_X_regular_begin = sv_dup_inc(proto_perl->Iutf8_X_regular_begin, param);
- PL_utf8_X_extend = sv_dup_inc(proto_perl->Iutf8_X_extend, param);
PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
nsv = sv_newmortal();
SvSetSV_nosteal(nsv, sv);
}
+ save_re_context();
PUSHMARK(sp);
EXTEND(SP, 3);
PUSHs(encoding);
PERL_ARGS_ASSERT_SV_CAT_DECODE;
- if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
+ if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding)) {
SV *offsv;
dSP;
ENTER;
SAVETMPS;
+ save_re_context();
PUSHMARK(sp);
EXTEND(SP, 6);
PUSHs(encoding);
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff