#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
/* ============================================================================
=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_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);
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);
SvSETMAGIC(sv);
}
-/* Print an "isn't numeric" warning, using a cleaned-up,
- * printable version of the offending string
+/* Return a cleaned-up, printable version of sv, for non-numeric, or
+ * not incrementable warning display.
+ * Originally part of S_not_a_number().
+ * The return value may be != tmpbuf.
*/
-STATIC void
-S_not_a_number(pTHX_ SV *const sv)
-{
- dVAR;
- SV *dsv;
- char tmpbuf[64];
- const char *pv;
+STATIC const char *
+S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
+ const char *pv;
- PERL_ARGS_ASSERT_NOT_A_NUMBER;
+ PERL_ARGS_ASSERT_SV_DISPLAY;
if (DO_UTF8(sv)) {
- dsv = newSVpvs_flags("", SVs_TEMP);
+ SV *dsv = newSVpvs_flags("", SVs_TEMP);
pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
} else {
char *d = tmpbuf;
- const char * const limit = tmpbuf + sizeof(tmpbuf) - 8;
+ const char * const limit = tmpbuf + tmpbuf_size - 8;
/* each *s can expand to 4 chars + "...\0",
i.e. need room for 8 chars */
pv = tmpbuf;
}
+ return pv;
+}
+
+/* Print an "isn't numeric" warning, using a cleaned-up,
+ * printable version of the offending string
+ */
+
+STATIC void
+S_not_a_number(pTHX_ SV *const sv)
+{
+ dVAR;
+ char tmpbuf[64];
+ const char *pv;
+
+ PERL_ARGS_ASSERT_NOT_A_NUMBER;
+
+ pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
+
if (PL_op)
Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
/* diag_listed_as: Argument "%s" isn't numeric%s */
"Argument \"%s\" isn't numeric", pv);
}
+STATIC void
+S_not_incrementable(pTHX_ SV *const sv) {
+ dVAR;
+ char tmpbuf[64];
+ const char *pv;
+
+ PERL_ARGS_ASSERT_NOT_INCREMENTABLE;
+
+ pv = sv_display(sv, tmpbuf, sizeof(tmpbuf));
+
+ Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
+ "Argument \"%s\" treated as 0 in increment (++)", pv);
+}
+
/*
=for apidoc looks_like_number
# 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;
bool
Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
{
- dVAR;
-
PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
restart:
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)) {
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:
/*
=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 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
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.
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;
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;
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;
amount left, otherwise this is the amount it
can hold. */
-#if defined(VMS) && defined(PERLIO_IS_STDIO)
+#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.
*/
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 (;;) {
/* 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)));
/*
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;
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_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
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;
}
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);
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.
SV *
Perl_newSVpv(pTHX_ const char *const s, const STRLEN len)
{
- dVAR;
SV *sv;
new_SV(sv);
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;
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;
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);
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;
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? */
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 (*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;
}
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;
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 '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 */
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;
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;
}
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;
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;
* it replaced are still in the tree, so we work on them instead.
*/
o2 = NULL;
- for (kid=o; kid; kid = kid->op_sibling) {
+ 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))
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