#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;
*/
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;
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 */
/* 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
dVAR;
register U32 sflags;
register int dtype;
- register int stype;
+ register svtype stype;
if (sstr == dstr)
return;
if (stype == SVt_PVLV)
SvUPGRADE(dstr, SVt_PVNV);
else
- SvUPGRADE(dstr, (U32)stype);
+ SvUPGRADE(dstr, (svtype)stype);
}
/* dstr may have been upgraded. */
if (SvPVX_const(sv))
SvPV_free(sv);
+#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);
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? */
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");
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';
}
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;
((reg_trie_data*)d->data[i])->refcount++;
OP_REFCNT_UNLOCK;
break;
+ case 'T':
+ d->data[i] = r->data->data[i];
+ OP_REFCNT_LOCK;
+ ((reg_ac_data*)d->data[i])->refcount++;
+ OP_REFCNT_UNLOCK;
+ /* Trie stclasses are readonly and can thus be shared
+ * without duplication. We free the stclass in pregfree
+ * when the corresponding reg_ac_data struct is freed.
+ */
+ ret->regstclass= r->regstclass;
+ break;
default:
Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
}
}
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;
- }
+ /* Record stashes for possible cloning in Perl_clone(). */
+ if (hvname)
+ av_push(param->stashes, dstr);
}
- else {
- SvPV_set(dstr, NULL);
- }
- /* 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)) {
ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
- if (!specialCopIO(PL_compiling.cop_io))
- PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
if (PL_compiling.cop_hints_hash) {
HINTS_REFCNT_LOCK;
PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
https://perl5.git.perl.org / perl5.git / blobdiff