#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
-#define FCALL *f
-
#ifdef __Lynx__
/* Missing proto on LynxOS */
char *gconvert(double, int, int, char *);
#endif
+/* 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
&& (sv->sv_flags & mask) == flags
&& SvREFCNT(sv))
{
- (FCALL)(aTHX_ sv);
+ (*f)(aTHX_ sv);
++visited;
}
}
preceding structure in memory.)
We calculate the correction using the STRUCT_OFFSET macro on the first
-member present. If the allocated structure is smaller (no initial NV
+member present. If the allocated structure is smaller (no initial NV
actually allocated) then the net effect is to subtract the size of the NV
from the pointer, to return a new pointer as if an initial NV were actually
-allocated. (We were using structures named *_allocated for this, but
+allocated. (We were using structures named *_allocated for this, but
this turned out to be a subtle bug, because a structure without an NV
could have a lower alignment constraint, but the compiler is allowed to
optimised accesses based on the alignment constraint of the actual pointer
to the full structure, for example, using a single 64 bit load instruction
because it "knows" that two adjacent 32 bit members will be 8-byte aligned.)
-This is the same trick as was used for NV and IV bodies. Ironically it
+This is the same trick as was used for NV and IV bodies. Ironically it
doesn't need to be used for NV bodies any more, because NV is now at
-the start of the structure. IV bodies don't need it either, because
+the start of the structure. IV bodies don't need it either, because
they are no longer allocated.
In turn, the new_body_* allocators call S_new_body(), which invokes
PERL_ARGS_ASSERT_SV_GROW;
-#ifdef HAS_64K_LIMIT
- if (newlen >= 0x10000) {
- PerlIO_printf(Perl_debug_log,
- "Allocation too large: %"UVxf"\n", (UV)newlen);
- my_exit(1);
- }
-#endif /* HAS_64K_LIMIT */
if (SvROK(sv))
sv_unref(sv);
if (SvTYPE(sv) < SVt_PV) {
s = SvPVX_mutable(sv);
if (newlen > SvLEN(sv))
newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
-#ifdef HAS_64K_LIMIT
- if (newlen >= 0x10000)
- newlen = 0xFFFF;
-#endif
}
else
{
const char * const end = s + SvCUR(sv);
for ( ; s < end && d < limit; s++ ) {
int ch = *s & 0xFF;
- if (ch & 128 && !isPRINT_LC(ch)) {
+ if (! isASCII(ch) && !isPRINT_LC(ch)) {
*d++ = 'M';
*d++ = '-';
- ch &= 127;
+
+ /* Map to ASCII "equivalent" of Latin1 */
+ ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127);
}
if (ch == '\n') {
*d++ = '\\';
{
dVAR;
- if (!sv)
- return 0;
+ PERL_ARGS_ASSERT_SV_2IV_FLAGS;
assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
&& SvTYPE(sv) != SVt_PVFM);
{
dVAR;
- if (!sv)
- return 0;
+ PERL_ARGS_ASSERT_SV_2UV_FLAGS;
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
mg_get(sv);
Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags)
{
dVAR;
- if (!sv)
- return 0.0;
+
+ PERL_ARGS_ASSERT_SV_2NV_FLAGS;
+
assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
&& SvTYPE(sv) != SVt_PVFM);
if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) {
dVAR;
char *s;
- if (!sv) {
- if (lp)
- *lp = 0;
- return (char *)"";
- }
+ PERL_ARGS_ASSERT_SV_2PV_FLAGS;
+
assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV
&& SvTYPE(sv) != SVt_PVFM);
if (SvGMAGICAL(sv) && (flags & SV_GMAGIC))
/* some Xenix systems wipe out errno here */
#ifndef USE_LOCALE_NUMERIC
- Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ V_Gconvert(SvNVX(sv), NV_DIG, 0, s);
SvPOK_on(sv);
#else
- /* Gconvert always uses the current locale. That's the right thing
- * to do if we're supposed to be using locales. But otherwise, we
- * want the result to be based on the C locale, so we need to
- * change to the C locale during the Gconvert and then change back.
- * But if we're already in the C locale (PL_numeric_standard is
- * TRUE in that case), no need to do any changing */
- if (PL_numeric_standard || IN_SOME_LOCALE_FORM_RUNTIME) {
- Gconvert(SvNVX(sv), NV_DIG, 0, s);
+ {
+ DECLARE_STORE_LC_NUMERIC_SET_TO_NEEDED();
+ V_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 */
- if (! PL_numeric_standard
+ if (PL_numeric_local
&& PL_numeric_radix_sv && SvUTF8(PL_numeric_radix_sv)
&& instr(s, SvPVX_const(PL_numeric_radix_sv)))
{
SvUTF8_on(sv);
}
- }
- else {
- char *loc = savepv(setlocale(LC_NUMERIC, NULL));
- setlocale(LC_NUMERIC, "C");
- Gconvert(SvNVX(sv), NV_DIG, 0, s);
- setlocale(LC_NUMERIC, loc);
- Safefree(loc);
-
+ RESTORE_LC_NUMERIC();
}
/* We don't call SvPOK_on(), because it may come to pass that the
RESTORE_ERRNO;
while (*s) s++;
}
-#ifdef hcx
- if (s[-1] == '.')
- *--s = '\0';
-#endif
}
else if (isGV_with_GP(sv)) {
GV *const gv = MUTABLE_GV(sv);
*/
bool
-Perl_sv_2bool_flags(pTHX_ SV *const sv, const I32 flags)
+Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
{
dVAR;
PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
+ restart:
if(flags & SV_GMAGIC) SvGETMAGIC(sv);
if (!SvOK(sv))
if (SvROK(sv)) {
if (SvAMAGIC(sv)) {
SV * const tmpsv = AMG_CALLunary(sv, bool__amg);
- if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
- return cBOOL(SvTRUE(tmpsv));
+ if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) {
+ bool svb;
+ sv = tmpsv;
+ if(SvGMAGICAL(sv)) {
+ flags = SV_GMAGIC;
+ goto restart; /* call sv_2bool */
+ }
+ /* expanded SvTRUE_common(sv, (flags = 0, goto restart)) */
+ else if(!SvOK(sv)) {
+ svb = 0;
+ }
+ else if(SvPOK(sv)) {
+ svb = SvPVXtrue(sv);
+ }
+ else if((SvFLAGS(sv) & (SVf_IOK|SVf_NOK))) {
+ svb = (SvIOK(sv) && SvIVX(sv) != 0)
+ || (SvNOK(sv) && SvNVX(sv) != 0.0);
+ }
+ else {
+ flags = 0;
+ goto restart; /* call sv_2bool_nomg */
+ }
+ return cBOOL(svb);
+ }
}
return SvRV(sv) != 0;
}
if all the bytes are invariant in UTF-8.
If C<flags> has C<SV_GMAGIC> bit set,
will C<mg_get> on C<sv> if appropriate, else not.
-Returns the number of bytes in the converted string
-C<sv_utf8_upgrade> and
-C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
+
+If C<flags> has SV_FORCE_UTF8_UPGRADE set, this function assumes that the PV
+will expand when converted to UTF-8, and skips the extra work of checking for
+that. Typically this flag is used by a routine that has already parsed the
+string and found such characters, and passes this information on so that the
+work doesn't have to be repeated.
+
+Returns the number of bytes in the converted string.
This is not a general purpose byte encoding to Unicode interface:
use the Encode extension for that.
-=cut
+=for apidoc sv_utf8_upgrade_flags_grow
+
+Like sv_utf8_upgrade_flags, but has an additional parameter C<extra>, which is
+the number of unused bytes the string of 'sv' is guaranteed to have free after
+it upon return. This allows the caller to reserve extra space that it intends
+to fill, to avoid extra grows.
-The grow version is currently not externally documented. It adds a parameter,
-extra, which is the number of unused bytes the string of 'sv' is guaranteed to
-have free after it upon return. This allows the caller to reserve extra space
-that it intends to fill, to avoid extra grows.
+C<sv_utf8_upgrade>, C<sv_utf8_upgrade_nomg>, and C<sv_utf8_upgrade_flags>
+are implemented in terms of this function.
-Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE,
-which can be used to tell this function to not first check to see if there are
-any characters that are different in UTF-8 (variant characters) which would
-force it to allocate a new string to sv, but to assume there are. Typically
-this flag is used by a routine that has already parsed the string to find that
-there are such characters, and passes this information on so that the work
-doesn't have to be repeated.
+Returns the number of bytes in the converted string (not including the spares).
+
+=cut
(One might think that the calling routine could pass in the position of the
-first such variant, so it wouldn't have to be found again. But that is not the
-case, because typically when the caller is likely to use this flag, it won't be
-calling this routine unless it finds something that won't fit into a byte.
-Otherwise it tries to not upgrade 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.)
+first variant character when it has set SV_FORCE_UTF8_UPGRADE, so it wouldn't
+have to be found again. But that is not the case, because typically when the
+caller is likely to use this flag, it won't be calling this routine unless it
+finds something that won't fit into a byte. Otherwise it tries to not upgrade
+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,
while (t < e) {
const U8 ch = *t++;
- if (NATIVE_IS_INVARIANT(ch)) continue;
+ if (NATIVE_BYTE_IS_INVARIANT(ch)) continue;
t--; /* t already incremented; re-point to first variant */
two_byte_count = 1;
while (d < e) {
const U8 chr = *d++;
- if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++;
+ if (! NATIVE_BYTE_IS_INVARIANT(chr)) two_byte_count++;
}
/* The string will expand by just the number of bytes that
e--;
while (e >= t) {
- if (NATIVE_IS_INVARIANT(*e)) {
+ if (NATIVE_BYTE_IS_INVARIANT(*e)) {
*d-- = *e;
} else {
*d-- = UTF8_EIGHT_BIT_LO(*e);
Copies the contents of the source SV C<ssv> into the destination SV
C<dsv>. The source SV may be destroyed if it is mortal, so don't use this
-function if the source SV needs to be reused. Does not handle 'set' magic.
-Loosely speaking, it performs a copy-by-value, obliterating any previous
-content of the destination.
+function if the source SV needs to be reused. Does not handle 'set' magic on
+destination SV. Calls 'get' magic on source SV. Loosely speaking, it
+performs a copy-by-value, obliterating any previous content of the
+destination.
You probably want to use one of the assortment of wrappers, such as
C<SvSetSV>, C<SvSetSV_nosteal>, C<SvSetMagicSV> and
content of the destination.
If the C<flags> parameter has the C<SV_GMAGIC> bit set, will C<mg_get> on
C<ssv> if appropriate, else not. If the C<flags>
-parameter has the C<NOSTEAL> bit set then the
+parameter has the C<SV_NOSTEAL> bit set then the
buffers of temps will not be stolen. <sv_setsv>
and C<sv_setsv_nomg> are implemented in terms of this function.
}
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))
# define GE_COWBUF_THRESHOLD(len) 1
#endif
+#ifdef PERL_DEBUG_READONLY_COW
+# include <sys/mman.h>
+
+# 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)-PERL_MEMORY_DEBUG_HEADER_SIZE);
+ const MEM_SIZE len = header->size;
+ PERL_ARGS_ASSERT_SV_BUF_TO_RO;
+# ifdef PERL_TRACK_MEMPOOL
+ if (!header->readonly) header->readonly = 1;
+# endif
+ if (mprotect(header, len, PROT_READ))
+ Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
+ header, len, errno);
+}
+
+static void
+S_sv_buf_to_rw(pTHX_ SV *sv)
+{
+ struct perl_memory_debug_header * const header =
+ (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))
+ Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
+ header, len, errno);
+# ifdef PERL_TRACK_MEMPOOL
+ header->readonly = 0;
+# endif
+}
+
+#else
+# define sv_buf_to_ro(sv) NOOP
+# define sv_buf_to_rw(sv) NOOP
+#endif
+
void
Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags)
{
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) {
reg_temp_copy((REGEXP*)dstr, (REGEXP*)sstr);
}
else if (sflags & SVp_POK) {
- bool isSwipe = 0;
const STRLEN cur = SvCUR(sstr);
const STRLEN len = SvLEN(sstr);
/*
- * Check to see if we can just swipe the string. If so, it's a
- * possible small lose on short strings, but a big win on long ones.
- * It might even be a win on short strings if SvPVX_const(dstr)
- * has to be allocated and SvPVX_const(sstr) has to be freed.
- * Likewise if we can set up COW rather than doing an actual copy, we
- * drop to the else clause, as the swipe code and the COW setup code
- * have much in common.
+ * We have three basic ways to copy the string:
+ *
+ * 1. Swipe
+ * 2. Copy-on-write
+ * 3. Actual copy
+ *
+ * Which we choose is based on various factors. The following
+ * things are listed in order of speed, fastest to slowest:
+ * - Swipe
+ * - Copying a short string
+ * - Copy-on-write bookkeeping
+ * - malloc
+ * - Copying a long string
+ *
+ * We swipe the string (steal the string buffer) if the SV on the
+ * rhs is about to be freed anyway (TEMP and refcnt==1). This is a
+ * big win on long strings. It should be a win on short strings if
+ * SvPVX_const(dstr) has to be allocated. If not, it should not
+ * slow things down, as SvPVX_const(sstr) would have been freed
+ * soon anyway.
+ *
+ * We also steal the buffer from a PADTMP (operator target) if it
+ * is ‘long enough’. For short strings, a swipe does not help
+ * here, as it causes more malloc calls the next time the target
+ * is used. Benchmarks show that even if SvPVX_const(dstr) has to
+ * be allocated it is still not worth swiping PADTMPs for short
+ * strings, as the savings here are small.
+ *
+ * If the rhs is already flagged as a copy-on-write string and COW
+ * is possible here, we use copy-on-write and make both SVs share
+ * the string buffer.
+ *
+ * If the rhs is not flagged as copy-on-write, then we see whether
+ * it is worth upgrading it to such. If the lhs already has a buf-
+ * fer big enough and the string is short, we skip it and fall back
+ * to method 3, since memcpy is faster for short strings than the
+ * later bookkeeping overhead that copy-on-write entails.
+ *
+ * If there is no buffer on the left, or the buffer is too small,
+ * then we use copy-on-write.
*/
/* Whichever path we take through the next code, we want this true,
(void)SvPOK_only(dstr);
if (
- /* If we're already COW then this clause is not true, and if COW
- is allowed then we drop down to the else and make dest COW
- with us. If caller hasn't said that we're allowed to COW
- shared hash keys then we don't do the COW setup, even if the
- source scalar is a shared hash key scalar. */
- (((flags & SV_COW_SHARED_HASH_KEYS)
- ? !(sflags & SVf_IsCOW)
-#ifdef PERL_NEW_COPY_ON_WRITE
- || (len &&
- ((!GE_COWBUF_THRESHOLD(cur) && SvLEN(dstr) > cur)
- /* If this is a regular (non-hek) COW, only so many COW
- "copies" are possible. */
- || CowREFCNT(sstr) == SV_COW_REFCNT_MAX))
-#endif
- : 1 /* If making a COW copy is forbidden then the behaviour we
- desire is as if the source SV isn't actually already
- COW, even if it is. So we act as if the source flags
- are not COW, rather than actually testing them. */
- )
-#ifndef PERL_ANY_COW
- /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic
- when PERL_OLD_COPY_ON_WRITE is defined a little wrong.
- Conceptually PERL_OLD_COPY_ON_WRITE being defined should
- override SV_COW_SHARED_HASH_KEYS, because it means "always COW"
- but in turn, it's somewhat dead code, never expected to go
- live, but more kept as a placeholder on how to do it better
- in a newer implementation. */
- /* If we are COW and dstr is a suitable target then we drop down
- into the else and make dest a COW of us. */
- || (SvFLAGS(dstr) & SVf_BREAK)
-#endif
- )
- &&
- !(isSwipe =
-#ifdef PERL_NEW_COPY_ON_WRITE
+ ( /* Either ... */
/* slated for free anyway (and not COW)? */
- (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP &&
-#else
- (sflags & SVs_TEMP) && /* slated for free anyway? */
-#endif
+ (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP
+ /* or a swipable TARG */
+ || ((sflags & (SVs_PADTMP|SVf_READONLY|SVf_IsCOW))
+ == SVs_PADTMP
+ /* whose buffer is worth stealing */
+ && GE_COWBUF_THRESHOLD(cur)
+ )
+ ) &&
!(sflags & SVf_OOK) && /* and not involved in OOK hack? */
(!(flags & SV_NOSTEAL)) &&
/* and we're allowed to steal temps */
SvREFCNT(sstr) == 1 && /* and no other references to it? */
len) /* and really is a string */
-#ifdef PERL_ANY_COW
- && ((flags & SV_COW_SHARED_HASH_KEYS)
- ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS
-# ifdef PERL_OLD_COPY_ON_WRITE
+ { /* Passes the swipe test. */
+ if (SvPVX_const(dstr)) /* we know that dtype >= SVt_PV */
+ SvPV_free(dstr);
+ SvPV_set(dstr, SvPVX_mutable(sstr));
+ SvLEN_set(dstr, SvLEN(sstr));
+ SvCUR_set(dstr, SvCUR(sstr));
+
+ SvTEMP_off(dstr);
+ (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
+ SvPV_set(sstr, NULL);
+ SvLEN_set(sstr, 0);
+ SvCUR_set(sstr, 0);
+ SvTEMP_off(sstr);
+ }
+ else if (flags & SV_COW_SHARED_HASH_KEYS
+ &&
+#ifdef PERL_OLD_COPY_ON_WRITE
+ ( sflags & SVf_IsCOW
+ || ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS
&& (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS
&& SvTYPE(sstr) >= SVt_PVIV && len
-# else
+ )
+ )
+#elif defined(PERL_NEW_COPY_ON_WRITE)
+ (sflags & SVf_IsCOW
+ ? (!len ||
+ ( (GE_COWBUF_THRESHOLD(cur) || 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)
- && !(sflags & SVf_IsCOW)
&& GE_COW_THRESHOLD(cur) && cur+1 < len
&& (GE_COWBUF_THRESHOLD(cur) || SvLEN(dstr) < cur+1)
-# endif
))
- : 1)
+#else
+ sflags & SVf_IsCOW
+ && !(SvFLAGS(dstr) & SVf_BREAK)
#endif
) {
- /* Failed the swipe test, and it's not a shared hash key either.
- Have to copy the string. */
- SvGROW(dstr, cur + 1); /* inlined from sv_setpvn */
- Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
- SvCUR_set(dstr, cur);
- *SvEND(dstr) = '\0';
- } else {
- /* If PERL_OLD_COPY_ON_WRITE is not defined, then isSwipe will always
- be true in here. */
/* Either it's a shared hash key, or it's suitable for
- copy-on-write or we can swipe the string. */
+ copy-on-write. */
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
sv_dump(sstr);
sv_dump(dstr);
}
#ifdef PERL_ANY_COW
- if (!isSwipe) {
- if (!(sflags & SVf_IsCOW)) {
+ if (!(sflags & SVf_IsCOW)) {
SvIsCOW_on(sstr);
# ifdef PERL_OLD_COPY_ON_WRITE
/* Make the source SV into a loop of 1.
# else
CowREFCNT(sstr) = 0;
# endif
- }
}
#endif
- /* Initial code is common. */
if (SvPVX_const(dstr)) { /* we know that dtype >= SVt_PV */
SvPV_free(dstr);
}
- if (!isSwipe) {
- /* making another shared SV. */
#ifdef PERL_ANY_COW
- if (len) {
+ if (len) {
# ifdef PERL_OLD_COPY_ON_WRITE
assert (SvTYPE(dstr) >= SVt_PVIV);
/* SvIsCOW_normal */
SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
SV_COW_NEXT_SV_SET(sstr, dstr);
# else
+ if (sflags & SVf_IsCOW) {
+ sv_buf_to_rw(sstr);
+ }
CowREFCNT(sstr)++;
# endif
SvPV_set(dstr, SvPVX_mutable(sstr));
- } else
+ sv_buf_to_ro(sstr);
+ } else
#endif
- {
+ {
/* SvIsCOW_shared_hash */
DEBUG_C(PerlIO_printf(Perl_debug_log,
"Copy on write: Sharing hash\n"));
assert (SvTYPE(dstr) >= SVt_PV);
SvPV_set(dstr,
HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sstr)))));
- }
- SvLEN_set(dstr, len);
- SvCUR_set(dstr, cur);
- SvIsCOW_on(dstr);
- }
- else
- { /* Passes the swipe test. */
- SvPV_set(dstr, SvPVX_mutable(sstr));
- SvLEN_set(dstr, SvLEN(sstr));
- SvCUR_set(dstr, SvCUR(sstr));
-
- SvTEMP_off(dstr);
- (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
- SvPV_set(sstr, NULL);
- SvLEN_set(sstr, 0);
- SvCUR_set(sstr, 0);
- SvTEMP_off(sstr);
- }
+ }
+ SvLEN_set(dstr, len);
+ SvCUR_set(dstr, cur);
+ SvIsCOW_on(dstr);
+ } else {
+ /* Failed the swipe test, and we cannot do copy-on-write either.
+ Have to copy the string. */
+ SvGROW(dstr, cur + 1); /* inlined from sv_setpvn */
+ Move(SvPVX_const(sstr),SvPVX(dstr),cur,char);
+ SvCUR_set(dstr, cur);
+ *SvEND(dstr) = '\0';
}
if (sflags & SVp_NOK) {
SvNV_set(dstr, SvNVX(sstr));
STRLEN cur = SvCUR(sstr);
STRLEN len = SvLEN(sstr);
char *new_pv;
+#if defined(PERL_DEBUG_READONLY_COW) && defined(PERL_NEW_COPY_ON_WRITE)
+ const bool already = cBOOL(SvIsCOW(sstr));
+#endif
PERL_ARGS_ASSERT_SV_SETSV_COW;
# ifdef PERL_OLD_COPY_ON_WRITE
SV_COW_NEXT_SV_SET(sstr, dstr);
# else
+# ifdef PERL_DEBUG_READONLY_COW
+ if (already) sv_buf_to_rw(sstr);
+# endif
CowREFCNT(sstr)++;
# endif
new_pv = SvPVX_mutable(sstr);
+ sv_buf_to_ro(sstr);
common_exit:
SvPV_set(dstr, new_pv);
in the loop.)
Hence other SV is no longer copy on write either. */
SvIsCOW_off(after);
+ sv_buf_to_rw(after);
} else {
/* We need to follow the pointers around the loop. */
SV *next;
when unreffing. C<sv_force_normal> calls this function
with flags set to 0.
+This function is expected to be used to signal to perl that this SV is
+about to be written to, and any extra book-keeping needs to be taken care
+of. Hence, it croaks on read-only values.
+
=cut
*/
# ifdef PERL_NEW_COPY_ON_WRITE
if (len && CowREFCNT(sv) == 0)
/* We own the buffer ourselves. */
- NOOP;
+ sv_buf_to_rw(sv);
else
# endif
{
/* This SV doesn't own the buffer, so need to Newx() a new one: */
# ifdef PERL_NEW_COPY_ON_WRITE
/* Must do this first, since the macro uses SvPVX. */
- if (len) CowREFCNT(sv)--;
+ if (len) {
+ sv_buf_to_rw(sv);
+ CowREFCNT(sv)--;
+ sv_buf_to_ro(sv);
+ }
# endif
SvPV_set(sv, NULL);
SvLEN_set(sv, 0);
if (SvTYPE(tsv) == SVt_PVHV) {
svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv));
} else {
- if (! ((mg =
- (SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL))))
- {
- sv_magic(tsv, NULL, PERL_MAGIC_backref, NULL, 0);
- mg = mg_find(tsv, PERL_MAGIC_backref);
- }
+ if (SvMAGICAL(tsv))
+ mg = mg_find(tsv, PERL_MAGIC_backref);
+ if (!mg)
+ mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0);
svp = &(mg->mg_obj);
}
|| (*svp && SvTYPE(*svp) != SVt_PVAV)
) {
/* create array */
+ if (mg)
+ mg->mg_flags |= MGf_REFCOUNTED;
av = newAV();
AvREAL_off(av);
- SvREFCNT_inc_simple_void(av);
+ SvREFCNT_inc_simple_void_NN(av);
/* av now has a refcnt of 2; see discussion above */
+ av_extend(av, *svp ? 2 : 1);
if (*svp) {
/* move single existing backref to the array */
- av_extend(av, 1);
AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */
}
*svp = (SV*)av;
- if (mg)
- mg->mg_flags |= MGf_REFCOUNTED;
}
- else
+ else {
av = MUTABLE_AV(*svp);
-
- if (!av) {
- /* optimisation: store single backref directly in HvAUX or mg_obj */
- *svp = sv;
- return;
+ if (!av) {
+ /* optimisation: store single backref directly in HvAUX or mg_obj */
+ *svp = sv;
+ return;
+ }
+ assert(SvTYPE(av) == SVt_PVAV);
+ if (AvFILLp(av) >= AvMAX(av)) {
+ av_extend(av, AvFILLp(av)+1);
+ }
}
/* push new backref */
- assert(SvTYPE(av) == SVt_PVAV);
- if (AvFILLp(av) >= AvMAX(av)) {
- av_extend(av, AvFILLp(av)+1);
- }
AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
}
if (PL_stashcache) {
DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
sv));
- (void)hv_delete(PL_stashcache, name,
- HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) : HvNAMELEN_get((HV*)sv), G_DISCARD);
+ (void)hv_deletehek(PL_stashcache,
+ HvNAME_HEK((HV*)sv), G_DISCARD);
}
hv_name_set((HV*)sv, NULL, 0, 0);
}
sv_release_COW(sv, SvPVX_const(sv), SV_COW_NEXT_SV(sv));
# else
if (CowREFCNT(sv)) {
+ sv_buf_to_rw(sv);
CowREFCNT(sv)--;
+ sv_buf_to_ro(sv);
SvLEN_set(sv, 0);
}
# endif
raw_compare:
/*FALLTHROUGH*/
+#else
+ PERL_UNUSED_ARG(flags);
#endif /* USE_LOCALE_COLLATE */
return sv_cmp(sv1, sv2);
=for apidoc sv_gets
Get a line from the filehandle and store it into the SV, optionally
-appending to the currently-stored string. If C<append> is not 0, the
-line is appended to the SV instead of overwriting it. C<append> should
+appending to the currently-stored string.
If C<append> is not 0, the
+line is appended to the SV instead of overwriting it.
C<append> should
be set to the byte offset that the appended string should start at
in the SV (typically, C<SvCUR(sv)> is a suitable choice).
STRLEN rslen;
STDCHAR rslast;
STDCHAR *bp;
- I32 cnt;
- I32 i = 0;
- I32 rspara = 0;
+ SSize_t cnt;
+ int i = 0;
+ int rspara = 0;
PERL_ARGS_ASSERT_SV_GETS;
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;
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%zd, base=%"
+ UVuf"\n",
+ PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
for (;;) {
screamer:
cannot_be_shortbuffered:
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
- PTR2UV(ptr),(long)cnt));
+ "Screamer: going to getc, ptr=%"UVuf", cnt=%zd\n",
+ PTR2UV(ptr),cnt));
PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
DEBUG_Pv(PerlIO_printf(Perl_debug_log,
- "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n",
+ PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
/* This used to call 'filbuf' in stdio form, but as that behaves like
i = PerlIO_getc(fp); /* get more characters */
DEBUG_Pv(PerlIO_printf(Perl_debug_log,
- "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf"\n",
+ PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
cnt = PerlIO_get_cnt(fp);
ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
+ "Screamer: after getc, ptr=%"UVuf", cnt=%zd\n",
+ PTR2UV(ptr),cnt));
if (i == EOF) /* all done for ever? */
goto thats_really_all_folks;
if (shortbuffered)
cnt += shortbuffered;
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
+ "Screamer: quitting, ptr=%"UVuf", cnt=%zd\n",PTR2UV(ptr),cnt));
PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
- PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
+ "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%zd, base=%"UVuf
+ "\n",
+ PTR2UV(PerlIO_get_ptr(fp)), PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
*bp = '\0';
SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */
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:
Creates a new SV for the existing RV, C<rv>, to point to. If C<rv> is not an
RV then it will be upgraded to one. If C<classname> is non-null then the new
SV will be blessed in the specified package. The new SV is returned and its
-reference count is 1. The reference count 1 is owned by C<rv>.
+reference count is 1. The reference count 1 is owned by C<rv>.
=cut
*/
return sv;
}
+SV *
+Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible)
+{
+ SV * const lv = newSV_type(SVt_PVLV);
+ PERL_ARGS_ASSERT_NEWSVAVDEFELEM;
+ LvTYPE(lv) = 'y';
+ sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
+ LvTARG(lv) = SvREFCNT_inc_simple_NN(av);
+ LvSTARGOFF(lv) = ix;
+ LvTARGLEN(lv) = extendible ? 1 : (STRLEN)UV_MAX;
+ return lv;
+}
+
/*
=for apidoc sv_setref_pv
{
dVAR;
SV *tmpRef;
+ HV *oldstash = NULL;
PERL_ARGS_ASSERT_SV_BLESS;
if (SvREADONLY(tmpRef))
Perl_croak_no_modify();
if (SvOBJECT(tmpRef)) {
- SvREFCNT_dec(SvSTASH(tmpRef));
+ oldstash = SvSTASH(tmpRef);
}
}
SvOBJECT_on(tmpRef);
SvUPGRADE(tmpRef, SVt_PVMG);
SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash)));
+ SvREFCNT_dec(oldstash);
if(SvSMAGICAL(tmpRef))
if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
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))
PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT;
va_start(args, pat);
- sv_vcatpvf(sv, pat, &args);
+ sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
va_end(args);
}
PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT;
va_start(args, pat);
- sv_vcatpvf_mg(sv, pat, &args);
+ sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
+ SvSETMAGIC(sv);
va_end(args);
}
#endif
PERL_ARGS_ASSERT_SV_CATPVF;
va_start(args, pat);
- sv_vcatpvf(sv, pat, &args);
+ sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
va_end(args);
}
{
PERL_ARGS_ASSERT_SV_VCATPVF;
- sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL);
+ sv_vcatpvfn_flags(sv, pat, strlen(pat), args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
}
/*
PERL_ARGS_ASSERT_SV_CATPVF_MG;
va_start(args, pat);
- sv_vcatpvf_mg(sv, pat, &args);
+ sv_vcatpvfn_flags(sv, pat, strlen(pat), &args, NULL, 0, NULL, SV_GMAGIC|SV_SMAGIC);
+ SvSETMAGIC(sv);
va_end(args);
}
/* large enough for "%#.#f" --chip */
/* what about long double NVs? --jhi */
+ DECLARATION_FOR_STORE_LC_NUMERIC_SET_TO_NEEDED;
+
PERL_ARGS_ASSERT_SV_VCATPVFN_FLAGS;
PERL_UNUSED_ARG(maybe_tainted);
a Configure test for this. */
if (digits && digits < sizeof(ebuf) - NV_DIG - 10) {
/* 0, point, slack */
- Gconvert(nv, (int)digits, 0, ebuf);
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
+ V_Gconvert(nv, (int)digits, 0, ebuf);
sv_catpv_nomg(sv, ebuf);
if (*ebuf) /* May return an empty string for digits==0 */
return;
q++;
break;
#endif
-#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
+#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
case 'L': /* Ld */
/*FALLTHROUGH*/
-#ifdef HAS_QUAD
+#if IVSIZE >= 8
case 'q': /* qd */
#endif
intsize = 'q';
#endif
case 'l':
++q;
-#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
+#if IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)
if (*q == 'l') { /* lld, llf */
intsize = 'q';
++q;
case 'V':
case 'z':
case 't':
-#if HAS_C99
+#ifdef HAS_C99
case 'j':
#endif
intsize = *q++;
goto unknown;
uv = (args) ? va_arg(*args, int) : SvIV(argsv);
if ((uv > 255 ||
- (!NATIVE_IS_INVARIANT(uv) && SvUTF8(sv)))
+ (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv)))
&& !IN_BYTES) {
eptr = (char*)utf8buf;
elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
/*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':
-#ifdef HAS_QUAD
+#if IVSIZE >= 8
iv = va_arg(*args, Quad_t); break;
#else
goto unknown;
case 'V':
default: iv = tiv; break;
case 'q':
-#ifdef HAS_QUAD
+#if IVSIZE >= 8
iv = (Quad_t)tiv; break;
#else
goto unknown;
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;
case 'q':
-#ifdef HAS_QUAD
+#if IVSIZE >= 8
uv = va_arg(*args, Uquad_t); break;
#else
goto unknown;
case 'V':
default: uv = tuv; break;
case 'q':
-#ifdef HAS_QUAD
+#if IVSIZE >= 8
uv = (Uquad_t)tuv; break;
#else
goto unknown;
/* See earlier comment about buggy Gconvert when digits,
aka precis is 0 */
if ( c == 'g' && precis) {
- Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
+ V_Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf);
/* May return an empty string for digits==0 */
if (*PL_efloatbuf) {
elen = strlen(PL_efloatbuf);
/* No taint. Otherwise we are in the strange situation
* where printf() taints but print($float) doesn't.
* --jhi */
+
+ STORE_LC_NUMERIC_SET_TO_NEEDED();
+
+ /* hopefully the above makes ptr a very constrained format
+ * 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)
#else
elen = my_sprintf(PL_efloatbuf, ptr, nv);
#endif
+ GCC_DIAG_RESTORE;
}
float_converted:
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':
-#ifdef HAS_QUAD
+#if IVSIZE >= 8
*(va_arg(*args, Quad_t*)) = i; break;
#else
goto unknown;
}
}
SvTAINT(sv);
+
+ RESTORE_LC_NUMERIC(); /* Done outside loop, so don't have to save/restore
+ each iteration. */
}
/* =========================================================================
{
DIR *ret;
-#ifdef HAS_FCHDIR
+#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
+ int rc = 0;
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. */
- fchdir(my_dirfd(pwd)); /* If this fails, then what? */
+ rc = fchdir(my_dirfd(pwd));
+ /* XXX If this fails, then what? */
+ PERL_UNUSED_VAR(rc);
/* 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,
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_last_swash_slen = 0;
PL_srand_called = proto_perl->Isrand_called;
+ Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE);
if (flags & CLONEf_COPY_STACKS) {
/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
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;
PerlIO_clone(aTHX_ proto_perl, param);
#endif
- PL_envgv = gv_dup(proto_perl->Ienvgv, param);
- PL_incgv = gv_dup(proto_perl->Iincgv, param);
- PL_hintgv = gv_dup(proto_perl->Ihintgv, param);
+ PL_envgv = gv_dup_inc(proto_perl->Ienvgv, param);
+ PL_incgv = gv_dup_inc(proto_perl->Iincgv, param);
+ PL_hintgv = gv_dup_inc(proto_perl->Ihintgv, param);
PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
PL_stdingv = gv_dup(proto_perl->Istdingv, param);
PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
PL_defgv = gv_dup(proto_perl->Idefgv, param);
- PL_argvgv = gv_dup(proto_perl->Iargvgv, param);
+ PL_argvgv = gv_dup_inc(proto_perl->Iargvgv, param);
PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv, param);
PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack, param);
/* shortcuts to regexp stuff */
- PL_replgv = gv_dup(proto_perl->Ireplgv, param);
+ PL_replgv = gv_dup_inc(proto_perl->Ireplgv, param);
/* shortcuts to misc objects */
PL_errgv = gv_dup(proto_perl->Ierrgv, param);
/* shortcuts to debugging objects */
- PL_DBgv = gv_dup(proto_perl->IDBgv, param);
- PL_DBline = gv_dup(proto_perl->IDBline, param);
- PL_DBsub = gv_dup(proto_perl->IDBsub, param);
+ PL_DBgv = gv_dup_inc(proto_perl->IDBgv, param);
+ PL_DBline = gv_dup_inc(proto_perl->IDBline, param);
+ PL_DBsub = gv_dup_inc(proto_perl->IDBsub, param);
PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
#endif /* !USE_LOCALE_NUMERIC */
/* Unicode inversion lists */
- PL_ASCII = sv_dup_inc(proto_perl->IASCII, param);
PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
+ PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param);
PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param);
PL_NonL1NonFinalFold = sv_dup_inc(proto_perl->INonL1NonFinalFold, param);
- PL_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++) {
PL_utf8_swash_ptrs[i] = sv_dup_inc(proto_perl->Iutf8_swash_ptrs[i], param);
}
for (i = 0; i < POSIX_CC_COUNT; i++) {
- PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param);
- PL_L1Posix_ptrs[i] = sv_dup_inc(proto_perl->IL1Posix_ptrs[i], param);
PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param);
}
PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
PL_errors = sv_dup_inc(proto_perl->Ierrors, param);
PL_sortcop = (OP*)any_dup(proto_perl->Isortcop, proto_perl);
- PL_firstgv = gv_dup(proto_perl->Ifirstgv, param);
- PL_secondgv = gv_dup(proto_perl->Isecondgv, param);
+ PL_firstgv = gv_dup_inc(proto_perl->Ifirstgv, param);
+ PL_secondgv = gv_dup_inc(proto_perl->Isecondgv, param);
PL_stashcache = newHV();
/* 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)) {
STRLEN len;
const char *s;
dSP;
+ SV *nsv = sv;
ENTER;
+ PUSHSTACK;
SAVETMPS;
+ if (SvPADTMP(nsv)) {
+ nsv = sv_newmortal();
+ SvSetSV_nosteal(nsv, sv);
+ }
save_re_context();
PUSHMARK(sp);
EXTEND(SP, 3);
PUSHs(encoding);
- PUSHs(sv);
+ PUSHs(nsv);
/*
NI-S 2002/07/09
Passing sv_yes is wrong - it needs to be or'ed set of constants
SvCUR_set(sv, len);
}
FREETMPS;
+ POPSTACK;
LEAVE;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
/* clear pos and any utf8 cache */
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;
if (varname)
sv_insert(varname, 0, 0, " ", 1);
}
+ /* PL_warn_uninit_sv is constant */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
/* diag_listed_as: Use of uninitialized value%s */
Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit_sv,
SVfARG(varname ? varname : &PL_sv_no),
" in ", OP_DESC(PL_op));
+ GCC_DIAG_RESTORE;
}
- else
+ else {
+ /* PL_warn_uninit is constant */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
"", "", "");
+ GCC_DIAG_RESTORE;
+ }
}
/*
https://perl5.git.perl.org / perl5.git / blobdiff