#include "regcomp.h"
#ifndef HAS_C99
-# if __STDC_VERSION__ >= 199901L && !defined(VMS)
+# if defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L && !defined(VMS)
# define HAS_C99 1
# endif
#endif
-#if HAS_C99
+#ifdef HAS_C99
# include <stdint.h>
#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
if (newlen < minlen)
newlen = minlen;
#ifndef Perl_safesysmalloc_size
- newlen = PERL_STRLEN_ROUNDUP(newlen);
+ if (SvLEN(sv))
+ newlen = PERL_STRLEN_ROUNDUP(newlen);
#endif
if (SvLEN(sv) && s) {
s = (char*)saferealloc(s, newlen);
SvSETMAGIC(sv);
}
-/* 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.
+/* Print an "isn't numeric" warning, using a cleaned-up,
+ * printable version of the offending string
*/
-STATIC const char *
-S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) {
- const char *pv;
+STATIC void
+S_not_a_number(pTHX_ SV *const sv)
+{
+ dVAR;
+ SV *dsv;
+ char tmpbuf[64];
+ const char *pv;
- PERL_ARGS_ASSERT_SV_DISPLAY;
+ PERL_ARGS_ASSERT_NOT_A_NUMBER;
if (DO_UTF8(sv)) {
- SV *dsv = newSVpvs_flags("", SVs_TEMP);
+ dsv = newSVpvs_flags("", SVs_TEMP);
pv = sv_uni_display(dsv, sv, 10, UNI_DISPLAY_ISPRINT);
} else {
char *d = tmpbuf;
- const char * const limit = tmpbuf + tmpbuf_size - 8;
+ const char * const limit = tmpbuf + sizeof(tmpbuf) - 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
/* 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 */
}
SvUPGRADE(dstr, SVt_PVGV);
(void)SvOK_off(dstr);
- /* We have to turn this on here, even though we turn it off
- below, as GvSTASH will fail an assertion otherwise. */
isGV_with_GP_on(dstr);
}
GvSTASH(dstr) = GvSTASH(sstr);
);
}
}
+
+ SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
}
gp_free(MUTABLE_GV(dstr));
- isGV_with_GP_off(dstr); /* SvOK_off does not like globs. */
- (void)SvOK_off(dstr);
- isGV_with_GP_on(dstr);
GvINTRO_off(dstr); /* one-shot flag */
GvGP_set(dstr, gp_ref(GvGP(sstr)));
if (SvTAINTED(sstr))
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>
-# ifndef sTHX
-# define sTHX 0
+# ifndef PERL_MEMORY_DEBUG_HEADER_SIZE
+# define PERL_MEMORY_DEBUG_HEADER_SIZE 0
# endif
void
Perl_sv_buf_to_ro(pTHX_ SV *sv)
{
struct perl_memory_debug_header * const header =
- (struct perl_memory_debug_header *)(SvPVX(sv)-sTHX);
+ (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
const MEM_SIZE len = header->size;
PERL_ARGS_ASSERT_SV_BUF_TO_RO;
# ifdef PERL_TRACK_MEMPOOL
S_sv_buf_to_rw(pTHX_ SV *sv)
{
struct perl_memory_debug_header * const header =
- (struct perl_memory_debug_header *)(SvPVX(sv)-sTHX);
+ (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE);
const MEM_SIZE len = header->size;
PERL_ARGS_ASSERT_SV_BUF_TO_RW;
if (mprotect(header, len, PROT_READ|PROT_WRITE))
reset_isa = TRUE;
}
- if (GvGP(dstr))
+ if (GvGP(dstr)) {
+ SvREFCNT_inc_simple_void_NN(sv_2mortal(dstr));
gp_free(MUTABLE_GV(dstr));
+ }
GvGP_set(dstr, gp_ref(GvGP(gv)));
if (reset_isa) {
|| ((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
raw_compare:
/*FALLTHROUGH*/
+#else
+ PERL_UNUSED_ARG(flags);
#endif /* USE_LOCALE_COLLATE */
return sv_cmp(sv1, sv2);
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))
if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
const Off_t offset = PerlIO_tell(fp);
if (offset != (Off_t) -1 && st.st_size + append > offset) {
- (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
+#ifdef PERL_NEW_COPY_ON_WRITE
+ /* Add an extra byte for the sake of copy-on-write's
+ * buffer reference count. */
+ (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2));
+#else
+ (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
+#endif
}
}
rsptr = NULL;
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;
+ 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
/* 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,
UVuf"\n",
PTR2UV(PerlIO_get_ptr(fp)), 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));
PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
- /* This used to call 'filbuf' in stdio form, but as that behaves like
- 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,
PTR2UV(PerlIO_get_ptr(fp)), 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,
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 */
while (isALPHA(*d)) d++;
while (isDIGIT(*d)) d++;
if (d < SvEND(sv)) {
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
#ifdef PERL_PRESERVE_IVUV
/* Got to punt this as an integer if needs be, but we don't issue
warnings. Probably ought to make the sv_iv_please() that does
the conversion if possible, and silently. */
+ const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL);
if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
/* Need to try really hard to see if it's an integer.
9.22337203685478e+18 is an integer.
#endif
}
#endif /* PERL_PRESERVE_IVUV */
- if (!numtype && ckWARN(WARN_NUMERIC))
- not_incrementable(sv);
sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0);
return;
}
if (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 */
return SvPV_nolen_const(sv_ref(NULL, sv, ob));
}
else {
+ /* WARNING - There is code, for instance in mg.c, that assumes that
+ * the only reason that sv_reftype(sv,0) would return a string starting
+ * with 'L' or 'S' is that it is a LVALUE or a SCALAR.
+ * Yes this a dodgy way to do type checking, but it saves practically reimplementing
+ * this routine inside other subs, and it saves time.
+ * Do not change this assumption without searching for "dodgy type check" in
+ * the code.
+ * - Yves */
switch (SvTYPE(sv)) {
case SVt_NULL:
case SVt_IV:
if (!(flags & SV_COW_DROP_PV))
gv_efullname3(temp, MUTABLE_GV(sv), "*");
+ SvREFCNT_inc_simple_void_NN(sv_2mortal(sv));
if (GvGP(sv)) {
if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv)))
&& HvNAME_get(stash))
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;
case 'V':
case 'z':
case 't':
-#if HAS_C99
+#ifdef HAS_C99
case 'j':
#endif
intsize = *q++;
/*FALLTHROUGH*/
case 'd':
case 'i':
-#if vdNUMBER
- format_vd:
-#endif
if (vectorize) {
STRLEN ulen;
if (!veclen)
case 'z': iv = va_arg(*args, SSize_t); break;
case 't': iv = va_arg(*args, ptrdiff_t); break;
default: iv = va_arg(*args, int); break;
-#if HAS_C99
+#ifdef HAS_C99
case 'j': iv = va_arg(*args, intmax_t); break;
#endif
case 'q':
case 'V': uv = va_arg(*args, UV); break;
case 'z': uv = va_arg(*args, Size_t); break;
case 't': uv = va_arg(*args, ptrdiff_t); break; /* will sign extend, but there is no uptrdiff_t, so oh well */
-#if HAS_C99
+#ifdef HAS_C99
case 'j': uv = va_arg(*args, uintmax_t); break;
#endif
default: uv = va_arg(*args, unsigned); break;
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);
eptr = PL_efloatbuf;
#ifdef USE_LOCALE_NUMERIC
+ /* If the decimal point character in the string is UTF-8, make the
+ * output utf8 */
if (PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
&& instr(eptr, SvPVX_const(PL_numeric_radix_sv)))
{
case 'V': *(va_arg(*args, IV*)) = i; break;
case 'z': *(va_arg(*args, SSize_t*)) = i; break;
case 't': *(va_arg(*args, ptrdiff_t*)) = i; break;
-#if HAS_C99
+#ifdef HAS_C99
case 'j': *(va_arg(*args, intmax_t*)) = i; break;
#endif
case 'q':
{
DIR *ret;
-#ifdef HAS_FCHDIR
- int rc = 0;
+#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
DIR *pwd;
const Direntry_t *dirent;
char smallbuf[256];
if (ret)
return ret;
-#ifdef HAS_FCHDIR
+#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
PERL_UNUSED_ARG(param);
/* 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);
return tblent ? tblent->newval : NULL;
}
-/* add a new entry to a pointer-mapping table */
+/* add a new entry to a pointer-mapping table 'tbl'. In hash terms, 'oldsv' is
+ * the key; 'newsv' is the value. The names "old" and "new" are specific to
+ * the core's typical use of ptr_tables in thread cloning. */
void
Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv)
daux->xhv_name_count = saux->xhv_name_count;
daux->xhv_fill_lazy = saux->xhv_fill_lazy;
+ daux->xhv_aux_flags = saux->xhv_aux_flags;
+#ifdef PERL_HASH_RANDOMIZE_KEYS
+ daux->xhv_rand = saux->xhv_rand;
+ daux->xhv_last_rand = saux->xhv_last_rand;
+#endif
daux->xhv_riter = saux->xhv_riter;
daux->xhv_eiter = saux->xhv_eiter
? he_dup(saux->xhv_eiter,
? av_dup_inc(ncx->blk_sub.argarray,
param)
: NULL);
- ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,
- param);
+ ncx->blk_sub.savearray = (CxHASARGS(ncx)
+ ? av_dup_inc(ncx->blk_sub.savearray,
+ param)
+ : NULL);
ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
ncx->blk_sub.oldcomppad);
break;
PL_origargc = proto_perl->Iorigargc;
PL_origargv = proto_perl->Iorigargv;
-#if !NO_TAINT_SUPPORT
+#ifndef NO_TAINT_SUPPORT
/* Set tainting stuff before PerlIO_debug can possibly get called */
PL_tainting = proto_perl->Itainting;
PL_taint_warn = proto_perl->Itaint_warn;
/* Did the locale setup indicate UTF-8? */
PL_utf8locale = proto_perl->Iutf8locale;
+ PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale;
/* Unicode features (see perlrun/-C) */
PL_unicode = proto_perl->Iunicode;
PL_statbuf = proto_perl->Istatbuf;
PL_statcache = proto_perl->Istatcache;
-#ifdef HAS_TIMES
- PL_timesbuf = proto_perl->Itimesbuf;
-#endif
-
-#if !NO_TAINT_SUPPORT
+#ifndef NO_TAINT_SUPPORT
PL_tainted = proto_perl->Itainted;
#else
PL_tainted = FALSE;
PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
- PL_HasMultiCharFold= sv_dup_inc(proto_perl->IHasMultiCharFold, param);
+ PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param);
/* utf8 character class swashes */
for (i = 0; i < POSIX_SWASH_COUNT; i++) {
/* Call the ->CLONE method, if it exists, for each of the stashes
identified by sv_dup() above.
*/
- while(av_len(param->stashes) != -1) {
+ while(av_tindex(param->stashes) != -1) {
HV* const stash = MUTABLE_HV(av_shift(param->stashes));
GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
if (cloner && GvCV(cloner)) {
AV *av = MUTABLE_AV(PAD_SV(obase->op_targ));
if (!av || SvRMAGICAL(av))
break;
- svp = av_fetch(av, (I32)obase->op_private, FALSE);
+ svp = av_fetch(av, (I8)obase->op_private, FALSE);
if (!svp || *svp != uninit_sv)
break;
}
return varname(NULL, '$', obase->op_targ,
- NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+ NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
case OP_AELEMFAST:
{
gv = cGVOPx_gv(obase);
AV *const av = GvAV(gv);
if (!av || SvRMAGICAL(av))
break;
- svp = av_fetch(av, (I32)obase->op_private, FALSE);
+ svp = av_fetch(av, (I8)obase->op_private, FALSE);
if (!svp || *svp != uninit_sv)
break;
}
return varname(gv, '$', 0,
- NULL, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY);
+ NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY);
}
break;
*/
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;
- }
+ 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;
https://perl5.git.perl.org / perl5.git / blobdiff