#define PERL_IN_SV_C
#include "perl.h"
#include "regcomp.h"
+#ifdef __VMS
+# include <rms.h>
+#endif
#ifndef HAS_C99
-# if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(VMS)
+# if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(__VMS)
# define HAS_C99 1
# endif
#endif
char *gconvert(double, int, int, char *);
#endif
+#ifdef PERL_NEW_COPY_ON_WRITE
+# ifndef SV_COW_THRESHOLD
+# define SV_COW_THRESHOLD 0 /* COW iff len > K */
+# endif
+# ifndef SV_COWBUF_THRESHOLD
+# define SV_COWBUF_THRESHOLD 1250 /* COW iff len > K */
+# endif
+# ifndef SV_COW_MAX_WASTE_THRESHOLD
+# define SV_COW_MAX_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
+# endif
+# ifndef SV_COWBUF_WASTE_THRESHOLD
+# define SV_COWBUF_WASTE_THRESHOLD 80 /* COW iff (len - cur) < K */
+# endif
+# ifndef SV_COW_MAX_WASTE_FACTOR_THRESHOLD
+# define SV_COW_MAX_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
+# endif
+# ifndef SV_COWBUF_WASTE_FACTOR_THRESHOLD
+# define SV_COWBUF_WASTE_FACTOR_THRESHOLD 2 /* COW iff len < (cur * K) */
+# endif
+#endif
+/* Work around compiler warnings about unsigned >= THRESHOLD when thres-
+ hold is 0. */
+#if SV_COW_THRESHOLD
+# define GE_COW_THRESHOLD(cur) ((cur) >= SV_COW_THRESHOLD)
+#else
+# define GE_COW_THRESHOLD(cur) 1
+#endif
+#if SV_COWBUF_THRESHOLD
+# define GE_COWBUF_THRESHOLD(cur) ((cur) >= SV_COWBUF_THRESHOLD)
+#else
+# define GE_COWBUF_THRESHOLD(cur) 1
+#endif
+#if SV_COW_MAX_WASTE_THRESHOLD
+# define GE_COW_MAX_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COW_MAX_WASTE_THRESHOLD)
+#else
+# define GE_COW_MAX_WASTE_THRESHOLD(cur,len) 1
+#endif
+#if SV_COWBUF_WASTE_THRESHOLD
+# define GE_COWBUF_WASTE_THRESHOLD(cur,len) (((len)-(cur)) < SV_COWBUF_WASTE_THRESHOLD)
+#else
+# define GE_COWBUF_WASTE_THRESHOLD(cur,len) 1
+#endif
+#if SV_COW_MAX_WASTE_FACTOR_THRESHOLD
+# define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COW_MAX_WASTE_FACTOR_THRESHOLD * (cur))
+#else
+# define GE_COW_MAX_WASTE_FACTOR_THRESHOLD(cur,len) 1
+#endif
+#if SV_COWBUF_WASTE_FACTOR_THRESHOLD
+# define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) ((len) < SV_COWBUF_WASTE_FACTOR_THRESHOLD * (cur))
+#else
+# define GE_COWBUF_WASTE_FACTOR_THRESHOLD(cur,len) 1
+#endif
+
+#define CHECK_COW_THRESHOLD(cur,len) (\
+ GE_COW_THRESHOLD((cur)) && \
+ GE_COW_MAX_WASTE_THRESHOLD((cur),(len)) && \
+ GE_COW_MAX_WASTE_FACTOR_THRESHOLD((cur),(len)) \
+)
+#define CHECK_COWBUF_THRESHOLD(cur,len) (\
+ GE_COWBUF_THRESHOLD((cur)) && \
+ GE_COWBUF_WASTE_THRESHOLD((cur),(len)) && \
+ GE_COWBUF_WASTE_FACTOR_THRESHOLD((cur),(len)) \
+)
/* void Gconvert: on Linux at least, gcvt (which Gconvert gets deffed to),
* has a mandatory return value, even though that value is just the same
* as the buf arg */
-#define V_Gconvert(x,n,t,b) \
-{ \
- char *rc = (char *)Gconvert(x,n,t,b); \
- PERL_UNUSED_VAR(rc); \
-}
-
-
#ifdef PERL_UTF8_CACHE_ASSERT
/* if adding more checks watch out for the following tests:
* t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
/* ============================================================================
=head1 Allocation and deallocation of SVs.
-
An SV (or AV, HV, etc.) is allocated in two parts: the head (struct
sv, av, hv...) contains type and reference count information, and for
many types, a pointer to the body (struct xrv, xpv, xpviv...), which
The following global variables are associated with arenas:
- PL_sv_arenaroot pointer to list of SV arenas
- PL_sv_root pointer to list of free SV structures
+ PL_sv_arenaroot pointer to list of SV arenas
+ PL_sv_root pointer to list of free SV structures
- PL_body_arenas head of linked-list of body arenas
- PL_body_roots[] array of pointers to list of free bodies of svtype
- arrays are indexed by the svtype needed
+ PL_body_arenas head of linked-list of body arenas
+ PL_body_roots[] array of pointers to list of free bodies of svtype
+ arrays are indexed by the svtype needed
A few special SV heads are not allocated from an arena, but are
instead directly created in the interpreter structure, eg PL_sv_undef.
STATIC SV*
S_more_sv(pTHX)
{
- dVAR;
SV* sv;
char *chunk; /* must use New here to match call to */
Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */
STATIC void
S_del_sv(pTHX_ SV *p)
{
- dVAR;
-
PERL_ARGS_ASSERT_DEL_SV;
if (DEBUG_D_TEST) {
static void
S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags)
{
- dVAR;
SV *const sva = MUTABLE_SV(ptr);
SV* sv;
SV* svend;
STATIC I32
S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask)
{
- dVAR;
SV* sva;
I32 visited = 0;
static void
do_clean_objs(pTHX_ SV *const ref)
{
- dVAR;
assert (SvROK(ref));
{
SV * const target = SvRV(ref);
static void
do_clean_named_objs(pTHX_ SV *const sv)
{
- dVAR;
SV *obj;
assert(SvTYPE(sv) == SVt_PVGV);
assert(isGV_with_GP(sv));
static void
do_clean_named_io_objs(pTHX_ SV *const sv)
{
- dVAR;
SV *obj;
assert(SvTYPE(sv) == SVt_PVGV);
assert(isGV_with_GP(sv));
void
Perl_sv_clean_objs(pTHX)
{
- dVAR;
GV *olddef, *olderr;
PL_in_clean_objs = TRUE;
visit(do_clean_objs, SVf_ROK, SVf_ROK);
static void
do_clean_all(pTHX_ SV *const sv)
{
- dVAR;
if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) {
/* don't clean pid table and strtab */
return;
I32
Perl_sv_clean_all(pTHX)
{
- dVAR;
I32 cleaned;
PL_in_clean_all = TRUE;
cleaned = visit(do_clean_all, 0,0);
heads and bodies within the arenas must already have been freed.
=cut
+
*/
void
Perl_sv_free_arenas(pTHX)
{
- dVAR;
SV* sva;
SV* svanext;
unsigned int i;
=head1 SV-Body Allocation
+=cut
+
Allocation of SV-bodies is similar to SV-heads, differing as follows;
the allocation mechanism is used for many body types, so is somewhat
more complicated, it uses arena-sets, and has no need for still-live
Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size,
const size_t arena_size)
{
- dVAR;
void ** const root = &PL_body_roots[sv_type];
struct arena_desc *adesc;
struct arena_set *aroot = (struct arena_set *) PL_body_arenas;
char *start;
const char *end;
const size_t good_arena_size = Perl_malloc_good_size(arena_size);
+#if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT)
+ dVAR;
+#endif
#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
static bool done_sanity_check;
STATIC void *
S_new_body(pTHX_ const svtype sv_type)
{
- dVAR;
void *xpv;
new_body_inline(xpv, sv_type);
return xpv;
void
Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type)
{
- dVAR;
void* old_body;
void* new_body;
const svtype old_type = SvTYPE(sv);
*/
int
-Perl_sv_backoff(pTHX_ SV *const sv)
+Perl_sv_backoff(SV *const sv)
{
STRLEN delta;
const char * const s = SvPVX_const(sv);
PERL_ARGS_ASSERT_SV_BACKOFF;
- PERL_UNUSED_CONTEXT;
assert(SvOOK(sv));
assert(SvTYPE(sv) != SVt_PVHV);
newlen++;
#endif
+#if defined(PERL_USE_MALLOC_SIZE) && defined(Perl_safesysmalloc_size)
+#define PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
+#endif
+
if (newlen > SvLEN(sv)) { /* need more room? */
STRLEN minlen = SvCUR(sv);
minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10;
if (newlen < minlen)
newlen = minlen;
-#ifndef Perl_safesysmalloc_size
- newlen = PERL_STRLEN_ROUNDUP(newlen);
+#ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
+
+ /* 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);
+ }
#endif
if (SvLEN(sv) && s) {
s = (char*)saferealloc(s, newlen);
}
}
SvPV_set(sv, s);
-#ifdef Perl_safesysmalloc_size
+#ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC
/* Do this here, do it once, do it right, and then we will never get
called back into sv_grow() unless there really is some growing
needed. */
void
Perl_sv_setiv(pTHX_ SV *const sv, const IV i)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_SETIV;
SV_CHECK_THINKFIRST_COW_DROP(sv);
void
Perl_sv_setnv(pTHX_ SV *const sv, const NV num)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_SETNV;
SV_CHECK_THINKFIRST_COW_DROP(sv);
STATIC void
S_not_a_number(pTHX_ SV *const sv)
{
- dVAR;
char tmpbuf[64];
const char *pv;
STATIC void
S_not_incrementable(pTHX_ SV *const sv) {
- dVAR;
char tmpbuf[64];
const char *pv;
Instead, IV/UV and NV need to be given equal rights. So as to not lose
precision as a side effect of conversion (which would lead to insanity
and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
- 1) to distinguish between IV/UV/NV slots that have cached a valid
- conversion where precision was lost and IV/UV/NV slots that have a
- valid conversion which has lost no precision
+ 1) to distinguish between IV/UV/NV slots that have a valid conversion cached
+ where precision was lost, and IV/UV/NV slots that have a valid conversion
+ which has lost no precision
2) to ensure that if a numeric conversion to one form is requested that
would lose precision, the precise conversion (or differently
imprecise conversion) is also performed and cached, to prevent
# endif
)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
+ PERL_UNUSED_CONTEXT;
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
STATIC bool
S_sv_2iuv_common(pTHX_ SV *const sv)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2IUV_COMMON;
if (SvNOKp(sv)) {
IV
Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2IV_FLAGS;
assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
UV
Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2UV_FLAGS;
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
NV
Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2NV_FLAGS;
assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
char *
Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
{
- dVAR;
char *s;
PERL_ARGS_ASSERT_SV_2PV_FLAGS;
/* some Xenix systems wipe out errno here */
#ifndef USE_LOCALE_NUMERIC
- V_Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
SvPOK_on(sv);
#else
{
DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
- V_Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ PERL_UNUSED_RESULT(Gconvert(SvNVX(sv), NV_DIG, 0, s));
/* If the radix character is UTF-8, and actually is in the
* output, turn on the UTF-8 flag for the scalar */
bool
Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
restart:
and just use bytes. But some things that do fit into a byte are variants in
utf8, and the caller may not have been keeping track of these.)
-If the routine itself changes the string, it adds a trailing NUL. Such a NUL
-isn't guaranteed due to having other routines do the work in some input cases,
-or if the input is already flagged as being in utf8.
+If the routine itself changes the string, it adds a trailing C<NUL>. Such a
+C<NUL> isn't guaranteed due to having other routines do the work in some input
+cases, or if the input is already flagged as being in utf8.
The speed of this could perhaps be improved for many cases if someone wanted to
write a fast function that counts the number of variant characters in a string,
STRLEN
Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW;
if (sv == &PL_sv_undef)
bool
Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE;
if (SvPOKp(sv) && SvUTF8(sv)) {
return;
}
-/* Work around compiler warnings about unsigned >= THRESHOLD when thres-
- hold is 0. */
-#if SV_COW_THRESHOLD
-# define GE_COW_THRESHOLD(len) ((len) >= SV_COW_THRESHOLD)
-#else
-# define GE_COW_THRESHOLD(len) 1
-#endif
-#if SV_COWBUF_THRESHOLD
-# define GE_COWBUF_THRESHOLD(len) ((len) >= SV_COWBUF_THRESHOLD)
-#else
-# define GE_COWBUF_THRESHOLD(len) 1
-#endif
+
+
#ifdef PERL_DEBUG_READONLY_COW
# include <sys/mman.h>
void
Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
{
- dVAR;
U32 sflags;
int dtype;
svtype stype;
else
Perl_croak(aTHX_ "Bizarre copy of %s", type);
}
- break;
+ NOT_REACHED; /* NOTREACHED */
case SVt_REGEXP:
upgregexp:
|| ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW))
== SVs_PADTMP
/* whose buffer is worth stealing */
- && GE_COWBUF_THRESHOLD(cur)
+ && CHECK_COWBUF_THRESHOLD(cur,len)
)
) &&
!(sflags & SVf_OOK) && /* and not involved in OOK hack? */
#elif defined(PERL_NEW_COPY_ON_WRITE)
(sflags & SVf_IsCOW
? (!len ||
- ( (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
+ ( (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
/* If this is a regular (non-hek) COW, only so
many COW "copies" are possible. */
&& CowREFCNT(sstr) != SV_COW_REFCNT_MAX ))
: ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
&& !(SvFLAGS(dstr) & SVf_BREAK)
- && GE_COW_THRESHOLD(cur) && cur+1 < len
- && (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
+ && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len
+ && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dstr) < cur+1)
))
#else
sflags & SVf_IsCOW
/*
=for apidoc sv_setpvn
-Copies a string into an SV. The C<len> parameter indicates the number of
+Copies a string (possibly containing embedded C<NUL> characters) into an SV.
+The C<len> parameter indicates the number of
bytes to be copied. If the C<ptr> argument is NULL the SV will become
undefined. Does not handle 'set' magic. See C<sv_setpvn_mg>.
void
Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len)
{
- dVAR;
char *dptr;
PERL_ARGS_ASSERT_SV_SETPVN;
/*
=for apidoc sv_setpv
-Copies a string into an SV. The string must be null-terminated. Does not
-handle 'set' magic. See C<sv_setpv_mg>.
+Copies a string into an SV. The string must be terminated with a C<NUL>
+character.
+Does not handle 'set' magic. See C<sv_setpv_mg>.
=cut
*/
void
Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr)
{
- dVAR;
STRLEN len;
PERL_ARGS_ASSERT_SV_SETPV;
void
Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_SETHEK;
if (!hek) {
=for apidoc sv_usepvn_flags
Tells an SV to use C<ptr> to find its string value. Normally the
-string is stored inside the SV but sv_usepvn allows the SV to use an
+string is stored inside the SV, but sv_usepvn allows the SV to use an
outside string. The C<ptr> should point to memory that was allocated
-by C<malloc>. It must be the start of a mallocked block
-of memory, and not a pointer to the middle of it. The
-string length, C<len>, must be supplied. By default
-this function will realloc (i.e. move) the memory pointed to by C<ptr>,
+by L<Newx|perlclib/Memory Management and String Handling>. It must be
+the start of a Newx-ed block of memory, and not a pointer to the
+middle of it (beware of L<OOK|perlguts/Offsets> and copy-on-write),
+and not be from a non-Newx memory allocator like C<malloc>. The
+string length, C<len>, must be supplied. By default this function
+will C<Renew> (i.e. realloc, move) the memory pointed to by C<ptr>,
so that pointer should not be freed or used by the programmer after
giving it to sv_usepvn, and neither should any pointers from "behind"
that pointer (e.g. ptr + 1) be used.
If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
-SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
+SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be C<NUL>, and the realloc
will be skipped (i.e. the buffer is actually at least 1 byte longer than
C<len>, and already meets the requirements for storing in C<SvPVX>).
void
Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags)
{
- dVAR;
STRLEN allocate;
PERL_ARGS_ASSERT_SV_USEPVN_FLAGS;
static void
S_sv_uncow(pTHX_ SV * const sv, const U32 flags)
{
- dVAR;
-
assert(SvIsCOW(sv));
{
#ifdef PERL_ANY_COW
}
# endif
SvPV_set(sv, NULL);
+ SvCUR_set(sv, 0);
SvLEN_set(sv, 0);
if (flags & SV_COW_DROP_PV) {
/* OK, so we don't need to copy our buffer. */
void
Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, const I32 flags)
{
- dVAR;
STRLEN dlen;
const char * const dstr = SvPV_force_flags(dsv, dlen, flags);
void
Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_CATSV_FLAGS;
if (ssv) {
/*
=for apidoc sv_catpv
-Concatenates the string onto the end of the string which is in the SV.
+Concatenates the C<NUL>-terminated string onto the end of the string which is
+in the SV.
If the SV has the UTF-8 status set, then the bytes appended should be
valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
void
Perl_sv_catpv(pTHX_ SV *const sv, const char *ptr)
{
- dVAR;
STRLEN len;
STRLEN tlen;
char *junk;
/*
=for apidoc sv_catpv_flags
-Concatenates the string onto the end of the string which is in the SV.
+Concatenates the C<NUL>-terminated string onto the end of the string which is
+in the SV.
If the SV has the UTF-8 status set, then the bytes appended should
be valid UTF-8. If C<flags> has the C<SV_SMAGIC> bit set, will C<mg_set>
on the modified SV if appropriate.
Creates a new SV. A non-zero C<len> parameter indicates the number of
bytes of preallocated string space the SV should have. An extra byte for a
-trailing NUL is also reserved. (SvPOK is not set for the SV even if string
+trailing C<NUL> is also reserved. (SvPOK is not set for the SV even if string
space is allocated.) The reference count for the new SV is set to 1.
In 5.9.3, newSV() replaces the older NEWSV() API, and drops the first
SV *
Perl_newSV(pTHX_ const STRLEN len)
{
- dVAR;
SV *sv;
new_SV(sv);
Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how,
const MGVTBL *const vtable, const char *const name, const I32 namlen)
{
- dVAR;
MAGIC* mg;
PERL_ARGS_ASSERT_SV_MAGICEXT;
Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
const char *const name, const I32 namlen)
{
- dVAR;
const MGVTBL *vtable;
MAGIC* mg;
unsigned int flags;
PERL_ARGS_ASSERT_SV_MAGIC;
- if (how < 0 || (unsigned)how > C_ARRAY_LENGTH(PL_magic_data)
+ if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data)
|| ((flags = PL_magic_data[how]),
(vtable_index = flags & PERL_MAGIC_VTABLE_MASK)
> magic_vtable_max))
void
Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv)
{
- dVAR;
SV **svp;
AV *av = NULL;
MAGIC *mg = NULL;
void
Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv)
{
- dVAR;
SV **svp = NULL;
PERL_ARGS_ASSERT_SV_DEL_BACKREF;
if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0)
return;
Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf,
- *svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
+ (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv));
}
if (SvTYPE(*svp) == SVt_PVAV) {
else {
/* optimisation: only a single backref, stored directly */
if (*svp != sv)
- Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", *svp, sv);
+ Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p",
+ (void*)*svp, (void*)sv);
*svp = NULL;
}
void
Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags)
{
- dVAR;
char *big;
char *mid;
char *midend;
void
Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv)
{
- dVAR;
const U32 refcnt = SvREFCNT(sv);
PERL_ARGS_ASSERT_SV_REPLACE;
{
if (PL_stashcache) {
DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
- sv));
+ SVfARG(sv)));
(void)hv_deletehek(PL_stashcache,
HvNAME_HEK((HV*)sv), G_DISCARD);
}
static bool
S_curse(pTHX_ SV * const sv, const bool check_refcnt) {
- dVAR;
-
PERL_ARGS_ASSERT_CURSE;
assert(SvOBJECT(sv));
STRLEN
Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
{
- dVAR;
STRLEN len;
const U8 *s = (U8*)SvPV_nomg_const(sv, len);
I32
Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags)
{
- dVAR;
const char *pv1;
STRLEN cur1;
const char *pv2;
Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2,
const U32 flags)
{
- dVAR;
STRLEN cur1, cur2;
const char *pv1, *pv2;
I32 cmp;
Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2,
const U32 flags)
{
- dVAR;
#ifdef USE_LOCALE_COLLATE
char *pv1, *pv2;
*/
raw_compare:
- /*FALLTHROUGH*/
+ /* FALLTHROUGH */
#else
PERL_UNUSED_ARG(flags);
char *
Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
{
- dVAR;
MAGIC *mg;
PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
char *buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
/* Go yank in */
-#ifdef VMS
-#include <rms.h>
+#ifdef __VMS
int fd;
Stat_t st;
char *
Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append)
{
- dVAR;
const char *rsptr;
STRLEN rslen;
STDCHAR rslast;
SvUPGRADE(sv, SVt_PV);
if (append) {
+ /* line is going to be appended to the existing buffer in the sv */
if (PerlIO_isutf8(fp)) {
if (!SvUTF8(sv)) {
sv_utf8_upgrade_nomg(sv);
SvPOK_only(sv);
if (!append) {
+ /* not appending - "clear" the string by setting SvCUR to 0,
+ * the pv is still avaiable. */
SvCUR_set(sv,0);
}
if (PerlIO_isutf8(fp))
Perl_croak(aTHX_ "Wide character in $/");
}
}
+ /* extract the raw pointer to the record separator */
rsptr = SvPV_const(PL_rs, rslen);
}
}
+ /* rslast is the last character in the record separator
+ * note we don't use rslast except when rslen is true, so the
+ * null assign is a placeholder. */
rslast = rslen ? rsptr[rslen - 1] : '\0';
if (rspara) { /* have to do this both before and after */
*/
if (PerlIO_fast_gets(fp)) {
+ /*
+ * We can do buffer based IO operations on this filehandle.
+ *
+ * This means we can bypass a lot of subcalls and process
+ * the buffer directly, it also means we know the upper bound
+ * on the amount of data we might read of the current buffer
+ * into our sv. Knowing this allows us to preallocate the pv
+ * to be able to hold that maximum, which allows us to simplify
+ * a lot of logic. */
/*
* We're going to steal some values from the stdio struct
* and put EVERYTHING in the innermost loop into registers.
*/
- STDCHAR *ptr;
- STRLEN bpx;
- I32 shortbuffered;
-
-#if defined(VMS) && defined(PERLIO_IS_STDIO)
+ STDCHAR *ptr; /* pointer into fp's read-ahead buffer */
+ STRLEN bpx; /* length of the data in the target sv
+ used to fix pointers after a SvGROW */
+ I32 shortbuffered; /* If the pv buffer is shorter than the amount
+ of data left in the read-ahead buffer.
+ If 0 then the pv buffer can hold the full
+ amount left, otherwise this is the amount it
+ can hold. */
+
+#if defined(__VMS) && defined(PERLIO_IS_STDIO)
/* An ungetc()d char is handled separately from the regular
* buffer, so we getc() it back out and stuff it in the buffer.
*/
/* Here is some breathtakingly efficient cheating */
- cnt = PerlIO_get_cnt(fp); /* get count into register */
+ /* When you read the following logic resist the urge to think
+ * of record separators that are 1 byte long. They are an
+ * uninteresting special (simple) case.
+ *
+ * Instead think of record separators which are at least 2 bytes
+ * long, and keep in mind that we need to deal with such
+ * separators when they cross a read-ahead buffer boundary.
+ *
+ * Also consider that we need to gracefully deal with separators
+ * that may be longer than a single read ahead buffer.
+ *
+ * Lastly do not forget we want to copy the delimiter as well. We
+ * are copying all data in the file _up_to_and_including_ the separator
+ * itself.
+ *
+ * Now that you have all that in mind here is what is happening below:
+ *
+ * 1. When we first enter the loop we do some memory book keeping to see
+ * how much free space there is in the target SV. (This sub assumes that
+ * it is operating on the same SV most of the time via $_ and that it is
+ * going to be able to reuse the same pv buffer each call.) If there is
+ * "enough" room then we set "shortbuffered" to how much space there is
+ * and start reading forward.
+ *
+ * 2. When we scan forward we copy from the read-ahead buffer to the target
+ * SV's pv buffer. While we go we watch for the end of the read-ahead buffer,
+ * and the end of the of pv, as well as for the "rslast", which is the last
+ * char of the separator.
+ *
+ * 3. When scanning forward if we see rslast then we jump backwards in *pv*
+ * (which has a "complete" record up to the point we saw rslast) and check
+ * it to see if it matches the separator. If it does we are done. If it doesn't
+ * we continue on with the scan/copy.
+ *
+ * 4. If we run out of read-ahead buffer (cnt goes to 0) then we have to get
+ * the IO system to read the next buffer. We do this by doing a getc(), which
+ * returns a single char read (or EOF), and prefills the buffer, and also
+ * allows us to find out how full the buffer is. We use this information to
+ * SvGROW() the sv to the size remaining in the buffer, after which we copy
+ * the returned single char into the target sv, and then go back into scan
+ * forward mode.
+ *
+ * 5. If we run out of write-buffer then we SvGROW() it by the size of the
+ * remaining space in the read-buffer.
+ *
+ * Note that this code despite its twisty-turny nature is pretty darn slick.
+ * It manages single byte separators, multi-byte cross boundary separators,
+ * and cross-read-buffer separators cleanly and efficiently at the cost
+ * of potentially greatly overallocating the target SV.
+ *
+ * Yves
+ */
+
+
+ /* get the number of bytes remaining in the read-ahead buffer
+ * on first call on a given fp this will return 0.*/
+ cnt = PerlIO_get_cnt(fp);
+
/* make sure we have the room */
if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
/* Not room for all of it
cnt -= shortbuffered;
}
else {
+ /* ensure that the target sv has enough room to hold
+ * the rest of the read-ahead buffer */
shortbuffered = 0;
/* remember that cnt can be negative */
SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
}
}
- else
+ else {
+ /* we have enough room to hold the full buffer, lets scream */
shortbuffered = 0;
+ }
+
+ /* extract the pointer to sv's string buffer, offset by append as necessary */
bp = (STDCHAR*)SvPVX_const(sv) + append; /* move these two too to registers */
+ /* extract the point to the read-ahead buffer */
ptr = (STDCHAR*)PerlIO_get_ptr(fp);
+
+ /* some trace debug output */
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=%zd, base=%"
+ "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"
UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
+ PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
+
for (;;) {
screamer:
+ /* if there is stuff left in the read-ahead buffer */
if (cnt > 0) {
+ /* if there is a separator */
if (rslen) {
+ /* loop until we hit the end of the read-ahead buffer */
while (cnt > 0) { /* this | eat */
+ /* scan forward copying and searching for rslast as we go */
cnt--;
if ((*bp++ = *ptr++) == rslast) /* really | dust */
goto thats_all_folks; /* screams | sed :-) */
}
}
else {
+ /* no separator, slurp the full buffer */
Copy(ptr, bp, cnt, char); /* this | eat */
bp += cnt; /* screams | dust */
ptr += cnt; /* louder | sed :-) */
}
if (shortbuffered) { /* oh well, must extend */
+ /* we didnt have enough room to fit the line into the target buffer
+ * so we must extend the target buffer and keep going */
cnt = shortbuffered;
shortbuffered = 0;
bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
SvCUR_set(sv, bpx);
+ /* extned the target sv's buffer so it can hold the full read-ahead buffer */
SvGROW(sv, SvLEN(sv) + append + cnt + 2);
bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
continue;
}
cannot_be_shortbuffered:
+ /* we need to refill the read-ahead buffer if possible */
+
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: going to getc, ptr=%"UVuf", cnt=%zd\n",
- PTR2UV(ptr),cnt));
+ "Screamer: going to getc, ptr=%"UVuf", cnt=%"IVdf"\n",
+ PTR2UV(ptr),(IV)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=%zd, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
+ "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf"\n",
+ PTR2UV(PerlIO_get_ptr(fp)), (IV)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
- getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
- another abstraction. */
+ /*
+ call PerlIO_getc() to let it prefill the lookahead buffer
+
+ This used to call 'filbuf' in stdio form, but as that behaves like
+ getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
+ another abstraction.
+
+ Note we have to deal with the char in 'i' if we are not at EOF
+ */
i = PerlIO_getc(fp); /* get more characters */
DEBUG_Pv(PerlIO_printf(Perl_debug_log,
- "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
+ "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf"\n",
+ PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+ /* find out how much is left in the read-ahead buffer, and rextract its pointer */
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=%zd\n",
- PTR2UV(ptr),cnt));
+ "Screamer: after getc, ptr=%"UVuf", cnt=%"IVdf"\n",
+ PTR2UV(ptr),(IV)cnt));
if (i == EOF) /* all done for ever? */
goto thats_really_all_folks;
+ /* make sure we have enough space in the target sv */
bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */
SvCUR_set(sv, bpx);
SvGROW(sv, bpx + cnt + 2);
bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */
+ /* copy of the char we got from getc() */
*bp++ = (STDCHAR)i; /* store character from PerlIO_getc */
+ /* make sure we deal with the i being the last character of a separator */
if (rslen && (STDCHAR)i == rslast) /* all done for now? */
goto 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 */
if (shortbuffered)
cnt += shortbuffered;
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: quitting, ptr=%"UVuf", cnt=%zd\n",PTR2UV(ptr),cnt));
+ "Screamer: quitting, ptr=%"UVuf", cnt=%"IVdf"\n",PTR2UV(ptr),(IV)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=%zd, base=%"UVuf
+ "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf
"\n",
- PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
+ PTR2UV(PerlIO_get_ptr(fp)), (IV)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 */
void
Perl_sv_inc_nomg(pTHX_ SV *const sv)
{
- dVAR;
char *d;
int flags;
while (isALPHA(*d)) d++;
while (isDIGIT(*d)) d++;
if (d < SvEND(sv)) {
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
+ const int numtype = grok_number_flags(SvPVX_const(sv), SvCUR(sv), NULL, PERL_SCAN_TRAILING);
#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
void
Perl_sv_dec(pTHX_ SV *const sv)
{
- dVAR;
if (!sv)
return;
SvGETMAGIC(sv);
void
Perl_sv_dec_nomg(pTHX_ SV *const sv)
{
- dVAR;
int flags;
if (!sv)
SV *
Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags)
{
- dVAR;
SV *sv;
if (flags & SV_GMAGIC)
SV *
Perl_sv_newmortal(pTHX)
{
- dVAR;
SV *sv;
new_SV(sv);
/*
=for apidoc newSVpvn_flags
-Creates a new SV and copies a string into it. The reference count for the
+Creates a new SV and copies a string (which may contain C<NUL> (C<\0>)
+characters) into it. The reference count for the
SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
string. You are responsible for ensuring that the source string is at least
C<len> bytes long. If the C<s> argument is NULL the new SV will be undefined.
SV *
Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags)
{
- dVAR;
SV *sv;
/* All the flags we don't support must be zero.
/*
=for apidoc newSVpv
-Creates a new SV and copies a string into it. The reference count for the
+Creates a new SV and copies a string (which may contain C<NUL> (C<\0>)
+characters) into it. The reference count for the
SV is set to 1. If C<len> is zero, Perl will compute the length using
-strlen(). For efficiency, consider using C<newSVpvn> instead.
+strlen(), (which means if you use this option, that C<s> can't have embedded
+C<NUL> characters and has to have a terminating C<NUL> byte).
+
+For efficiency, consider using C<newSVpvn> instead.
=cut
*/
SV *
Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
{
- dVAR;
SV *sv;
new_SV(sv);
/*
=for apidoc newSVpvn
-Creates a new SV and copies a buffer into it, which may contain NUL characters
+Creates a new SV and copies a string into it, which may contain C<NUL> characters
(C<\0>) and other binary data. The reference count for the SV is set to 1.
Note that if C<len> is zero, Perl will create a zero length (Perl) string. You
are responsible for ensuring that the source buffer is at least
SV *
Perl_newSVpvn(pTHX_ const char *const buffer, const STRLEN len)
{
- dVAR;
SV *sv;
-
new_SV(sv);
sv_setpvn(sv,buffer,len);
return sv;
SV *
Perl_newSVhek(pTHX_ const HEK *const hek)
{
- dVAR;
if (!hek) {
SV *sv;
/*
=for apidoc newSVpv_share
-Like C<newSVpvn_share>, but takes a nul-terminated string instead of a
+Like C<newSVpvn_share>, but takes a C<NUL>-terminated string instead of a
string/length pair.
=cut
SV *
Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args)
{
- dVAR;
SV *sv;
PERL_ARGS_ASSERT_VNEWSVPVF;
SV *
Perl_newSVnv(pTHX_ const NV n)
{
- dVAR;
SV *sv;
new_SV(sv);
SV *
Perl_newSViv(pTHX_ const IV i)
{
- dVAR;
SV *sv;
new_SV(sv);
SV *
Perl_newSVuv(pTHX_ const UV u)
{
- dVAR;
SV *sv;
new_SV(sv);
SV *
Perl_newRV_noinc(pTHX_ SV *const tmpRef)
{
- dVAR;
SV *sv = newSV_type(SVt_IV);
PERL_ARGS_ASSERT_NEWRV_NOINC;
SV *
Perl_newRV(pTHX_ SV *const sv)
{
- dVAR;
-
PERL_ARGS_ASSERT_NEWRV;
return newRV_noinc(SvREFCNT_inc_simple_NN(sv));
SV *
Perl_newSVsv(pTHX_ SV *const old)
{
- dVAR;
SV *sv;
if (!old)
void
Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
{
- dVAR;
char todo[PERL_UCHAR_MAX+1];
const char *send;
HEKfARG(GvNAME_HEK(gv)));
break;
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
if (!SvOK(sv))
Perl_croak(aTHX_ PL_no_usym, "filehandle");
CV *
Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref)
{
- dVAR;
GV *gv = NULL;
CV *cv = NULL;
char *
Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS;
if (flags & SV_GMAGIC) SvGETMAGIC(sv);
if (lp)
*lp = len;
- if (s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
+ if (SvTYPE(sv) < SVt_PV ||
+ s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */
if (SvROK(sv))
sv_unref(sv);
SvUPGRADE(sv, SVt_PV); /* Never FALSE */
SV*
Perl_newSVrv(pTHX_ SV *const rv, const char *const classname)
{
- dVAR;
SV *sv;
PERL_ARGS_ASSERT_NEWSVRV;
SV*
Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_SETREF_PV;
if (!pv) {
SV*
Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
{
- dVAR;
SV *tmpRef;
HV *oldstash = NULL;
PERL_STATIC_INLINE void
S_sv_unglob(pTHX_ SV *const sv, U32 flags)
{
- dVAR;
void *xpvmg;
HV *stash;
SV * const temp = flags & SV_COW_DROP_PV ? NULL : sv_newmortal();
Perl_sv_untaint(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_UNTAINT;
+ PERL_UNUSED_CONTEXT;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
Perl_sv_tainted(pTHX_ SV *const sv)
{
PERL_ARGS_ASSERT_SV_TAINTED;
+ PERL_UNUSED_CONTEXT;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint);
* Warn of missing argument to sprintf, and then return a defined value
* to avoid inappropriate "use of uninit" warnings [perl #71000].
*/
-#define WARN_MISSING WARN_UNINITIALIZED /* Not sure we want a new category */
STATIC SV*
S_vcatpvfn_missing_argument(pTHX) {
if (ckWARN(WARN_MISSING)) {
STATIC I32
S_expect_number(pTHX_ char **const pattern)
{
- dVAR;
I32 var = 0;
PERL_ARGS_ASSERT_EXPECT_NUMBER;
sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, SV_GMAGIC|SV_SMAGIC);
}
+/* vhex will contain the values (0..15) of the hex digits ("nybbles"
+ * of 4 bits); 1 for the implicit 1, and at most 128 bits of mantissa,
+ * four bits per xdigit. */
+#define VHEX_SIZE (1+128/4)
+
+/* If we do not have a known long double format, (including not using
+ * long doubles, or long doubles being equal to doubles) then we will
+ * fall back to the ldexp/frexp route, with which we can retrieve at
+ * most as many bits as our widest unsigned integer type is. We try
+ * to get a 64-bit unsigned integer even if we are not having 64-bit
+ * UV. */
+#if defined(HAS_QUAD) && defined(Uquad_t)
+# define MANTISSATYPE Uquad_t
+# define MANTISSASIZE 8
+#else
+# define MANTISSATYPE UV /* May lose precision if UVSIZE is not 8. */
+# define MANTISSASIZE UVSIZE
+#endif
+
+/* S_hextract() is a helper for Perl_sv_vcatpvfn_flags, for extracting
+ * the hexadecimal values (for %a/%A). The nv is the NV where the value
+ * are being extracted from (either directly from the long double in-memory
+ * presentation, or from the uquad computed via frexp+ldexp). frexp also
+ * is used to update the exponent. vhex is the pointer to the beginning
+ * of the output buffer (of VHEX_SIZE).
+ *
+ * The tricky part is that S_hextract() needs to be called twice:
+ * the first time with vend as NULL, and the second time with vend as
+ * the pointer returned by the first call. What happens is that on
+ * the first round the output size is computed, and the intended
+ * extraction sanity checked. On the second round the actual output
+ * (the extraction of the hexadecimal values) takes place.
+ * Sanity failures cause fatal failures during both rounds. */
+STATIC U8*
+S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend)
+{
+ U8* v = vhex;
+ int ix;
+ int ixmin = 0, ixmax = 0;
+
+ /* XXX Inf/NaN handling in the HEXTRACT_IMPLICIT_BIT,
+ * and elsewhere. */
+
+ /* These macros are just to reduce typos, they have multiple
+ * repetitions below, but usually only one (or sometimes two)
+ * of them is really being used. */
+ /* HEXTRACT_OUTPUT() extracts the high nybble first. */
+#define HEXTRACT_OUTPUT() \
+ STMT_START { \
+ *v++ = nvp[ix] >> 4; \
+ *v++ = nvp[ix] & 0xF; \
+ } STMT_END
+#define HEXTRACT_COUNT() \
+ STMT_START { \
+ v += 2; \
+ if (ix < ixmin) \
+ ixmin = ix; \
+ else if (ix > ixmax) \
+ ixmax = ix; \
+ } STMT_END
+#define HEXTRACT_IMPLICIT_BIT() \
+ if (exponent) { \
+ if (vend) \
+ *v++ = 1; \
+ else \
+ v++; \
+ }
+
+ /* First see if we are using long doubles. */
+#if NVSIZE > DOUBLESIZE && LONG_DOUBLEKIND != LONG_DOUBLE_IS_DOUBLE
+ const U8* nvp = (const U8*)(&nv);
+# define HEXTRACTSIZE NVSIZE
+ (void)Perl_frexp(PERL_ABS(nv), exponent);
+# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
+ /* Used in e.g. VMS and HP-UX IA64, e.g. -0.1L:
+ * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */
+ /* The bytes 13..0 are the mantissa/fraction,
+ * the 15,14 are the sign+exponent. */
+ HEXTRACT_IMPLICIT_BIT();
+ for (ix = 13; ix >= 0; ix--) {
+ if (vend)
+ HEXTRACT_OUTPUT();
+ else
+ HEXTRACT_COUNT();
+ }
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_BIG_ENDIAN
+ /* Used in e.g. Solaris Sparc and HP-PA HP-UX, e.g. -0.1L:
+ * bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a */
+ /* The bytes 2..15 are the mantissa/fraction,
+ * the 0,1 are the sign+exponent. */
+ HEXTRACT_IMPLICIT_BIT();
+ for (ix = 2; ix <= 15; ix++) {
+ if (vend)
+ HEXTRACT_OUTPUT();
+ else
+ HEXTRACT_COUNT();
+ }
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
+ /* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
+ * significand, 15 bits of exponent, 1 bit of sign. NVSIZE can
+ * be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X),
+ * meaning that 4 or 6 bytes are empty padding. */
+ /* The bytes 7..0 are the mantissa/fraction */
+ /* There explicitly is *no* implicit bit in this case. */
+ for (ix = 7; ix >= 0; ix--) {
+ if (vend)
+ HEXTRACT_OUTPUT();
+ else
+ HEXTRACT_COUNT();
+ }
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
+ /* The last 8 bytes are the mantissa/fraction.
+ * (does this format ever happen?) */
+ /* There explicitly is *no* implicit bit in this case. */
+ for (ix = LONGDBLSIZE - 8; ix < LONGDBLSIZE; ix++) {
+ if (vend)
+ HEXTRACT_OUTPUT();
+ else
+ HEXTRACT_COUNT();
+ }
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_LITTLE_ENDIAN
+ /* Where is this used?
+ *
+ * Guessing that the format would be the reverse
+ * of big endian, i.e. for -0.1L:
+ * 9a 99 99 99 99 99 59 3c 9a 99 99 99 99 99 b9 bf */
+ HEXTRACT_IMPLICIT_BIT();
+ for (ix = 13; ix >= 8; ix--) {
+ if (vend)
+ HEXTRACT_OUTPUT();
+ else
+ HEXTRACT_COUNT();
+ }
+ for (ix = 5; ix >= 0; ix--) {
+ if (vend)
+ HEXTRACT_OUTPUT();
+ else
+ HEXTRACT_COUNT();
+ }
+# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_DOUBLEDOUBLE_128_BIT_BIG_ENDIAN
+ /* Used in e.g. PPC/Power and MIPS.
+ *
+ * The mantissa bits are in two separate stretches,
+ * e.g. for -0.1L:
+ * bf b9 99 99 99 99 99 9a 3c 59 99 99 99 99 99 9a
+ * as seen in PowerPC AIX, as opposed to "true" 128-bit IEEE 754:
+ * bf fb 99 99 99 99 99 99 99 99 99 99 99 99 99 9a
+ * as seen in HP-PA HP-UX.
+ *
+ * Note that this blind copying might be considered not to be
+ * the right thing, since the first double already does
+ * rounding (0x9A as opposed to 0x99). But then again, we
+ * probably should just copy the bits as they are?
+ */
+ HEXTRACT_IMPLICIT_BIT();
+ for (ix = 2; ix < 8; ix++) {
+ if (vend)
+ HEXTRACT_OUTPUT();
+ else
+ HEXTRACT_COUNT();
+ }
+ for (ix = 10; ix < 16; ix++) {
+ if (vend)
+ HEXTRACT_OUTPUT();
+ else
+ HEXTRACT_COUNT();
+ }
+# else
+ Perl_croak(aTHX_
+ "Hexadecimal float: unsupported long double format");
+# endif
+#else
+ /* If not using long doubles (or if the long double format is
+ * known but not yet supported), try to retrieve the mantissa bits
+ * via frexp+ldexp. */
+
+ NV norm = Perl_frexp(PERL_ABS(nv), exponent);
+ /* Theoretically we have all the bytes [0, MANTISSASIZE-1] to
+ * inspect; but in practice we don't want the leading nybbles that
+ * are zero. With the common IEEE 754 value for NV_MANT_DIG being
+ * 53, we want the limit byte to be (int)((53-1)/8) == 6.
+ *
+ * Note that this is _not_ inspecting the in-memory format of the
+ * nv (as opposed to the long double method), but instead the UV
+ * retrieved with the frexp+ldexp invocation. */
+# if MANTISSASIZE * 8 > NV_MANT_DIG
+ MANTISSATYPE mantissa = Perl_ldexp(norm, NV_MANT_DIG);
+ int limit_byte = (NV_MANT_DIG - 1) / 8;
+# else
+ /* There will be low-order precision loss. Try to salvage as many
+ * bits as possible. Will truncate, not round. */
+ MANTISSATYPE mantissa =
+ Perl_ldexp(norm,
+ /* The highest possible shift by two that fits in the
+ * mantissa and is aligned (by four) the same was as
+ * NV_MANT_DIG. */
+ MANTISSASIZE * 8 - (4 - NV_MANT_DIG % 4));
+ int limit_byte = MANTISSASIZE - 1;
+# endif
+ const U8* nvp = (const U8*)(&mantissa);
+# define HEXTRACTSIZE MANTISSASIZE
+ /* We make here the wild assumption that the endianness of doubles
+ * is similar to the endianness of integers, and that there is no
+ * middle-endianness. This may come back to haunt us (the rumor
+ * has it that ARM can be quite haunted).
+ *
+ * We generate 4-bit xdigits (nybble/nibble) instead of 8-bit
+ * bytes, since we might need to handle printf precision, and also
+ * insert the radix.
+ */
+# if BYTEORDER == 0x12345678 || BYTEORDER == 0x1234 || \
+ 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
+ /* Little endian. */
+ for (ix = limit_byte; ix >= 0; ix--) {
+ if (vend)
+ HEXTRACT_OUTPUT();
+ else
+ HEXTRACT_COUNT();
+ }
+# else
+ /* Big endian. */
+ for (ix = MANTISSASIZE - 1 - limit_byte; ix < MANTISSASIZE; ix++) {
+ if (vend)
+ HEXTRACT_OUTPUT();
+ else
+ HEXTRACT_COUNT();
+ }
+# endif
+ /* If there are not enough bits in MANTISSATYPE, we couldn't get
+ * all of them, issue a warning.
+ *
+ * Note that NV_PRESERVES_UV_BITS would not help here, it is the
+ * wrong way around. */
+# if NV_MANT_DIG > MANTISSASIZE * 8
+ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
+ "Hexadecimal float: precision loss");
+# endif
+#endif
+ /* Croak for various reasons: if the output pointer escaped the
+ * output buffer, if the extraction index escaped the extraction
+ * buffer, or if the ending output pointer didn't match the
+ * previously computed value. */
+ if (v <= vhex || v - vhex >= VHEX_SIZE ||
+ ixmin < 0 || ixmax >= HEXTRACTSIZE ||
+ (vend && v != vend))
+ Perl_croak(aTHX_ "Hexadecimal float: internal error");
+ return v;
+}
+
void
Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen,
va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted,
const U32 flags)
{
- dVAR;
char *p;
char *q;
const char *patend;
char ebuf[IV_DIG * 4 + NV_DIG + 32];
/* large enough for "%#.#f" --chip */
/* what about long double NVs? --jhi */
+ bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */
+ bool hexfp = FALSE;
DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED;
(void)SvPV_force_nomg(sv, origlen);
/* special-case "", "%s", and "%-p" (SVf - see below) */
- if (patlen == 0)
+ if (patlen == 0) {
+ if (svmax && ckWARN(WARN_REDUNDANT))
+ Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+ PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
return;
+ }
if (patlen == 2 && pat[0] == '%' && pat[1] == 's') {
+ if (svmax > 1 && ckWARN(WARN_REDUNDANT))
+ Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+ PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
+
if (args) {
const char * const s = va_arg(*args, char*);
sv_catpv_nomg(sv, s ? s : nullstr);
}
if (args && patlen == 3 && pat[0] == '%' &&
pat[1] == '-' && pat[2] == 'p') {
+ if (svmax > 1 && ckWARN(WARN_REDUNDANT))
+ Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+ PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
argsv = MUTABLE_SV(va_arg(*args, void*));
sv_catsv_nomg(sv, argsv);
return;
pp = pat + 2;
while (*pp >= '0' && *pp <= '9')
digits = 10 * digits + (*pp++ - '0');
+
+ /* XXX: Why do this `svix < svmax` test? Couldn't we just
+ format the first argument and WARN_REDUNDANT if svmax > 1?
+ Munged by Nicholas Clark in v5.13.0-209-g95ea86d */
if (pp - pat == (int)patlen - 1 && svix < svmax) {
const NV nv = SvNV(*svargs);
if (*pp == 'g') {
if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
/* 0, point, slack */
STORE_LC_NUMERIC_SET_TO_NEEDED();
- V_Gconvert(nv, (int)digits, 0, ebuf);
+ PERL_UNUSED_RESULT(Gconvert(nv, (int)digits, 0, ebuf));
sv_catpv_nomg(sv, ebuf);
if (*ebuf) /* May return an empty string for digits==0 */
return;
if (*q == '$') {
++q;
efix = width;
+ if (!no_redundant_warning)
+ /* I've forgotten if it's a better
+ micro-optimization to always set this or to
+ only set it if it's unset */
+ no_redundant_warning = TRUE;
} else {
goto gotwidth;
}
#endif
#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
case 'L': /* Ld */
- /*FALLTHROUGH*/
+ /* FALLTHROUGH */
#if IVSIZE >= 8
case 'q': /* qd */
#endif
#else
intsize = 'l';
#endif
- /*FALLTHROUGH*/
+ /* FALLTHROUGH */
case 'd':
case 'i':
if (vectorize) {
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
case 'z': iv = va_arg(*args, SSize_t); break;
+#ifdef HAS_PTRDIFF_T
case 't': iv = va_arg(*args, ptrdiff_t); break;
+#endif
default: iv = va_arg(*args, int); break;
#ifdef HAS_C99
case 'j': iv = va_arg(*args, intmax_t); break;
#else
intsize = 'l';
#endif
- /*FALLTHROUGH*/
+ /* FALLTHROUGH */
case 'u':
base = 10;
goto uns_integer;
#else
intsize = 'l';
#endif
- /*FALLTHROUGH*/
+ /* FALLTHROUGH */
case 'o':
base = 8;
goto uns_integer;
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
case 'z': uv = va_arg(*args, Size_t); break;
+#ifdef HAS_PTRDIFF_T
case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
+#endif
#ifdef HAS_C99
case 'j': uv = va_arg(*args, uintmax_t); break;
#endif
{
char *ptr = ebuf + sizeof ebuf;
bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
+ unsigned dig;
zeros = 0;
switch (base) {
- unsigned dig;
case 16:
p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
do {
case 'F':
c = 'f'; /* maybe %F isn't supported here */
- /*FALLTHROUGH*/
+ /* FALLTHROUGH */
case 'e': case 'E':
case 'f':
case 'g': case 'G':
+ case 'a': case 'A':
if (vectorize)
goto unknown;
break;
/* [perl #20339] - we should accept and ignore %lf rather than die */
case 'l':
- /*FALLTHROUGH*/
+ /* FALLTHROUGH */
default:
#if defined(USE_LONG_DOUBLE)
intsize = args ? 0 : 'q';
#if defined(HAS_LONG_DOUBLE)
break;
#else
- /*FALLTHROUGH*/
+ /* FALLTHROUGH */
#endif
case 'c':
case 'h':
/* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything
else. frexp() has some unspecified behaviour for those three */
if (c != 'e' && c != 'E' && (nv * 0) == 0) {
- i = PERL_INT_MIN;
- /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
- will cast our (long double) to (double) */
- (void)Perl_frexp(nv, &i);
- if (i == PERL_INT_MIN)
- Perl_die(aTHX_ "panic: frexp");
- if (i > 0)
- need = BIT_DIGITS(i);
+ i = PERL_INT_MIN;
+ /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
+ will cast our (long double) to (double) */
+ (void)Perl_frexp(nv, &i);
+ if (i == PERL_INT_MIN)
+ Perl_die(aTHX_ "panic: frexp");
+ hexfp = (c == 'a' || c == 'A');
+ if (UNLIKELY(hexfp)) {
+ /* Hexadecimal floating point: this size
+ * computation probably overshoots, but that is
+ * better than undershooting. */
+ need +=
+ (nv < 0) + /* possible unary minus */
+ 2 + /* "0x" */
+ 1 + /* the very unlikely carry */
+ 1 + /* "1" */
+ 1 + /* "." */
+ /* We want one byte per each 4 bits in the
+ * mantissa. This works out to about 0.83
+ * bytes per NV decimal digit (of 4 bits):
+ * (NV_DIG * log(10)/log(2)) / 4,
+ * we overestimate by using 5/6 (0.8333...) */
+ ((NV_DIG * 5) / 6 + 1) +
+ 2 + /* "p+" */
+ (i >= 0 ? BIT_DIGITS(i) : 1 + BIT_DIGITS(-i)) +
+ 1; /* \0 */
+#ifdef USE_LOCALE_NUMERIC
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
+ if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC))
+ need += SvLEN(PL_numeric_radix_sv);
+ RESTORE_LC_NUMERIC();
+#endif
+ }
+ else if (i > 0) {
+ need = BIT_DIGITS(i);
+ } /* if i < 0, the number of digits is hard to predict. */
}
need += has_precis ? precis : 6; /* known default */
aka precis is 0 */
if ( c == 'g' && precis) {
STORE_LC_NUMERIC_SET_TO_NEEDED();
- V_Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
+ PERL_UNUSED_RESULT(Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf));
/* May return an empty string for digits==0 */
if (*PL_efloatbuf) {
elen = strlen(PL_efloatbuf);
break;
}
}
- {
+
+ if (UNLIKELY(hexfp)) {
+ /* Hexadecimal floating point. */
+ char* p = PL_efloatbuf;
+ U8 vhex[VHEX_SIZE];
+ U8* v = vhex; /* working pointer to vhex */
+ U8* vend; /* pointer to one beyond last digit of vhex */
+ U8* vfnz = NULL; /* first non-zero */
+ const bool lower = (c == 'a');
+ /* At output the values of vhex (up to vend) will
+ * be mapped through the xdig to get the actual
+ * human-readable xdigits. */
+ const char* xdig = PL_hexdigit;
+ int zerotail = 0; /* how many extra zeros to append */
+ int exponent; /* exponent of the floating point input */
+
+ vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL);
+ S_hextract(aTHX_ nv, &exponent, vhex, vend);
+
+ if (nv < 0)
+ *p++ = '-';
+ else if (plus)
+ *p++ = plus;
+ *p++ = '0';
+ if (lower) {
+ *p++ = 'x';
+ }
+ else {
+ *p++ = 'X';
+ xdig += 16; /* Use uppercase hex. */
+ }
+
+ /* Find the first non-zero xdigit. */
+ for (v = vhex; v < vend; v++) {
+ if (*v) {
+ vfnz = v;
+ break;
+ }
+ }
+
+ if (vfnz) {
+ U8* vlnz = NULL; /* The last non-zero. */
+
+ /* Find the last non-zero xdigit. */
+ for (v = vend - 1; v >= vhex; v--) {
+ if (*v) {
+ vlnz = v;
+ break;
+ }
+ }
+
+ /* Adjust the exponent so that the first output
+ * xdigit aligns with the 4-bit nybbles. */
+ exponent -= NV_MANT_DIG % 4 ? NV_MANT_DIG % 4 : 4;
+
+ if (precis > 0) {
+ v = vhex + precis + 1;
+ if (v < vend) {
+ /* Round away from zero: if the tail
+ * beyond the precis xdigits is equal to
+ * or greater than 0x8000... */
+ bool round = *v > 0x8;
+ if (!round && *v == 0x8) {
+ for (v++; v < vend; v++) {
+ if (*v) {
+ round = TRUE;
+ break;
+ }
+ }
+ }
+ if (round) {
+ for (v = vhex + precis; v >= vhex; v--) {
+ if (*v < 0xF) {
+ (*v)++;
+ break;
+ }
+ *v = 0;
+ if (v == vhex) {
+ /* If the carry goes all the way to
+ * the front, we need to output
+ * a single '1'. This goes against
+ * the "xdigit and then radix"
+ * but since this is "cannot happen"
+ * category, that is probably good. */
+ *p++ = xdig[1];
+ }
+ }
+ }
+ /* The new effective "last non zero". */
+ vlnz = vhex + precis;
+ }
+ else {
+ zerotail = precis - (vlnz - vhex);
+ }
+ }
+
+ v = vhex;
+ *p++ = xdig[*v++];
+
+ /* The radix is always output after the first
+ * non-zero xdigit, or if alt. */
+ if (vfnz < vlnz || alt) {
+#ifndef USE_LOCALE_NUMERIC
+ *p++ = '.';
+#else
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
+ if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) {
+ STRLEN n;
+ const char* r = SvPV(PL_numeric_radix_sv, n);
+ Copy(r, p, n, char);
+ p += n;
+ }
+ else {
+ *p++ = '.';
+ }
+ RESTORE_LC_NUMERIC();
+#endif
+ }
+
+ while (v <= vlnz)
+ *p++ = xdig[*v++];
+
+ while (zerotail--)
+ *p++ = '0';
+ }
+ else {
+ *p++ = '0';
+ exponent = 0;
+ }
+
+ elen = p - PL_efloatbuf;
+ elen += my_snprintf(p, PL_efloatsize - elen,
+ "%c%+d", lower ? 'p' : 'P',
+ exponent);
+
+ if (elen < width) {
+ if (left) {
+ /* Pad the back with spaces. */
+ memset(PL_efloatbuf + elen, ' ', width - elen);
+ }
+ else if (fill == '0') {
+ /* Insert the zeros between the "0x" and
+ * the digits, otherwise we end up with
+ * "0000xHHH..." */
+ STRLEN nzero = width - elen;
+ char* zerox = PL_efloatbuf + 2;
+ Move(zerox, zerox + nzero, elen - 2, char);
+ memset(zerox, fill, nzero);
+ }
+ 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;
+ }
+ }
+ else {
char *ptr = ebuf + sizeof ebuf;
*--ptr = '\0';
*--ptr = c;
* that is safe to use, even though it's not literal */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
#if defined(HAS_LONG_DOUBLE)
- elen = ((intsize == 'q')
- ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
- : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
+ elen = ((intsize == 'q')
+ ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
+ : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
#else
- elen = my_sprintf(PL_efloatbuf, ptr, nv);
+ elen = my_sprintf(PL_efloatbuf, ptr, nv);
#endif
GCC_DIAG_RESTORE;
}
+
float_converted:
eptr = PL_efloatbuf;
case 'l': *(va_arg(*args, long*)) = i; break;
case 'V': *(va_arg(*args, IV*)) = i; break;
case 'z': *(va_arg(*args, SSize_t*)) = i; break;
+#ifdef HAS_PTRDIFF_T
case 't': *(va_arg(*args, ptrdiff_t*)) = i; break;
+#endif
#ifdef HAS_C99
case 'j': *(va_arg(*args, intmax_t*)) = i; break;
#endif
goto vector;
}
}
+
+ /* Now that we've consumed all our printf format arguments (svix)
+ * do we have things left on the stack that we didn't use?
+ */
+ if (!no_redundant_warning && svmax >= svix + 1 && ckWARN(WARN_REDUNDANT)) {
+ Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s",
+ PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()");
+ }
+
SvTAINT(sv);
RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore
=head1 Cloning an interpreter
+=cut
+
All the macros and functions in this section are for the private use of
the main function, perl_clone().
to new addresses. The table is created and manipulated with the
ptr_table_* functions.
-=cut
-
* =========================================================================*/
Copy(proto->tokenbuf, parser->tokenbuf, 256, char);
-#ifdef PERL_MAD
- parser->endwhite = proto->endwhite;
- parser->faketokens = proto->faketokens;
- parser->lasttoke = proto->lasttoke;
- parser->nextwhite = proto->nextwhite;
- parser->realtokenstart = proto->realtokenstart;
- parser->skipwhite = proto->skipwhite;
- parser->thisclose = proto->thisclose;
- parser->thismad = proto->thismad;
- parser->thisopen = proto->thisopen;
- parser->thisstuff = proto->thisstuff;
- parser->thistoken = proto->thistoken;
- parser->thiswhite = proto->thiswhite;
-
- Copy(proto->nexttoke, parser->nexttoke, 5, NEXTTOKE);
- parser->curforce = proto->curforce;
-#else
Copy(proto->nextval, parser->nextval, 5, YYSTYPE);
Copy(proto->nexttype, parser->nexttype, 5, I32);
parser->nexttoke = proto->nexttoke;
-#endif
/* XXX should clone saved_curcop here, but we aren't passed
* proto_perl; so do it in perl_clone_using instead */
DIR *ret;
#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
- int rc = 0;
DIR *pwd;
const Direntry_t *dirent;
char smallbuf[256];
/* Now we should have two dir handles pointing to the same dir. */
/* Be nice to the calling code and chdir back to where we were. */
- rc = fchdir(my_dirfd(pwd));
/* XXX If this fails, then what? */
- PERL_UNUSED_VAR(rc);
+ PERL_UNUSED_RESULT(fchdir(my_dirfd(pwd)));
/* We have no need of the pwd handle any more. */
PerlDir_close(pwd);
for(;;) {
pos = PerlDir_tell(ret);
if ((dirent = PerlDir_read(ret))) {
- if (len == d_namlen(dirent)
- && memEQ(name, dirent->d_name, len)) {
+ if (len == (STRLEN)d_namlen(dirent)
+ && memEQ(name, dirent->d_name, len)) {
/* found it */
PerlDir_seek(ret, pos); /* step back */
break;
new_arena->next = tbl->tbl_arena;
tbl->tbl_arena = new_arena;
tbl->tbl_arena_next = new_arena->array;
- tbl->tbl_arena_end = new_arena->array
- + sizeof(new_arena->array) / sizeof(new_arena->array[0]);
+ tbl->tbl_arena_end = C_ARRAY_END(new_arena->array);
}
tblent = tbl->tbl_arena_next++;
void
Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl)
{
+ PERL_UNUSED_CONTEXT;
if (tbl && tbl->tbl_items) {
struct ptr_tbl_arena *arena = tbl->tbl_arena;
{
struct ptr_tbl_arena *arena;
+ PERL_UNUSED_CONTEXT;
+
if (!tbl) {
return;
}
if (!(param->flags & CLONEf_COPY_STACKS)) {
CvDEPTH(dstr) = 0;
}
- /*FALLTHROUGH*/
+ /* FALLTHROUGH */
case SVt_PVFM:
/* NOTE: not refcounted */
SvANY(MUTABLE_CV(dstr))->xcv_stash =
ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
? cv_dup_inc(ncx->blk_sub.cv, param)
: cv_dup(ncx->blk_sub.cv,param));
- ncx->blk_sub.argarray = (CxHASARGS(ncx)
- ? av_dup_inc(ncx->blk_sub.argarray,
- param)
- : NULL);
- ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
- param);
+ if(CxHASARGS(ncx)){
+ ncx->blk_sub.argarray = av_dup_inc(ncx->blk_sub.argarray,param);
+ ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,param);
+ } else {
+ ncx->blk_sub.argarray = NULL;
+ ncx->blk_sub.savearray = NULL;
+ }
ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
ncx->blk_sub.oldcomppad);
break;
case SAVEt_HELEM: /* hash element */
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
- /* fall through */
+ /* FALLTHROUGH */
case SAVEt_ITEM: /* normal string */
case SAVEt_GVSV: /* scalar slot in GV */
case SAVEt_SV: /* scalar reference */
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
- /* fall through */
+ /* FALLTHROUGH */
case SAVEt_FREESV:
case SAVEt_MORTALIZESV:
case SAVEt_READONLY_OFF:
case SAVEt_AV: /* array reference */
sv = (const SV *) POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
- /* fall through */
+ /* FALLTHROUGH */
case SAVEt_COMPPAD:
case SAVEt_NSTAB:
sv = (const SV *) POPPTR(ss,ix);
case SAVEt_VPTR: /* random* reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- /* Fall through */
+ /* FALLTHROUGH */
case SAVEt_INT_SMALL:
case SAVEt_I32_SMALL:
case SAVEt_I16: /* I16 reference */
TOPPTR(nss,ix) = hv_dup_inc(hv, param);
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
- /* Fall through */
+ /* FALLTHROUGH */
case SAVEt_FREEPV:
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup_inc(c);
PL_maxsysfd = proto_perl->Imaxsysfd;
PL_statusvalue = proto_perl->Istatusvalue;
-#ifdef VMS
+#ifdef __VMS
PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
#else
PL_statusvalue_posix = proto_perl->Istatusvalue_posix;
PL_statbuf = proto_perl->Istatbuf;
PL_statcache = proto_perl->Istatcache;
-#ifdef HAS_TIMES
- PL_timesbuf = proto_perl->Itimesbuf;
-#endif
-
#ifndef NO_TAINT_SUPPORT
PL_tainted = proto_perl->Itainted;
#else
char *
Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8;
if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
SV *ssv, int *offset, char *tstr, int tlen)
{
- dVAR;
bool ret = FALSE;
PERL_ARGS_ASSERT_SV_CAT_DECODE;
STATIC I32
S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
{
- dVAR;
-
PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
return varname(gv, '$', 0,
NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
}
- break;
+ NOT_REACHED; /* NOTREACHED */
case OP_EXISTS:
o = cUNOPx(obase)->op_first;
? '@' : '%',
o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN);
}
- break;
+ NOT_REACHED; /* NOTREACHED */
}
case OP_AASSIGN:
if ( o->op_type == OP_PUSHMARK
|| (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)
)
- o = o->op_sibling;
+ o = OP_SIBLING(o);
- if (!o->op_sibling) {
+ if (!OP_HAS_SIBLING(o)) {
/* one-arg version of open is highly magical */
if (o->op_type == OP_GV) { /* open FOO; */
&&
( o->op_type == OP_PUSHMARK
|| (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK)))
- o = o->op_sibling->op_sibling;
+ o = OP_SIBLING(OP_SIBLING(o));
goto do_op2;
case OP_CHOMP:
if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs))
return newSVpvs_flags("${$/}", SVs_TEMP);
- /*FALLTHROUGH*/
+ /* FALLTHROUGH */
default:
do_op:
* it replaced are still in the tree, so we work on them instead.
*/
o2 = NULL;
- for (kid=o; kid; kid = kid->op_sibling) {
- if (kid) {
- const OPCODE type = kid->op_type;
- if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
- || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
- || (type == OP_PUSHMARK)
- || (type == OP_PADRANGE)
- )
- continue;
- }
+ for (kid=o; kid; kid = OP_SIBLING(kid)) {
+ const OPCODE type = kid->op_type;
+ if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid)))
+ || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
+ || (type == OP_PUSHMARK)
+ || (type == OP_PADRANGE)
+ )
+ continue;
+
if (o2) { /* more than one found */
o2 = NULL;
break;
sv = find_uninit_var(o, uninit_sv, 1);
if (sv)
return sv;
- o = o->op_sibling;
+ o = OP_SIBLING(o);
}
break;
}
void
Perl_report_uninit(pTHX_ const SV *uninit_sv)
{
- dVAR;
if (PL_op) {
SV* varname = NULL;
if (uninit_sv && PL_curpad) {
https://perl5.git.perl.org / perl5.git / blobdiff