* lib/utf8.t lib/Unicode/Collate/t/index.t
* --jhi
*/
-#define ASSERT_UTF8_CACHE(cache) \
+# define ASSERT_UTF8_CACHE(cache) \
STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
assert((cache)[2] <= (cache)[3]); \
assert((cache)[3] <= (cache)[1]);} \
} STMT_END
#else
-#define ASSERT_UTF8_CACHE(cache) NOOP
+# define ASSERT_UTF8_CACHE(cache) NOOP
#endif
#ifdef PERL_OLD_COPY_ON_WRITE
# define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
/* Whilst I'd love to do this, it seems that things like to check on
unreferenced scalars
-# define POSION_SV_HEAD(sv) Poison(sv, 1, struct STRUCT_SV)
+# define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
*/
-# define POSION_SV_HEAD(sv) Poison(&SvANY(sv), 1, void *), \
- Poison(&SvREFCNT(sv), 1, U32)
+# define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
+ PoisonNew(&SvREFCNT(sv), 1, U32)
#else
# define SvARENA_CHAIN(sv) SvANY(sv)
# define POSION_SV_HEAD(sv)
void*
Perl_get_arena(pTHX_ int arena_size)
{
+ dVAR;
struct arena_desc* adesc;
struct arena_set *newroot, **aroot = (struct arena_set**) &PL_body_arenas;
int curr;
newroot->set_size = ARENAS_PER_SET;
newroot->next = *aroot;
*aroot = newroot;
- DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", *aroot));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)*aroot));
}
/* ok, now have arena-set with at least 1 empty/available arena-desc */
#define new_NOARENAZ(details) \
my_safecalloc((details)->body_size + (details)->offset)
-#ifdef DEBUGGING
+#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
static bool done_sanity_check;
#endif
assert(bdp->arena_size);
-#ifdef DEBUGGING
+#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE)
+ /* PERL_GLOBAL_STRUCT_PRIVATE cannot coexist with global
+ * variables like done_sanity_check. */
if (!done_sanity_check) {
unsigned int i = SVt_LAST;
/* computed count doesnt reflect the 1st slot reservation */
DEBUG_m(PerlIO_printf(Perl_debug_log,
"arena %p end %p arena-size %d type %d size %d ct %d\n",
- start, end, bdp->arena_size, sv_type, body_size,
- bdp->arena_size / body_size));
+ start, end,
+ (int)bdp->arena_size, sv_type, (int)body_size,
+ (int)bdp->arena_size / (int)body_size));
*root = (void *)start;
STMT_START { \
void ** const r3wt = &PL_body_roots[sv_type]; \
LOCK_SV_MUTEX; \
- xpv = *((void **)(r3wt)) \
- ? *((void **)(r3wt)) : S_more_bodies(aTHX_ sv_type); \
+ xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \
+ ? *((void **)(r3wt)) : more_bodies(sv_type)); \
*(r3wt) = *(void**)(xpv); \
UNLOCK_SV_MUTEX; \
} STMT_END
*/
void
-Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type)
+Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type)
{
dVAR;
void* old_body;
void* new_body;
- const U32 old_type = SvTYPE(sv);
+ const svtype old_type = SvTYPE(sv);
const struct body_details *new_type_details;
const struct body_details *const old_type_details
= bodies_by_type + old_type;
int length = old_type_details->copy;
if (new_type_details->offset > old_type_details->offset) {
- int difference
+ const int difference
= new_type_details->offset - old_type_details->offset;
offset += difference;
length -= difference;
return s;
} else
#endif
- s = saferealloc(s, newlen);
+ s = (char*)saferealloc(s, newlen);
}
else {
- s = safemalloc(newlen);
+ s = (char*)safemalloc(newlen);
if (SvPVX_const(sv) && SvCUR(sv)) {
Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
}
case SVt_PVIO:
Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
OP_DESC(PL_op));
+ default: NOOP;
}
(void)SvIOK_only(sv); /* validate number */
SvIV_set(sv, i);
case SVt_PVIO:
Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
OP_NAME(PL_op));
+ default: NOOP;
}
SvNV_set(sv, num);
(void)SvNOK_only(sv); /* validate number */
return grok_number(sbegin, len, NULL);
}
+STATIC bool
+S_glob_2number(pTHX_ GV * const gv)
+{
+ const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
+ SV *const buffer = sv_newmortal();
+
+ /* FAKE globs can get coerced, so need to turn this off temporarily if it
+ is on. */
+ SvFAKE_off(gv);
+ gv_efullname3(buffer, gv, "*");
+ SvFLAGS(gv) |= wasfake;
+
+ /* We know that all GVs stringify to something that is not-a-number,
+ so no need to test that. */
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(buffer);
+ /* We just want something true to return, so that S_sv_2iuv_common
+ can tail call us and return true. */
+ return TRUE;
+}
+
STATIC char *
-S_glob_2inpuv(pTHX_ GV *gv, STRLEN *len, bool want_number)
+S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len)
{
const U32 wasfake = SvFLAGS(gv) & SVf_FAKE;
SV *const buffer = sv_newmortal();
gv_efullname3(buffer, gv, "*");
SvFLAGS(gv) |= wasfake;
- if (want_number) {
- /* We know that all GVs stringify to something that is not-a-number,
- so no need to test that. */
- if (ckWARN(WARN_NUMERIC))
- not_a_number(buffer);
- /* We just want something true to return, so that S_sv_2iuv_common
- can tail call us and return true. */
- return (char *) 1;
- } else {
- return SvPV(buffer, *len);
+ assert(SvPOK(buffer));
+ if (len) {
+ *len = SvCUR(buffer);
}
+ return SvPVX(buffer);
}
/* Actually, ISO C leaves conversion of UV to IV undefined, but
S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
{
dVAR;
+ PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */
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) {
(void)SvIOKp_on(sv);
if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
SvIOK_on(sv);
} else {
- /*EMPTY*/; /* Integer is imprecise. NOK, IOKp */
+ NOOP; /* Integer is imprecise. NOK, IOKp */
}
/* UV will not work better than IV */
} else {
if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
SvIOK_on(sv);
} else {
- /*EMPTY*/; /* Integer is imprecise. NOK, IOKp, is UV */
+ NOOP; /* Integer is imprecise. NOK, IOKp, is UV */
}
}
SvIsUV_on(sv);
}
}
else {
- if (isGV_with_GP(sv)) {
- return (bool)PTR2IV(glob_2inpuv((GV *)sv, NULL, TRUE));
- }
+ if (isGV_with_GP(sv))
+ return glob_2number((GV *)sv);
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
if (!PL_localizing && ckWARN(WARN_UNINITIALIZED))
}
else {
if (isGV_with_GP(sv)) {
- glob_2inpuv((GV *)sv, NULL, TRUE);
+ glob_2number((GV *)sv);
return 0.0;
}
STRLEN len;
if (SvIOKp(sv)) {
- len = SvIsUV(sv) ? my_sprintf(tbuf,"%"UVuf, (UV)SvUVX(sv))
- : my_sprintf(tbuf,"%"IVdf, (IV)SvIVX(sv));
+ len = SvIsUV(sv)
+ ? my_snprintf(tbuf, sizeof(tbuf), "%"UVuf, (UV)SvUVX(sv))
+ : my_snprintf(tbuf, sizeof(tbuf), "%"IVdf, (IV)SvIVX(sv));
} else {
Gconvert(SvNVX(sv), NV_DIG, 0, tbuf);
len = strlen(tbuf);
s = SvGROW_mutable(sv, len + 1);
SvCUR_set(sv, len);
SvPOKp_on(sv);
- return memcpy(s, tbuf, len + 1);
+ return (char*)memcpy(s, tbuf, len + 1);
}
}
if (SvROK(sv)) {
}
}
{
- SV *tsv;
+ STRLEN len;
+ char *retval;
+ char *buffer;
MAGIC *mg;
const SV *const referent = (SV*)SvRV(sv);
if (!referent) {
- tsv = sv_2mortal(newSVpvs("NULLREF"));
+ len = 7;
+ retval = buffer = savepvn("NULLREF", len);
} else if (SvTYPE(referent) == SVt_PVMG
&& ((SvFLAGS(referent) &
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
return stringify_regexp(sv, mg, lp);
} else {
const char *const typestr = sv_reftype(referent, 0);
+ const STRLEN typelen = strlen(typestr);
+ UV addr = PTR2UV(referent);
+ const char *stashname = NULL;
+ STRLEN stashnamelen = 0; /* hush, gcc */
+ const char *buffer_end;
- tsv = sv_newmortal();
if (SvOBJECT(referent)) {
- const char *const name = HvNAME_get(SvSTASH(referent));
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")",
- name ? name : "__ANON__" , typestr,
- PTR2UV(referent));
+ const HEK *const name = HvNAME_HEK(SvSTASH(referent));
+
+ if (name) {
+ stashname = HEK_KEY(name);
+ stashnamelen = HEK_LEN(name);
+
+ if (HEK_UTF8(name)) {
+ SvUTF8_on(sv);
+ } else {
+ SvUTF8_off(sv);
+ }
+ } else {
+ stashname = "__ANON__";
+ stashnamelen = 8;
+ }
+ len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
+ } else {
+ len = typelen + 3 /* (0x */
+ + 2 * sizeof(UV) + 2 /* )\0 */;
}
- else
- Perl_sv_setpvf(aTHX_ tsv, "%s(0x%"UVxf")", typestr,
- PTR2UV(referent));
+
+ Newx(buffer, len, char);
+ buffer_end = retval = buffer + len;
+
+ /* Working backwards */
+ *--retval = '\0';
+ *--retval = ')';
+ do {
+ *--retval = PL_hexdigit[addr & 15];
+ } while (addr >>= 4);
+ *--retval = 'x';
+ *--retval = '0';
+ *--retval = '(';
+
+ retval -= typelen;
+ memcpy(retval, typestr, typelen);
+
+ if (stashname) {
+ *--retval = '=';
+ retval -= stashnamelen;
+ memcpy(retval, stashname, stashnamelen);
+ }
+ /* retval may not neccesarily have reached the start of the
+ buffer here. */
+ assert (retval >= buffer);
+
+ len = buffer_end - retval - 1; /* -1 for that \0 */
}
if (lp)
- *lp = SvCUR(tsv);
- return SvPVX(tsv);
+ *lp = len;
+ SAVEFREEPV(buffer);
+ return retval;
}
}
if (SvREADONLY(sv) && !SvOK(sv)) {
/* some Xenix systems wipe out errno here */
#ifdef apollo
if (SvNVX(sv) == 0.0)
- (void)strcpy(s,"0");
+ my_strlcpy(s, "0", SvLEN(sv));
else
#endif /*apollo*/
{
errno = olderrno;
#ifdef FIXNEGATIVEZERO
if (*s == '-' && s[1] == '0' && !s[2])
- strcpy(s,"0");
+ my_strlcpy(s, "0", SvLEN(s));
#endif
while (*s) s++;
#ifdef hcx
#endif
}
else {
- if (isGV_with_GP(sv)) {
- return glob_2inpuv((GV *)sv, lp, FALSE);
- }
+ if (isGV_with_GP(sv))
+ return glob_2pv((GV *)sv, lp);
if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
void
Perl_sv_utf8_encode(pTHX_ register SV *sv)
{
- (void) sv_utf8_upgrade(sv);
if (SvIsCOW(sv)) {
sv_force_normal_flags(sv, 0);
}
if (SvREADONLY(sv)) {
Perl_croak(aTHX_ PL_no_modify);
}
+ (void) sv_utf8_upgrade(sv);
SvUTF8_off(sv);
}
it was a const and its value changed. */
if (CvCONST(cv) && CvCONST((CV*)sref)
&& cv_const_sv(cv) == cv_const_sv((CV*)sref)) {
- /*EMPTY*/
+ NOOP;
/* They are 2 constant subroutines generated from
the same constant. This probably means that
they are really the "same" proxy subroutine
|| sv_cmp(cv_const_sv(cv),
cv_const_sv((CV*)sref))))) {
Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- CvCONST(cv)
- ? "Constant subroutine %s::%s redefined"
- : "Subroutine %s::%s redefined",
+ (const char *)
+ (CvCONST(cv)
+ ? "Constant subroutine %s::%s redefined"
+ : "Subroutine %s::%s redefined"),
HvNAME_get(GvSTASH((GV*)dstr)),
GvENAME((GV*)dstr));
}
}
if (!intro)
- cv_ckproto(cv, (GV*)dstr,
- SvPOK(sref) ? SvPVX_const(sref) : NULL);
+ cv_ckproto_len(cv, (GV*)dstr,
+ SvPOK(sref) ? SvPVX_const(sref) : NULL,
+ SvPOK(sref) ? SvCUR(sref) : 0);
}
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
GvASSUMECV_on(dstr);
dVAR;
register U32 sflags;
register int dtype;
- register int stype;
+ register svtype stype;
if (sstr == dstr)
return;
+
+ if (SvIS_FREED(dstr)) {
+ Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
+ " to a freed scalar %p", sstr, dstr);
+ }
SV_CHECK_THINKFIRST_COW_DROP(dstr);
if (!sstr)
sstr = &PL_sv_undef;
+ if (SvIS_FREED(sstr)) {
+ Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p", sstr,
+ dstr);
+ }
stype = SvTYPE(sstr);
dtype = SvTYPE(dstr);
case SVt_PVGV:
if (dtype <= SVt_PVGV) {
- S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
+ glob_assign_glob(dstr, sstr, dtype);
return;
}
/*FALLTHROUGH*/
case SVt_PVBM:
if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
mg_get(sstr);
- if ((int)SvTYPE(sstr) != stype) {
+ if (SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
if (stype == SVt_PVGV && dtype <= SVt_PVGV) {
- S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
+ glob_assign_glob(dstr, sstr, dtype);
return;
}
}
if (stype == SVt_PVLV)
SvUPGRADE(dstr, SVt_PVNV);
else
- SvUPGRADE(dstr, (U32)stype);
+ SvUPGRADE(dstr, (svtype)stype);
}
/* dstr may have been upgraded. */
GvMULTI_on(dstr);
return;
}
- S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
+ glob_assign_glob(dstr, sstr, dtype);
return;
}
if (dtype >= SVt_PV) {
if (dtype == SVt_PVGV) {
- S_glob_assign_ref(aTHX_ dstr, sstr);
+ glob_assign_ref(dstr, sstr);
return;
}
if (SvPVX_const(dstr)) {
SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8
|SVf_AMAGIC);
{
- const MAGIC * const smg = SvVOK(sstr);
+ const MAGIC * const smg = SvVSTRING_mg(sstr);
if (smg) {
sv_magic(dstr, NULL, PERL_MAGIC_vstring,
smg->mg_ptr, smg->mg_len);
}
/*
-=for apidoc sv_usepvn
-
-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 outside string.
-The C<ptr> should point to memory that was allocated by C<malloc>. The
-string length, C<len>, must be supplied. This function will realloc the
-memory pointed to by C<ptr>, so that pointer should not be freed or used by
-the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
-See C<sv_usepvn_mg>.
+=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
+outside string. The C<ptr> should point to memory that was allocated
+by C<malloc>. The string length, C<len>, must be supplied. By default
+this function will realloc (i.e. move) the memory pointed to by C<ptr>,
+so that pointer should not be freed or used by the programmer after
+giving it to sv_usepvn, and neither should any pointers from "behind"
+that pointer (e.g. ptr + 1) be used.
+
+If C<flags> & SV_SMAGIC is true, will call SvSETMAGIC. If C<flags> &
+SV_HAS_TRAILING_NUL is true, then C<ptr[len]> must be NUL, and the realloc
+will be skipped. (i.e. the buffer is actually at least 1 byte longer than
+C<len>, and already meets the requirements for storing in C<SvPVX>)
=cut
*/
void
-Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
+Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags)
{
dVAR;
STRLEN allocate;
SvUPGRADE(sv, SVt_PV);
if (!ptr) {
(void)SvOK_off(sv);
+ if (flags & SV_SMAGIC)
+ SvSETMAGIC(sv);
return;
}
if (SvPVX_const(sv))
SvPV_free(sv);
- allocate = PERL_STRLEN_ROUNDUP(len + 1);
- ptr = saferealloc (ptr, allocate);
+#ifdef DEBUGGING
+ if (flags & SV_HAS_TRAILING_NUL)
+ assert(ptr[len] == '\0');
+#endif
+
+ allocate = (flags & SV_HAS_TRAILING_NUL)
+ ? len + 1: PERL_STRLEN_ROUNDUP(len + 1);
+ if (flags & SV_HAS_TRAILING_NUL) {
+ /* It's long enough - do nothing.
+ Specfically Perl_newCONSTSUB is relying on this. */
+ } else {
+#ifdef DEBUGGING
+ /* Force a move to shake out bugs in callers. */
+ char *new_ptr = (char*)safemalloc(allocate);
+ Copy(ptr, new_ptr, len, char);
+ PoisonFree(ptr,len,char);
+ Safefree(ptr);
+ ptr = new_ptr;
+#else
+ ptr = (char*) saferealloc (ptr, allocate);
+#endif
+ }
SvPV_set(sv, ptr);
SvCUR_set(sv, len);
SvLEN_set(sv, allocate);
- *SvEND(sv) = '\0';
+ if (!(flags & SV_HAS_TRAILING_NUL)) {
+ *SvEND(sv) = '\0';
+ }
(void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
-}
-
-/*
-=for apidoc sv_usepvn_mg
-
-Like C<sv_usepvn>, but also handles 'set' magic.
-
-=cut
-*/
-
-void
-Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
-{
- sv_usepvn(sv,ptr,len);
- SvSETMAGIC(sv);
+ if (flags & SV_SMAGIC)
+ SvSETMAGIC(sv);
}
#ifdef PERL_OLD_COPY_ON_WRITE
case PERL_MAGIC_regdata:
vtable = &PL_vtbl_regdata;
break;
+ case PERL_MAGIC_regdata_names:
+ vtable = &PL_vtbl_regdata_names;
+ break;
case PERL_MAGIC_regdatum:
vtable = &PL_vtbl_regdatum;
break;
case PERL_MAGIC_qr:
vtable = &PL_vtbl_regexp;
break;
+ case PERL_MAGIC_hints:
+ /* As this vtable is all NULL, we can reuse it. */
case PERL_MAGIC_sig:
vtable = &PL_vtbl_sig;
break;
case PERL_MAGIC_backref:
vtable = &PL_vtbl_backref;
break;
+ case PERL_MAGIC_hintselem:
+ vtable = &PL_vtbl_hintselem;
+ break;
case PERL_MAGIC_ext:
/* Reserved for use by extensions not perl internals. */
/* Useful for attaching extension internal data to perl vars. */
Weaken a reference: set the C<SvWEAKREF> flag on this RV; give the
referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
push a back-reference to this RV onto the array of backreferences
-associated with that magic.
+associated with that magic. If the RV is magical, set magic will be
+called after the RV is cleared.
=cut
*/
SvRV_set(referrer, 0);
SvOK_off(referrer);
SvWEAKREF_off(referrer);
+ SvSETMAGIC(referrer);
} else if (SvTYPE(referrer) == SVt_PVGV ||
SvTYPE(referrer) == SVt_PVLV) {
/* You lookin' at me? */
}
}
if (type >= SVt_PVMG) {
- HV *ourstash;
- if ((type == SVt_PVMG || type == SVt_PVGV) &&
- (ourstash = OURSTASH(sv))) {
- SvREFCNT_dec(ourstash);
+ if ((type == SVt_PVMG || type == SVt_PVGV) && SvPAD_OUR(sv)) {
+ SvREFCNT_dec(OURSTASH(sv));
} else if (SvMAGIC(sv))
mg_free(sv);
if (type == SVt_PVMG && SvPAD_TYPED(sv))
*/
SAVEI8(PL_utf8cache);
PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVf
- " real %"UVf" for %"SVf,
- (UV) ulen, (UV) real, sv);
+ Perl_croak(aTHX_ "panic: sv_len_utf8 cache %"UVuf
+ " real %"UVuf" for %"SVf,
+ (UV) ulen, (UV) real, (void*)sv);
}
}
}
/* Walk forwards to find the byte corresponding to the passed in UTF-8
offset. */
static STRLEN
-S_sv_pos_u2b_forwards(pTHX_ const U8 *const start, const U8 *const send,
+S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send,
STRLEN uoffset)
{
const U8 *s = start;
whether to walk forwards or backwards to find the byte corresponding to
the passed in UTF-8 offset. */
static STRLEN
-S_sv_pos_u2b_midway(pTHX_ const U8 *const start, const U8 *send,
+S_sv_pos_u2b_midway(const U8 *const start, const U8 *send,
STRLEN uoffset, STRLEN uend)
{
STRLEN backw = uend - uoffset;
/* The assumption is that going forwards is twice the speed of going
forward (that's where the 2 * backw comes from).
(The real figure of course depends on the UTF-8 data.) */
- return S_sv_pos_u2b_forwards(aTHX_ start, send, uoffset);
+ return sv_pos_u2b_forwards(start, send, uoffset);
}
while (backw--) {
S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start,
const U8 *const send, STRLEN uoffset,
STRLEN uoffset0, STRLEN boffset0) {
- STRLEN boffset;
+ STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
bool found = FALSE;
assert (uoffset >= uoffset0);
if ((*mgp)->mg_len != -1) {
/* And we know the end too. */
boffset = boffset0
- + S_sv_pos_u2b_midway(aTHX_ start + boffset0, send,
+ + sv_pos_u2b_midway(start + boffset0, send,
uoffset - uoffset0,
(*mgp)->mg_len - uoffset0);
} else {
boffset = boffset0
- + S_sv_pos_u2b_forwards(aTHX_ start + boffset0,
+ + sv_pos_u2b_forwards(start + boffset0,
send, uoffset - uoffset0);
}
}
}
boffset = boffset0
- + S_sv_pos_u2b_midway(aTHX_ start + boffset0,
+ + sv_pos_u2b_midway(start + boffset0,
start + cache[1],
uoffset - uoffset0,
cache[0] - uoffset0);
} else {
boffset = boffset0
- + S_sv_pos_u2b_midway(aTHX_ start + boffset0,
+ + sv_pos_u2b_midway(start + boffset0,
start + cache[3],
uoffset - uoffset0,
cache[2] - uoffset0);
/* In fact, offset0 is either 0, or less than offset, so don't
need to worry about the other possibility. */
boffset = boffset0
- + S_sv_pos_u2b_midway(aTHX_ start + boffset0, send,
+ + sv_pos_u2b_midway(start + boffset0, send,
uoffset - uoffset0,
(*mgp)->mg_len - uoffset0);
found = TRUE;
if (!found || PL_utf8cache < 0) {
const STRLEN real_boffset
- = boffset0 + S_sv_pos_u2b_forwards(aTHX_ start + boffset0,
+ = boffset0 + sv_pos_u2b_forwards(start + boffset0,
send, uoffset - uoffset0);
if (found && PL_utf8cache < 0) {
infinitely while printing error messages. */
SAVEI8(PL_utf8cache);
PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVf
- " real %"UVf" for %"SVf,
- (UV) boffset, (UV) real_boffset, sv);
+ Perl_croak(aTHX_ "panic: sv_pos_u2b_cache cache %"UVuf
+ " real %"UVuf" for %"SVf,
+ (UV) boffset, (UV) real_boffset, (void*)sv);
}
}
boffset = real_boffset;
STRLEN uoffset = (STRLEN) *offsetp;
const U8 * const send = start + len;
MAGIC *mg = NULL;
- STRLEN boffset = S_sv_pos_u2b_cached(aTHX_ sv, &mg, start, send,
+ const STRLEN boffset = sv_pos_u2b_cached(sv, &mg, start, send,
uoffset, 0, 0);
*offsetp = (I32) boffset;
if (lenp) {
/* Convert the relative offset to absolute. */
- STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
- STRLEN boffset2
- = S_sv_pos_u2b_cached(aTHX_ sv, &mg, start, send, uoffset2,
+ const STRLEN uoffset2 = uoffset + (STRLEN) *lenp;
+ const STRLEN boffset2
+ = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2,
uoffset, boffset) - boffset;
*lenp = boffset2;
infinitely while printing error messages. */
SAVEI8(PL_utf8cache);
PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVf
- " real %"UVf" for %"SVf, (UV) utf8, (UV) realutf8, sv);
+ Perl_croak(aTHX_ "panic: utf8_mg_pos_cache_update cache %"UVuf
+ " real %"UVuf" for %"SVf, (UV) utf8, (UV) realutf8, (void*)sv);
}
}
{
const U8* s;
const STRLEN byte = *offsetp;
- STRLEN len;
+ STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
STRLEN blen;
MAGIC* mg = NULL;
const U8* send;
if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
&& (mg = mg_find(sv, PERL_MAGIC_utf8))) {
if (mg->mg_ptr) {
- STRLEN *cache = (STRLEN *) mg->mg_ptr;
+ STRLEN * const cache = (STRLEN *) mg->mg_ptr;
if (cache[1] == byte) {
/* An exact match. */
*offsetp = cache[0];
infinitely while printing error messages. */
SAVEI8(PL_utf8cache);
PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVf
- " real %"UVf" for %"SVf,
- (UV) len, (UV) real_len, sv);
+ Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVuf
+ " real %"UVuf" for %"SVf,
+ (UV) len, (UV) real_len, (void*)sv);
}
}
len = real_len;
pv1 = "";
cur1 = 0;
}
- else
+ else {
+ /* if pv1 and pv2 are the same, second SvPV_const call may
+ * invalidate pv1, so we may need to make a copy */
+ if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
+ pv1 = SvPV_const(sv1, cur1);
+ sv1 = sv_2mortal(newSVpvn(pv1, cur1));
+ if (SvUTF8(sv2)) SvUTF8_on(sv1);
+ }
pv1 = SvPV_const(sv1, cur1);
+ }
if (!sv2){
pv2 = "";
register I32 cnt;
I32 i = 0;
I32 rspara = 0;
- I32 recsize;
if (SvTHINKFIRST(sv))
sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
}
else if (RsSNARF(PL_rs)) {
/* If it is a regular disk file use size from stat() as estimate
- of amount we are going to read - may result in malloc-ing
- more memory than we realy need if layers bellow reduce
- size we read (e.g. CRLF or a gzip layer)
+ of amount we are going to read -- may result in mallocing
+ more memory than we really need if the layers below reduce
+ the size we read (e.g. CRLF or a gzip layer).
*/
Stat_t st;
if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
else if (RsRECORD(PL_rs)) {
I32 bytesread;
char *buffer;
+ U32 recsize;
/* Grab the size of the record we're getting */
- recsize = SvIV(SvRV(PL_rs));
+ recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
/* Go yank in */
#ifdef VMS
*
* - jik 9/25/96
*/
- if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
+ if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp)))
goto screamer2;
}
register SV *sv;
new_SV(sv);
- sv_setpvn(sv,s,len ? len : strlen(s));
+ sv_setpvn(sv, s, len || s == NULL ? len : strlen(s));
return sv;
}
SvUTF8_on (sv);
Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
return sv;
- } else if (flags & HVhek_REHASH) {
+ } else if (flags & (HVhek_REHASH|HVhek_UNSHARED)) {
/* We don't have a pointer to the hv, so we have to replicate the
flag into every HEK. This hv is using custom a hasing
algorithm. Hence we can't return a shared string scalar, as
that would contain the (wrong) hash value, and might get passed
- into an hv routine with a regular hash */
+ into an hv routine with a regular hash.
+ Similarly, a hash that isn't using shared hash keys has to have
+ the flag in every key so that we know not to try to call
+ share_hek_kek on it. */
SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
if (HEK_UTF8(hek))
return sv;
}
/* This will be overwhelminly the most common case. */
- return newSVpvn_share(HEK_KEY(hek),
- (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
- HEK_HASH(hek));
+ {
+ /* Inline most of newSVpvn_share(), because share_hek_hek() is far
+ more efficient than sharepvn(). */
+ SV *sv;
+
+ new_SV(sv);
+ sv_upgrade(sv, SVt_PV);
+ SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
+ SvCUR_set(sv, HEK_LEN(hek));
+ SvLEN_set(sv, 0);
+ SvREADONLY_on(sv);
+ SvFAKE_on(sv);
+ SvPOK_on(sv);
+ if (HEK_UTF8(hek))
+ SvUTF8_on(sv);
+ return sv;
+ }
}
}
dVAR;
register SV *sv;
bool is_utf8 = FALSE;
+ const char *const orig_src = src;
+
if (len < 0) {
STRLEN tmplen = -len;
is_utf8 = TRUE;
SvPOK_on(sv);
if (is_utf8)
SvUTF8_on(sv);
+ if (src != orig_src)
+ Safefree(src);
return sv;
}
else
io = 0;
if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
+ Perl_croak(aTHX_ "Bad filehandle: %"SVf, (void*)sv);
break;
}
return io;
LEAVE;
if (!GvCVu(gv))
Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
- sv);
+ (void*)sv);
}
return GvCVu(gv);
}
=cut
*/
-char *
+const char *
Perl_sv_reftype(pTHX_ const SV *sv, int ob)
{
/* The fact that I don't need to downcast to char * everywhere, only in ?:
sv_clear(rv);
SvFLAGS(rv) = 0;
SvREFCNT(rv) = refcnt;
- }
- if (SvTYPE(rv) < SVt_RV)
+ sv_upgrade(rv, SVt_RV);
+ } else if (SvROK(rv)) {
+ SvREFCNT_dec(SvRV(rv));
+ } else if (SvTYPE(rv) < SVt_RV)
sv_upgrade(rv, SVt_RV);
else if (SvTYPE(rv) > SVt_RV) {
SvPV_free(rv);
switch (*q) {
case ' ':
case '+':
- plus = *q++;
+ if (plus == '+' && *q == ' ') /* '+' over ' ' */
+ q++;
+ else
+ plus = *q++;
continue;
case '-':
else
i = (ewix ? ewix <= svmax : svix < svmax)
? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
- precis = (i < 0) ? 0 : i;
+ precis = i;
+ has_precis = !(i < 0);
}
else {
precis = 0;
while (isDIGIT(*q))
precis = precis * 10 + (*q++ - '0');
+ has_precis = TRUE;
}
- has_precis = TRUE;
}
/* SIZE */
else {
eptr = SvPVx_const(argsv, elen);
if (DO_UTF8(argsv)) {
+ I32 old_precis = precis;
if (has_precis && precis < elen) {
I32 p = precis;
sv_pos_u2b(argsv, &p, 0); /* sticks at end */
precis = p;
}
if (width) { /* fudge width (can't fudge elen) */
- width += elen - sv_len_utf8(argsv);
+ if (has_precis && precis < elen)
+ width += precis - old_precis;
+ else
+ width += elen - sv_len_utf8(argsv);
}
is_utf8 = TRUE;
}
integer:
{
char *ptr = ebuf + sizeof ebuf;
+ bool tempalt = uv ? alt : FALSE; /* Vectors can't change alt */
+ zeros = 0;
+
switch (base) {
unsigned dig;
case 16:
- if (!uv)
- alt = FALSE;
- p = (char*)((c == 'X')
- ? "0123456789ABCDEF" : "0123456789abcdef");
+ p = (char *)((c == 'X') ? PL_hexdigit + 16 : PL_hexdigit);
do {
dig = uv & 15;
*--ptr = p[dig];
} while (uv >>= 4);
- if (alt) {
+ if (tempalt) {
esignbuf[esignlen++] = '0';
esignbuf[esignlen++] = c; /* 'x' or 'X' */
}
*--ptr = '0';
break;
case 2:
- if (!uv)
- alt = FALSE;
do {
dig = uv & 1;
*--ptr = '0' + dig;
} while (uv >>= 1);
- if (alt) {
+ if (tempalt) {
esignbuf[esignlen++] = '0';
esignbuf[esignlen++] = 'b';
}
zeros = precis - elen;
else if (precis == 0 && elen == 1 && *eptr == '0')
elen = 0;
+
+ /* a precision nullifies the 0 flag. */
+ if (fill == '0')
+ fill = ' ';
}
}
break;
* --jhi */
#if defined(HAS_LONG_DOUBLE)
elen = ((intsize == 'q')
- ? my_sprintf(PL_efloatbuf, ptr, nv)
- : my_sprintf(PL_efloatbuf, ptr, (double)nv));
+ ? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, nv)
+ : my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)nv));
#else
elen = my_sprintf(PL_efloatbuf, ptr, nv);
#endif
(UV)c & 0xFF);
} else
sv_catpvs(msg, "end of string");
- Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
+ Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, (void*)msg); /* yes, this is reentrant */
}
/* output mangled stuff ... */
continue; /* not "break" */
}
- /* calculate width before utf8_upgrade changes it */
+ if (is_utf8 != has_utf8) {
+ if (is_utf8) {
+ if (SvCUR(sv))
+ sv_utf8_upgrade(sv);
+ }
+ else {
+ const STRLEN old_elen = elen;
+ SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
+ sv_utf8_upgrade(nsv);
+ eptr = SvPVX_const(nsv);
+ elen = SvCUR(nsv);
+
+ if (width) { /* fudge width (can't fudge elen) */
+ width += elen - old_elen;
+ }
+ is_utf8 = TRUE;
+ }
+ }
+
have = esignlen + zeros + elen;
if (have < zeros)
Perl_croak_nocontext(PL_memory_wrap);
- if (is_utf8 != has_utf8) {
- if (is_utf8) {
- if (SvCUR(sv))
- sv_utf8_upgrade(sv);
- }
- else {
- SV * const nsv = sv_2mortal(newSVpvn(eptr, elen));
- sv_utf8_upgrade(nsv);
- eptr = SvPVX_const(nsv);
- elen = SvCUR(nsv);
- }
- SvGROW(sv, SvCUR(sv) + elen + 1);
- p = SvEND(sv);
- *p = '\0';
- }
-
need = (have > width ? have : width);
gap = need - have;
#if defined(USE_ITHREADS)
+/* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
#ifndef GpREFCNT_inc
# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
#endif
+/* Certain cases in Perl_ss_dup have been merged, by relying on the fact
+ that currently av_dup and hv_dup are the same as sv_dup. If this changes,
+ please unmerge ss_dup. */
#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
#define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t))
#define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
REGEXP *
Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param)
{
- dVAR;
- REGEXP *ret;
- int i, len, npar;
- struct reg_substr_datum *s;
-
- if (!r)
- return (REGEXP *)NULL;
-
- if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
- return ret;
-
- len = r->offsets[0];
- npar = r->nparens+1;
-
- Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
- Copy(r->program, ret->program, len+1, regnode);
-
- Newx(ret->startp, npar, I32);
- Copy(r->startp, ret->startp, npar, I32);
- Newx(ret->endp, npar, I32);
- Copy(r->startp, ret->startp, npar, I32);
-
- Newx(ret->substrs, 1, struct reg_substr_data);
- for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
- s->min_offset = r->substrs->data[i].min_offset;
- s->max_offset = r->substrs->data[i].max_offset;
- s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
- s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
- }
-
- ret->regstclass = NULL;
- if (r->data) {
- struct reg_data *d;
- const int count = r->data->count;
- int i;
-
- Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
- char, struct reg_data);
- Newx(d->what, count, U8);
-
- d->count = count;
- for (i = 0; i < count; i++) {
- d->what[i] = r->data->what[i];
- switch (d->what[i]) {
- /* legal options are one of: sfpont
- see also regcomp.h and pregfree() */
- case 's':
- d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
- break;
- case 'p':
- d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
- break;
- case 'f':
- /* This is cheating. */
- Newx(d->data[i], 1, struct regnode_charclass_class);
- StructCopy(r->data->data[i], d->data[i],
- struct regnode_charclass_class);
- ret->regstclass = (regnode*)d->data[i];
- break;
- case 'o':
- /* Compiled op trees are readonly, and can thus be
- shared without duplication. */
- OP_REFCNT_LOCK;
- d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
- OP_REFCNT_UNLOCK;
- break;
- case 'n':
- d->data[i] = r->data->data[i];
- break;
- case 't':
- d->data[i] = r->data->data[i];
- OP_REFCNT_LOCK;
- ((reg_trie_data*)d->data[i])->refcount++;
- OP_REFCNT_UNLOCK;
- break;
- default:
- Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
- }
- }
-
- ret->data = d;
- }
- else
- ret->data = NULL;
-
- Newx(ret->offsets, 2*len+1, U32);
- Copy(r->offsets, ret->offsets, 2*len+1, U32);
-
- ret->precomp = SAVEPVN(r->precomp, r->prelen);
- ret->refcnt = r->refcnt;
- ret->minlen = r->minlen;
- ret->prelen = r->prelen;
- ret->nparens = r->nparens;
- ret->lastparen = r->lastparen;
- ret->lastcloseparen = r->lastcloseparen;
- ret->reganch = r->reganch;
-
- ret->sublen = r->sublen;
-
- if (RX_MATCH_COPIED(ret))
- ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
- else
- ret->subbeg = NULL;
-#ifdef PERL_OLD_COPY_ON_WRITE
- ret->saved_copy = NULL;
-#endif
-
- ptr_table_store(PL_ptr_table, r, ret);
- return ret;
+ return CALLREGDUPE(r,param);
}
/* duplicate a file handle */
ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
ret->gp_cvgen = gp->gp_cvgen;
ret->gp_line = gp->gp_line;
- ret->gp_file = gp->gp_file; /* points to COP.cop_file */
+ ret->gp_file_hek = hek_dup(gp->gp_file_hek, param);
return ret;
}
if (tblent->oldval == sv)
return tblent;
}
- return 0;
+ return NULL;
}
void *
{
PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
PERL_UNUSED_CONTEXT;
- return tblent ? tblent->newval : (void *) 0;
+ return tblent ? tblent->newval : NULL;
}
/* add a new entry to a pointer-mapping table */
case SVt_PVGV:
if (GvUNIQUE((GV*)sstr)) {
- /*EMPTY*/; /* Do sharing here, and fall through */
+ NOOP; /* Do sharing here, and fall through */
}
case SVt_PVIO:
case SVt_PVFM:
missing by always going for the destination.
FIXME - instrument and check that assumption */
if (sv_type >= SVt_PVMG) {
- HV *ourstash;
- if ((sv_type == SVt_PVMG) && (ourstash = OURSTASH(dstr))) {
- OURSTASH_set(dstr, hv_dup_inc(ourstash, param));
+ if ((sv_type == SVt_PVMG) && SvPAD_OUR(dstr)) {
+ OURSTASH_set(dstr, hv_dup_inc(OURSTASH(dstr), param));
} else if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
if (SvSTASH(dstr))
if (IoDIRP(dstr)) {
IoDIRP(dstr) = dirp_dup(IoDIRP(dstr));
} else {
- /*EMPTY*/;
+ NOOP;
/* IoDIRP(dstr) is already a copy of IoDIRP(sstr) */
}
}
}
break;
case SVt_PVHV:
- {
- HEK *hvname = NULL;
-
- if (HvARRAY((HV*)sstr)) {
- STRLEN i = 0;
- const bool sharekeys = !!HvSHAREKEYS(sstr);
- XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
- XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
- char *darray;
- Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
- + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
- char);
- HvARRAY(dstr) = (HE**)darray;
- while (i <= sxhv->xhv_max) {
- const HE *source = HvARRAY(sstr)[i];
- HvARRAY(dstr)[i] = source
- ? he_dup(source, sharekeys, param) : 0;
- ++i;
- }
- if (SvOOK(sstr)) {
- struct xpvhv_aux * const saux = HvAUX(sstr);
- struct xpvhv_aux * const daux = HvAUX(dstr);
- /* This flag isn't copied. */
- /* SvOOK_on(hv) attacks the IV flags. */
- SvFLAGS(dstr) |= SVf_OOK;
-
- hvname = saux->xhv_name;
- daux->xhv_name
- = hvname ? hek_dup(hvname, param) : hvname;
-
- daux->xhv_riter = saux->xhv_riter;
- daux->xhv_eiter = saux->xhv_eiter
- ? he_dup(saux->xhv_eiter,
- (bool)!!HvSHAREKEYS(sstr), param) : 0;
- daux->xhv_backreferences = saux->xhv_backreferences
+ if (HvARRAY((HV*)sstr)) {
+ STRLEN i = 0;
+ const bool sharekeys = !!HvSHAREKEYS(sstr);
+ XPVHV * const dxhv = (XPVHV*)SvANY(dstr);
+ XPVHV * const sxhv = (XPVHV*)SvANY(sstr);
+ char *darray;
+ Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1)
+ + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0),
+ char);
+ HvARRAY(dstr) = (HE**)darray;
+ while (i <= sxhv->xhv_max) {
+ const HE * const source = HvARRAY(sstr)[i];
+ HvARRAY(dstr)[i] = source
+ ? he_dup(source, sharekeys, param) : 0;
+ ++i;
+ }
+ if (SvOOK(sstr)) {
+ HEK *hvname;
+ const struct xpvhv_aux * const saux = HvAUX(sstr);
+ struct xpvhv_aux * const daux = HvAUX(dstr);
+ /* This flag isn't copied. */
+ /* SvOOK_on(hv) attacks the IV flags. */
+ SvFLAGS(dstr) |= SVf_OOK;
+
+ hvname = saux->xhv_name;
+ daux->xhv_name = hvname ? hek_dup(hvname, param) : hvname;
+
+ daux->xhv_riter = saux->xhv_riter;
+ daux->xhv_eiter = saux->xhv_eiter
+ ? he_dup(saux->xhv_eiter,
+ (bool)!!HvSHAREKEYS(sstr), param) : 0;
+ daux->xhv_backreferences =
+ saux->xhv_backreferences
? (AV*) SvREFCNT_inc(
- sv_dup((SV*)saux->
- xhv_backreferences,
- param))
+ sv_dup((SV*)saux->xhv_backreferences, param))
: 0;
- }
- }
- else {
- SvPV_set(dstr, NULL);
+ /* Record stashes for possible cloning in Perl_clone(). */
+ if (hvname)
+ av_push(param->stashes, dstr);
}
- /* Record stashes for possible cloning in Perl_clone(). */
- if(hvname)
- av_push(param->stashes, dstr);
}
+ else
+ SvPV_set(dstr, NULL);
break;
case SVt_PVCV:
if (!(param->flags & CLONEf_COPY_STACKS)) {
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
ncx->blk_sub.lval = cx->blk_sub.lval;
ncx->blk_sub.retop = cx->blk_sub.retop;
+ ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
+ cx->blk_sub.oldcomppad);
break;
case CXt_EVAL:
ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
case CXt_LOOP:
ncx->blk_loop.label = cx->blk_loop.label;
ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
- ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
- ncx->blk_loop.next_op = cx->blk_loop.next_op;
- ncx->blk_loop.last_op = cx->blk_loop.last_op;
+ ncx->blk_loop.my_op = cx->blk_loop.my_op;
ncx->blk_loop.iterdata = (CxPADLOOP(cx)
? cx->blk_loop.iterdata
: gv_dup((GV*)cx->blk_loop.iterdata, param));
TOPINT(nss,ix) = i;
switch (i) {
case SAVEt_ITEM: /* normal string */
+ case SAVEt_SV: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
- case SAVEt_SV: /* scalar reference */
- sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv, param);
- gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup_inc(gv, param);
- break;
- case SAVEt_GENERIC_PVREF: /* generic char* */
- c = (char*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = pv_dup(c);
- ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- break;
case SAVEt_SHARED_PVREF: /* char* in shared space */
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = savesharedpv(c);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
break;
- case SAVEt_AV: /* array reference */
- av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup_inc(av, param);
- gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup(gv, param);
- break;
case SAVEt_HV: /* hash reference */
- hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup_inc(hv, param);
+ case SAVEt_AV: /* array reference */
+ sv = (SV*) POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
gv = (GV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gv_dup(gv, param);
break;
case SAVEt_I32: /* I32 reference */
case SAVEt_I16: /* I16 reference */
case SAVEt_I8: /* I8 reference */
+ case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
i = POPINT(ss,ix);
iv = POPIV(ss,ix);
TOPIV(nss,ix) = iv;
break;
+ case SAVEt_HPTR: /* HV* reference */
+ case SAVEt_APTR: /* AV* reference */
case SAVEt_SPTR: /* SV* reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
break;
+ case SAVEt_GENERIC_PVREF: /* generic char* */
case SAVEt_PPTR: /* char* reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup(c);
break;
- case SAVEt_HPTR: /* HV* reference */
- ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup(hv, param);
- break;
- case SAVEt_APTR: /* AV* reference */
- ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup(av, param);
- break;
case SAVEt_NSTAB:
gv = (GV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gv_dup(gv, param);
case SAVEt_HINTS:
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
+ ptr = POPPTR(ss,ix);
+ if (ptr) {
+ HINTS_REFCNT_LOCK;
+ ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
+ }
+ TOPPTR(nss,ix) = ptr;
+ if (i & HINT_LOCALIZE_HH) {
+ hv = (HV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = hv_dup_inc(hv, param);
+ }
break;
case SAVEt_COMPPAD:
av = (AV*)POPPTR(ss,ix);
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
+ case SAVEt_RE_STATE:
+ {
+ const struct re_save_state *const old_state
+ = (struct re_save_state *)
+ (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
+ struct re_save_state *const new_state
+ = (struct re_save_state *)
+ (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
+
+ Copy(old_state, new_state, 1, struct re_save_state);
+ ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
+
+ new_state->re_state_bostr
+ = pv_dup(old_state->re_state_bostr);
+ new_state->re_state_reginput
+ = pv_dup(old_state->re_state_reginput);
+ new_state->re_state_regeol
+ = pv_dup(old_state->re_state_regeol);
+ new_state->re_state_regstartp
+ = (I32*) any_dup(old_state->re_state_regstartp, proto_perl);
+ new_state->re_state_regendp
+ = (I32*) any_dup(old_state->re_state_regendp, proto_perl);
+ new_state->re_state_reglastparen
+ = (U32*) any_dup(old_state->re_state_reglastparen,
+ proto_perl);
+ new_state->re_state_reglastcloseparen
+ = (U32*)any_dup(old_state->re_state_reglastcloseparen,
+ proto_perl);
+ /* XXX This just has to be broken. The old save_re_context
+ code did SAVEGENERICPV(PL_reg_start_tmp);
+ PL_reg_start_tmp is char **.
+ Look above to what the dup code does for
+ SAVEt_GENERIC_PVREF
+ It can never have worked.
+ So this is merely a faithful copy of the exiting bug: */
+ new_state->re_state_reg_start_tmp
+ = (char **) pv_dup((char *)
+ old_state->re_state_reg_start_tmp);
+ /* I assume that it only ever "worked" because no-one called
+ (pseudo)fork while the regexp engine had re-entered itself.
+ */
+#ifdef PERL_OLD_COPY_ON_WRITE
+ new_state->re_state_nrs
+ = sv_dup(old_state->re_state_nrs, param);
+#endif
+ new_state->re_state_reg_magic
+ = (MAGIC*) any_dup(old_state->re_state_reg_magic,
+ proto_perl);
+ new_state->re_state_reg_oldcurpm
+ = (PMOP*) any_dup(old_state->re_state_reg_oldcurpm,
+ proto_perl);
+ new_state->re_state_reg_curpm
+ = (PMOP*) any_dup(old_state->re_state_reg_curpm,
+ proto_perl);
+ new_state->re_state_reg_oldsaved
+ = pv_dup(old_state->re_state_reg_oldsaved);
+ new_state->re_state_reg_poscache
+ = pv_dup(old_state->re_state_reg_poscache);
+ new_state->re_state_reg_starttry
+ = pv_dup(old_state->re_state_reg_starttry);
+ break;
+ }
+ case SAVEt_COMPILE_WARNINGS:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
+ break;
default:
- Perl_croak(aTHX_ "panic: ss_dup inconsistency");
+ Perl_croak(aTHX_ "panic: ss_dup inconsistency (%"IVdf")", (IV) i);
}
}
PERL_SET_THX(my_perl);
# ifdef DEBUGGING
- Poison(my_perl, 1, PerlInterpreter);
+ PoisonNew(my_perl, 1, PerlInterpreter);
PL_op = NULL;
PL_curcop = NULL;
PL_markstack = 0;
PERL_SET_THX(my_perl);
# ifdef DEBUGGING
- Poison(my_perl, 1, PerlInterpreter);
+ PoisonNew(my_perl, 1, PerlInterpreter);
PL_op = NULL;
PL_curcop = NULL;
PL_markstack = 0;
SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
SvFLAGS(&PL_sv_no) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
- SvPV_set(&PL_sv_no, SAVEPVN(PL_No, 0));
+ SvPV_set(&PL_sv_no, savepvn(PL_No, 0));
SvCUR_set(&PL_sv_no, 0);
SvLEN_set(&PL_sv_no, 1);
SvIV_set(&PL_sv_no, 0);
SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
SvFLAGS(&PL_sv_yes) = SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
- SvPV_set(&PL_sv_yes, SAVEPVN(PL_Yes, 1));
+ SvPV_set(&PL_sv_yes, savepvn(PL_Yes, 1));
SvCUR_set(&PL_sv_yes, 1);
SvLEN_set(&PL_sv_yes, 2);
SvIV_set(&PL_sv_yes, 1);
ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
- if (!specialWARN(PL_compiling.cop_warnings))
- PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
- if (!specialCopIO(PL_compiling.cop_io))
- PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
+ if (PL_compiling.cop_hints_hash) {
+ HINTS_REFCNT_LOCK;
+ PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
+ }
PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
/* pseudo environmental stuff */
sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
+
+ /* RE engine related */
+ Zero(&PL_reg_state, 1, struct re_save_state);
+ PL_reginterp_cnt = 0;
+ PL_regmatch_slab = NULL;
+
/* Clone the regex array */
PL_regex_padav = newAV();
{
PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
- PL_uudmap['M'] = 0; /* reinits on demand */
+ PL_uudmap[(U32) 'M'] = 0; /* reinits on demand */
PL_bitcount = NULL; /* reinits on demand */
if (proto_perl->Ipsig_pend) {
PL_watchok = NULL;
PL_regdummy = proto_perl->Tregdummy;
- PL_regprecomp = NULL;
- PL_regnpar = 0;
- PL_regsize = 0;
PL_colorset = 0; /* reinits PL_colors[] */
/*PL_colors[6] = {0,0,0,0,0,0};*/
- PL_reginput = NULL;
- PL_regbol = NULL;
- PL_regeol = NULL;
- PL_regstartp = (I32*)NULL;
- PL_regendp = (I32*)NULL;
- PL_reglastparen = (U32*)NULL;
- PL_reglastcloseparen = (U32*)NULL;
- PL_regtill = NULL;
- PL_reg_start_tmp = (char**)NULL;
- PL_reg_start_tmpl = 0;
- PL_regdata = (struct reg_data*)NULL;
- PL_bostr = NULL;
- PL_reg_flags = 0;
- PL_reg_eval_set = 0;
- PL_regnarrate = 0;
- PL_regprogram = (regnode*)NULL;
- PL_regindent = 0;
- PL_reg_call_cc = (struct re_cc_state*)NULL;
- PL_reg_re = (regexp*)NULL;
- PL_reg_ganch = NULL;
- PL_reg_sv = NULL;
- PL_reg_match_utf8 = FALSE;
- PL_reg_magic = (MAGIC*)NULL;
- PL_reg_oldpos = 0;
- PL_reg_oldcurpm = (PMOP*)NULL;
- PL_reg_curpm = (PMOP*)NULL;
- PL_reg_oldsaved = NULL;
- PL_reg_oldsavedlen = 0;
-#ifdef PERL_OLD_COPY_ON_WRITE
- PL_nrs = NULL;
-#endif
- PL_reg_maxiter = 0;
- PL_reg_leftiter = 0;
- PL_reg_poscache = NULL;
- PL_reg_poscache_size= 0;
-
- /* RE engine - function pointers */
- PL_regcompp = proto_perl->Tregcompp;
- PL_regexecp = proto_perl->Tregexecp;
- PL_regint_start = proto_perl->Tregint_start;
- PL_regint_string = proto_perl->Tregint_string;
- PL_regfree = proto_perl->Tregfree;
- PL_reginterp_cnt = 0;
- PL_reg_starttry = 0;
+
/* Pluggable optimizer */
PL_peepp = proto_perl->Tpeepp;
S_find_array_subscript(pTHX_ AV *av, SV* val)
{
dVAR;
- SV** svp;
- I32 i;
if (!av || SvMAGICAL(av) || !AvARRAY(av) ||
(AvFILLp(av) > FUV_MAX_SEARCH_SIZE))
return -1;
- svp = AvARRAY(av);
- for (i=AvFILLp(av); i>=0; i--) {
- if (svp[i] == val && svp[i] != &PL_sv_undef)
- return i;
+ if (val != &PL_sv_undef) {
+ SV ** const svp = AvARRAY(av);
+ I32 i;
+
+ for (i=AvFILLp(av); i>=0; i--)
+ if (svp[i] == val)
+ return i;
}
return -1;
}
/* attempt to find a match within the aggregate */
if (hash) {
- keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
+ keysv = find_hash_subscript((HV*)sv, uninit_sv);
if (keysv)
subscript_type = FUV_SUBSCRIPT_HASH;
}
else {
- index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
+ index = find_array_subscript((AV*)sv, uninit_sv);
if (index >= 0)
subscript_type = FUV_SUBSCRIPT_ARRAY;
}
/* index is an expression;
* attempt to find a match within the aggregate */
if (obase->op_type == OP_HELEM) {
- SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
+ SV * const keysv = find_hash_subscript((HV*)sv, uninit_sv);
if (keysv)
return varname(gv, '%', o->op_targ,
keysv, 0, FUV_SUBSCRIPT_HASH);
}
else {
- const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
+ const I32 index = find_array_subscript((AV*)sv, uninit_sv);
if (index >= 0)
return varname(gv, '@', o->op_targ,
NULL, index, FUV_SUBSCRIPT_ARRAY);
* or are optimized away, then it's unambiguous */
o2 = NULL;
for (kid=o; kid; kid = kid->op_sibling) {
- if (kid &&
- ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid)))
- || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS))
- || (kid->op_type == OP_PUSHMARK)
+ 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)
)
- )
continue;
+ }
if (o2) { /* more than one found */
o2 = NULL;
break;
https://perl5.git.perl.org / perl5.git / blobdiff