#define del_SV(p) \
STMT_START { \
LOCK_SV_MUTEX; \
- if (PL_debug & 32768) \
+ if (DEBUG_D_TEST) \
del_sv(p); \
else \
plant_SV(p); \
STATIC void
S_del_sv(pTHX_ SV *p)
{
- if (PL_debug & 32768) {
+ if (DEBUG_D_TEST) {
SV* sva;
SV* sv;
SV* svend;
if (PL_nice_chunk) {
sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
PL_nice_chunk = Nullch;
+ PL_nice_chunk_size = 0;
}
else {
char *chunk; /* must use New here to match call to */
return sv;
}
-STATIC void
+STATIC I32
S_visit(pTHX_ SVFUNC_t f)
{
SV* sva;
SV* sv;
register SV* svend;
+ I32 visited = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
- if (SvTYPE(sv) != SVTYPEMASK)
+ if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
(FCALL)(aTHXo_ sv);
+ ++visited;
+ }
}
}
+ return visited;
}
void
PL_in_clean_objs = FALSE;
}
-void
+I32
Perl_sv_clean_all(pTHX)
{
+ I32 cleaned;
PL_in_clean_all = TRUE;
- visit(do_clean_all);
+ cleaned = visit(do_clean_all);
PL_in_clean_all = FALSE;
+ return cleaned;
}
void
{
char tmpbuf[64];
char *d = tmpbuf;
- char *s;
char *limit = tmpbuf + sizeof(tmpbuf) - 8;
/* each *s can expand to 4 chars + "...\0",
i.e. need room for 8 chars */
- for (s = SvPVX(sv); *s && d < limit; s++) {
+ char *s, *end;
+ for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
int ch = *s & 0xFF;
if (ch & 128 && !isPRINT_LC(ch)) {
*d++ = 'M';
*d++ = '\\';
*d++ = '\\';
}
+ else if (ch == '\0') {
+ *d++ = '\\';
+ *d++ = '0';
+ }
else if (isPRINT_LC(ch))
*d++ = ch;
else {
*d++ = toCTRL(ch);
}
}
- if (*s) {
+ if (s < end) {
*d++ = '.';
*d++ = '.';
*d++ = '.';
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvRV(tmpstr) != SvRV(sv)))
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvIV(tmpstr);
return PTR2IV(SvRV(sv));
}
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvRV(tmpstr) != SvRV(sv)))
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvUV(tmpstr);
return PTR2UV(SvRV(sv));
}
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
- (SvRV(tmpstr) != SvRV(sv)))
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvNV(tmpstr);
return PTR2NV(SvRV(sv));
}
I32 numtype = 0;
I32 sawinf = 0;
STRLEN len;
+#ifdef USE_LOCALE_NUMERIC
+ bool specialradix = FALSE;
+#endif
if (SvPOK(sv)) {
sbegin = SvPVX(sv);
if (*s == '.'
#ifdef USE_LOCALE_NUMERIC
- || IS_NUMERIC_RADIX(*s)
+ || (specialradix = IS_NUMERIC_RADIX(s))
#endif
) {
- s++;
+#ifdef USE_LOCALE_NUMERIC
+ if (specialradix)
+ s += SvCUR(PL_numeric_radix_sv);
+ else
+#endif
+ s++;
numtype |= IS_NUMBER_NOT_INT;
while (isDIGIT(*s)) /* optional digits after the radix */
s++;
}
else if (*s == '.'
#ifdef USE_LOCALE_NUMERIC
- || IS_NUMERIC_RADIX(*s)
+ || (specialradix = IS_NUMERIC_RADIX(s))
#endif
) {
- s++;
+#ifdef USE_LOCALE_NUMERIC
+ if (specialradix)
+ s += SvCUR(PL_numeric_radix_sv);
+ else
+#endif
+ s++;
numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
/* no digits before the radix means we need digits after it */
if (isDIGIT(*s)) {
if (SvROK(sv)) {
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
- (SvRV(tmpstr) != SvRV(sv)))
+ (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
return SvPV(tmpstr,*lp);
sv = (SV*)SvRV(sv);
if (!sv)
char *
Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
{
- return sv_2pv(sv,lp);
+ sv_utf8_downgrade(sv,0);
+ return SvPV(sv,*lp);
}
char *
if (SvROK(sv)) {
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
- (SvRV(tmpsv) != SvRV(sv)))
+ (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
return SvTRUE(tmpsv);
return SvRV(sv) != 0;
}
=for apidoc sv_utf8_upgrade
Convert the PV of an SV to its UTF8-encoded form.
+Forces the SV to string form it it is not already.
+Always sets the SvUTF8 flag to avoid future validity checks even
+if all the bytes have hibit clear.
=cut
*/
-void
+STRLEN
Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
{
- char *s, *t, *e;
+ U8 *s, *t, *e;
int hibit = 0;
- if (!sv || !SvPOK(sv) || SvUTF8(sv))
- return;
+ if (!sv)
+ return 0;
+
+ if (!SvPOK(sv)) {
+ STRLEN len = 0;
+ (void) sv_2pv(sv,&len);
+ if (!SvPOK(sv))
+ return len;
+ }
+
+ if (SvUTF8(sv))
+ return SvCUR(sv);
+
+ if (SvREADONLY(sv) && SvFAKE(sv)) {
+ sv_force_normal(sv);
+ }
/* This function could be much more efficient if we had a FLAG in SVs
* to signal if there are any hibit chars in the PV.
* Given that there isn't make loop fast as possible
*/
- s = SvPVX(sv);
- e = SvEND(sv);
+ s = (U8 *) SvPVX(sv);
+ e = (U8 *) SvEND(sv);
t = s;
while (t < e) {
- if ((hibit = UTF8_IS_CONTINUED(*t++)))
+ U8 ch = *t++;
+ if ((hibit = !NATIVE_IS_INVARIANT(ch)))
break;
}
-
if (hibit) {
STRLEN len;
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
- s = SvPVX(sv);
- }
+
len = SvCUR(sv) + 1; /* Plus the \0 */
SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
SvCUR(sv) = len - 1;
if (SvLEN(sv) != 0)
Safefree(s); /* No longer using what was there before. */
SvLEN(sv) = len; /* No longer know the real size. */
- SvUTF8_on(sv);
}
+ /* Mark as UTF-8 even if no hibit - saves scanning loop */
+ SvUTF8_on(sv);
+ return SvCUR(sv);
}
/*
{
if (SvPOK(sv) && SvUTF8(sv)) {
if (SvCUR(sv)) {
- char *c = SvPVX(sv);
- STRLEN len = SvCUR(sv);
+ U8 *s;
+ STRLEN len;
- if (!utf8_to_bytes((U8*)c, &len)) {
+ if (SvREADONLY(sv) && SvFAKE(sv))
+ sv_force_normal(sv);
+ s = (U8 *) SvPV(sv, len);
+ if (!utf8_to_bytes(s, &len)) {
if (fail_ok)
return FALSE;
+#ifdef USE_BYTES_DOWNGRADES
+ else if (IN_BYTE) {
+ U8 *d = s;
+ U8 *e = (U8 *) SvEND(sv);
+ int first = 1;
+ while (s < e) {
+ UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
+ if (first && ch > 255) {
+ if (PL_op)
+ Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
+ PL_op_desc[PL_op->op_type]);
+ else
+ Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
+ first = 0;
+ }
+ *d++ = ch;
+ s += len;
+ }
+ *d = '\0';
+ len = (d - (U8 *) SvPVX(sv));
+ }
+#endif
else {
if (PL_op)
Perl_croak(aTHX_ "Wide character in %s",
}
SvCUR(sv) = len;
}
- SvUTF8_off(sv);
}
-
+ SvUTF8_off(sv);
return TRUE;
}
=for apidoc sv_utf8_encode
Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
-flag so that it looks like bytes again. Nothing calls this.
+flag so that it looks like octets again. Used as a building block
+for encode_utf8 in Encode.xs
=cut
*/
void
Perl_sv_utf8_encode(pTHX_ register SV *sv)
{
- sv_utf8_upgrade(sv);
+ (void) sv_utf8_upgrade(sv);
SvUTF8_off(sv);
}
+/*
+=for apidoc sv_utf8_decode
+
+Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
+turn of SvUTF8 if needed so that we see characters. Used as a building block
+for decode_utf8 in Encode.xs
+
+=cut
+*/
+
+
+
bool
Perl_sv_utf8_decode(pTHX_ register SV *sv)
{
if (SvPOK(sv)) {
- char *c;
- char *e;
- bool has_utf = FALSE;
+ U8 *c;
+ U8 *e;
+
+ /* The octets may have got themselves encoded - get them back as bytes */
if (!sv_utf8_downgrade(sv, TRUE))
return FALSE;
/* it is actually just a matter of turning the utf8 flag on, but
* we want to make sure everything inside is valid utf8 first.
*/
- c = SvPVX(sv);
- if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
+ c = (U8 *) SvPVX(sv);
+ if (!is_utf8_string(c, SvCUR(sv)+1))
return FALSE;
- e = SvEND(sv);
+ e = (U8 *) SvEND(sv);
while (c < e) {
- if (UTF8_IS_CONTINUED(*c++)) {
+ U8 ch = *c++;
+ if (!UTF8_IS_INVARIANT(ch)) {
SvUTF8_on(sv);
break;
}
&& GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
GvNAME(dstr));
+
+#ifdef GV_SHARED_CHECK
+ if (GvSHARED((GV*)dstr)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+#endif
+
(void)SvOK_off(dstr);
GvINTRO_off(dstr); /* one-shot flag */
gp_free((GV*)dstr);
SV *dref = 0;
int intro = GvINTRO(dstr);
+#ifdef GV_SHARED_CHECK
+ if (GvSHARED((GV*)dstr)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ }
+#endif
+
if (intro) {
GP *gp;
gp_free((GV*)dstr);
if (!GvCVGEN((GV*)dstr) &&
(CvROOT(cv) || CvXSUB(cv)))
{
- SV *const_sv;
/* ahem, death to those who redefine
* active sort subs */
if (PL_curstackinfo->si_type == PERLSI_SORT &&
if (sflags & SVf_IOK)
(void)SvIOK_only(dstr);
else {
- SvOK_off(dstr);
- SvIOKp_on(dstr);
+ (void)SvOK_off(dstr);
+ (void)SvIOKp_on(dstr);
}
/* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
if (sflags & SVf_IVisUV)
if (sflags & SVf_NOK)
(void)SvNOK_only(dstr);
else {
- SvOK_off(dstr);
+ (void)SvOK_off(dstr);
SvNOKp_on(dstr);
}
SvNVX(dstr) = SvNVX(sstr);
Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
{
register char *dptr;
- {
- /* len is STRLEN which is unsigned, need to copy to signed */
- IV iv = len;
- assert(iv >= 0);
- }
+
SV_CHECK_THINKFIRST(sv);
if (!ptr) {
(void)SvOK_off(sv);
return;
}
+ else {
+ /* len is STRLEN which is unsigned, need to copy to signed */
+ IV iv = len;
+ assert(iv >= 0);
+ }
(void)SvUPGRADE(sv, SVt_PV);
SvGROW(sv, len + 1);
=for apidoc sv_catpvn
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. Handles 'get' magic, but not
-'set' magic. See C<sv_catpvn_mg>.
+C<len> indicates number of bytes to copy. If the SV has the UTF8
+status set, then the bytes appended should be valid UTF8.
+Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
=cut
*/
=for apidoc sv_catpv
Concatenates the string onto the end of the string which is in the SV.
-Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
+If the SV has the UTF8 status set, then the bytes appended should be
+valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
-=cut
-*/
+=cut */
void
Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
}
Newz(702,mg, 1, MAGIC);
mg->mg_moremagic = SvMAGIC(sv);
-
SvMAGIC(sv) = mg;
- if (!obj || obj == sv || how == '#' || how == 'r')
+
+ /* Some magic sontains a reference loop, where the sv and object refer to
+ each other. To prevent a avoid a reference loop that would prevent such
+ objects being freed, we look for such loops and if we find one we avoid
+ incrementing the object refcount. */
+ if (!obj || obj == sv || how == '#' || how == 'r' ||
+ (SvTYPE(obj) == SVt_PVGV &&
+ (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
+ GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
+ GvFORM(obj) == (CV*)sv)))
+ {
mg->mg_obj = obj;
+ }
else {
mg->mg_obj = SvREFCNT_inc(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
mg->mg_type = how;
mg->mg_len = namlen;
- if (name)
+ if (name) {
if (namlen >= 0)
mg->mg_ptr = savepvn(name, namlen);
else if (namlen == HEf_SVKEY)
mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
+ }
switch (how) {
case 0:
*mgp = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
- if (mg->mg_ptr && mg->mg_type != 'g')
+ if (mg->mg_ptr && mg->mg_type != 'g') {
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec((SV*)mg->mg_ptr);
+ }
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
if (SvOBJECT(sv)) {
if (PL_defstash) { /* Still have a symbol table? */
- djSP;
+ dSP;
CV* destructor;
SV tmpref;
len = 0;
while (s < send) {
STRLEN n;
-
- if (utf8_to_uv(s, UTF8SKIP(s), &n, 0)) {
+ /* Call utf8n_to_uvchr() to validate the sequence */
+ utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
+ if (n > 0) {
s += n;
len++;
}
char *pv2;
STRLEN cur2;
I32 eq = 0;
- bool pv1tmp = FALSE;
- bool pv2tmp = FALSE;
+ char *tpv = Nullch;
if (!sv1) {
pv1 = "";
/* do not utf8ize the comparands as a side-effect */
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+ bool is_utf8 = TRUE;
+ /* UTF-8ness differs */
if (PL_hints & HINT_UTF8_DISTINCT)
return FALSE;
if (SvUTF8(sv1)) {
- (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1);
- {
- IV scur1 = cur1;
- if (scur1 < 0) {
- Safefree(pv1);
- return 0;
- }
- }
- pv1tmp = TRUE;
+ /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
+ char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
+ if (pv != pv1)
+ pv1 = tpv = pv;
}
else {
- (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2);
- {
- IV scur2 = cur2;
- if (scur2 < 0) {
- Safefree(pv2);
- return 0;
- }
- }
- pv2tmp = TRUE;
+ /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
+ char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
+ if (pv != pv2)
+ pv2 = tpv = pv;
+ }
+ if (is_utf8) {
+ /* Downgrade not possible - cannot be eq */
+ return FALSE;
}
}
if (cur1 == cur2)
eq = memEQ(pv1, pv2, cur1);
- if (pv1tmp)
- Safefree(pv1);
- if (pv2tmp)
- Safefree(pv2);
+ if (tpv != Nullch)
+ Safefree(tpv);
return eq;
}
len = -len;
is_utf8 = TRUE;
}
+ if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
+ STRLEN tmplen = len;
+ /* See the note in hv.c:hv_fetch() --jhi */
+ src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
+ len = tmplen;
+ }
if (!hash)
PERL_HASH(hash, src, len);
new_SV(sv);
char *
Perl_sv_pvbyte(pTHX_ SV *sv)
{
+ sv_utf8_downgrade(sv,0);
return sv_pv(sv);
}
char *
Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
{
+ sv_utf8_downgrade(sv,0);
return sv_pvn(sv,lp);
}
char *
Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
{
+ sv_utf8_downgrade(sv,0);
return sv_pvn_force(sv,lp);
}
}
/*
+=for apidoc sv_setref_uv
+
+Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
+argument will be upgraded to an RV. That RV will be modified to point to
+the new SV. The C<classname> argument indicates the package for the
+blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
+will be returned and will have a reference count of 1.
+
+=cut
+*/
+
+SV*
+Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
+{
+ sv_setuv(newSVrv(rv,classname), uv);
+ return rv;
+}
+
+/*
=for apidoc sv_setref_nv
Copies a double into a new SV, optionally blessing the SV. The C<rv>
/*
=for apidoc sv_catpvf
-Processes its arguments like C<sprintf> and appends the formatted output
-to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
-typically be called after calling this function to handle 'set' magic.
+Processes its arguments like C<sprintf> and appends the formatted
+output to an SV. If the appended data contains "wide" characters
+(including, but not limited to, SVs with a UTF-8 PV formatted with %s,
+and characters >255 formatted with %c), the original SV might get
+upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
+C<SvSETMAGIC()> must typically be called after calling this function
+to handle 'set' magic.
-=cut
-*/
+=cut */
void
Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
}
-I32
+STATIC I32
S_expect_number(pTHX_ char** pattern)
{
I32 var = 0;
q++;
if (vectorize)
goto unknown;
- if (vectorarg = asterisk) {
+ if ((vectorarg = asterisk)) {
evix = ewix;
ewix = 0;
asterisk = FALSE;
case 'c':
uv = args ? va_arg(*args, int) : SvIVx(argsv);
- if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
+ if ((uv > 255 ||
+ (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
+ && !IN_BYTE) {
eptr = (char*)utf8buf;
- elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
+ elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
is_utf = TRUE;
}
else {
if (!veclen)
continue;
if (vec_utf)
- iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
+ iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
else {
iv = *vecstr;
ulen = 1;
if (!veclen)
continue;
if (vec_utf)
- uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
+ uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
else {
uv = *vecstr;
ulen = 1;
MAGIC *
Perl_mg_dup(pTHX_ MAGIC *mg)
{
- MAGIC *mgret = (MAGIC*)NULL;
- MAGIC *mgprev;
+ MAGIC *mgprev = (MAGIC*)NULL;
+ MAGIC *mgret;
if (!mg)
return (MAGIC*)NULL;
/* look for it in the table first */
for (; mg; mg = mg->mg_moremagic) {
MAGIC *nmg;
Newz(0, nmg, 1, MAGIC);
- if (!mgret)
- mgret = nmg;
- else
+ if (mgprev)
mgprev->mg_moremagic = nmg;
+ else
+ mgret = nmg;
nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
nmg->mg_private = mg->mg_private;
nmg->mg_type = mg->mg_type;
}
}
+void
+Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
+{
+ register PTR_TBL_ENT_t **array;
+ register PTR_TBL_ENT_t *entry;
+ register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
+ UV riter = 0;
+ UV max;
+
+ if (!tbl || !tbl->tbl_items) {
+ return;
+ }
+
+ array = tbl->tbl_ary;
+ entry = array[0];
+ max = tbl->tbl_max;
+
+ for (;;) {
+ if (entry) {
+ oentry = entry;
+ entry = entry->next;
+ Safefree(oentry);
+ }
+ if (!entry) {
+ if (++riter > max) {
+ break;
+ }
+ entry = array[riter];
+ }
+ }
+
+ tbl->tbl_items = 0;
+}
+
+void
+Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
+{
+ if (!tbl) {
+ return;
+ }
+ ptr_table_clear(tbl);
+ Safefree(tbl->tbl_ary);
+ Safefree(tbl);
+}
+
#ifdef DEBUGGING
char *PL_watch_pvx;
#endif
+STATIC SV *
+S_gv_share(pTHX_ SV *sstr)
+{
+ GV *gv = (GV*)sstr;
+ SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
+
+ if (GvIO(gv) || GvFORM(gv)) {
+ GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
+ }
+ else if (!GvCV(gv)) {
+ GvCV(gv) = (CV*)sv;
+ }
+ else {
+ /* CvPADLISTs cannot be shared */
+ if (!CvXSUB(GvCV(gv))) {
+ GvSHARED_off(gv);
+ }
+ }
+
+ if (!GvSHARED(gv)) {
+#if 0
+ PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
+ HvNAME(GvSTASH(gv)), GvNAME(gv));
+#endif
+ return Nullsv;
+ }
+
+ /*
+ * write attempts will die with
+ * "Modification of a read-only value attempted"
+ */
+ if (!GvSV(gv)) {
+ GvSV(gv) = sv;
+ }
+ else {
+ SvREADONLY_on(GvSV(gv));
+ }
+
+ if (!GvAV(gv)) {
+ GvAV(gv) = (AV*)sv;
+ }
+ else {
+ SvREADONLY_on(GvAV(gv));
+ }
+
+ if (!GvHV(gv)) {
+ GvHV(gv) = (HV*)sv;
+ }
+ else {
+ SvREADONLY_on(GvAV(gv));
+ }
+
+ return sstr; /* he_dup() will SvREFCNT_inc() */
+}
+
SV *
Perl_sv_dup(pTHX_ SV *sstr)
{
LvTYPE(dstr) = LvTYPE(sstr);
break;
case SVt_PVGV:
+ if (GvSHARED((GV*)sstr)) {
+ SV *share;
+ if ((share = gv_share(sstr))) {
+ del_SV(dstr);
+ dstr = share;
+#if 0
+ PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
+ HvNAME(GvSTASH(share)), GvNAME(share));
+#endif
+ break;
+ }
+ }
SvANY(dstr) = new_XPVGV();
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
CvXSUB(dstr) = CvXSUB(sstr);
CvXSUBANY(dstr) = CvXSUBANY(sstr);
- CvGV(dstr) = gv_dup_inc(CvGV(sstr));
+ CvGV(dstr) = gv_dup(CvGV(sstr));
CvDEPTH(dstr) = CvDEPTH(sstr);
if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
/* XXX padlists are real, but pretend to be not */
}
else
CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
- CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
+ if (!CvANON(sstr) || CvCLONED(sstr))
+ CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
+ else
+ CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
CvFLAGS(dstr) = CvFLAGS(sstr);
break;
default:
ncx->blk_sub.argarray = (cx->blk_sub.hasargs
? av_dup_inc(cx->blk_sub.argarray)
: Nullav);
- ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
+ ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
ncx->blk_sub.lval = cx->blk_sub.lval;
TOPIV(nss,ix) = iv;
break;
case SAVEt_FREESV:
+ case SAVEt_MORTALIZESV:
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup_inc(sv);
break;
PL_defgv = gv_dup(proto_perl->Idefgv);
PL_argvgv = gv_dup(proto_perl->Iargvgv);
PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
- PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
+ PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
/* shortcuts to regexp stuff */
PL_replgv = gv_dup(proto_perl->Ireplgv);
PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
PL_numeric_standard = proto_perl->Inumeric_standard;
PL_numeric_local = proto_perl->Inumeric_local;
- PL_numeric_radix = proto_perl->Inumeric_radix;
+ PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
#endif /* !USE_LOCALE_NUMERIC */
/* utf8 character classes */
/* thrdvar.h stuff */
- if (flags & 1) {
+ if (flags & CLONEf_COPY_STACKS) {
/* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
PL_tmps_ix = proto_perl->Ttmps_ix;
PL_tmps_max = proto_perl->Ttmps_max;
PL_regendp = (I32*)NULL;
PL_reglastparen = (U32*)NULL;
PL_regtill = Nullch;
- PL_regprev = '\n';
PL_reg_start_tmp = (char**)NULL;
PL_reg_start_tmpl = 0;
PL_regdata = (struct reg_data*)NULL;
PL_reginterp_cnt = 0;
PL_reg_starttry = 0;
+ if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
+ ptr_table_free(PL_ptr_table);
+ PL_ptr_table = NULL;
+ }
+
#ifdef PERL_OBJECT
return (PerlInterpreter*)pPerl;
#else
https://perl5.git.perl.org / perl5.git / blobdiff