* "I wonder what the Entish is for 'yes' and 'no'," he thought.
*
*
- * Manipulation of scalar values (SVs). This file contains the code that
- * creates, manipulates and destroys SVs. (Opcode-level functions on SVs
- * can be found in the various pp*.c files.) Note that the basic structure
- * of an SV is also used to hold the other major Perl data types - AVs,
- * HVs, GVs, IO etc. Low-level functions on these other types - such as
- * memory allocation and destruction - are handled within this file, while
- * higher-level stuff can be found in the individual files av.c, hv.c,
- * etc.
+ * This file contains the code that creates, manipulates and destroys
+ * scalar values (SVs). The other types (AV, HV, GV, etc.) reuse the
+ * structure of an SV, so their creation and destruction is handled
+ * here; higher-level functions are in av.c, hv.c, and so on. Opcode
+ * level functions (eg. substr, split, join) for each of the types are
+ * in the pp*.c files.
*/
#include "EXTERN.h"
#define PERL_IN_SV_C
#include "perl.h"
+#include "regcomp.h"
#define FCALL *f
#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
=head1 Allocation and deallocation of SVs.
-An SV (or AV, HV etc) is in 2 parts: the head and the body. There is only
-one type of head, but around 13 body types. Head and body are each
-separately allocated. Normally, this allocation is done using arenas,
-which are approximately 1K chunks of memory parcelled up into N heads or
-bodies. The first slot in each arena is reserved, and is used to hold a
-link to the next arena. In the case of heads, the unused first slot
-also contains some flags and a note of the number of slots. Snaked through
-each arena chain is a linked list of free items; when this becomes empty,
-an extra arena is allocated and divided up into N items which are threaded
-into the free list.
+An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv,
+av, hv...) contains type and reference count information, as well as a
+pointer to the body (struct xrv, xpv, xpviv...), which contains fields
+specific to each type.
+
+Normally, this allocation is done using arenas, which are approximately
+1K chunks of memory parcelled up into N heads or bodies. The first slot
+in each arena is reserved, and is used to hold a link to the next arena.
+In the case of heads, the unused first slot also contains some flags and
+a note of the number of slots. Snaked through each arena chain is a
+linked list of free items; when this becomes empty, an extra arena is
+allocated and divided up into N items which are threaded into the free
+list.
The following global variables are associated with arenas:
Similarly, there are macros new_XIV()/del_XIV(), new_XNV()/del_XNV() etc
that allocate and return individual body types. Normally these are mapped
-to the arena-maniplulating functions new_xiv()/del_xiv() etc, but may be
-instead mapped directly to malloc()/free() if PURIFY is in effect. The
+to the arena-manipulating functions new_xiv()/del_xiv() etc, but may be
+instead mapped directly to malloc()/free() if PURIFY is defined. The
new/del functions remove from, or add to, the appropriate PL_foo_root
list, and call more_xiv() etc to add a new arena if the list is empty.
-It the time of very final cleanup, sv_free_arenas() is called from
+At the time of very final cleanup, sv_free_arenas() is called from
perl_destruct() to physically free all the arenas allocated since the
start of the interpreter. Note that this also clears PL_he_arenaroot,
which is otherwise dealt with in hv.c.
Public API:
- sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
+ sv_report_used(), sv_clean_objs(), sv_clean_all(), sv_free_arenas()
=cut
/*
+=head1 SV Manipulation Functions
+
=for apidoc sv_add_arena
Given a chunk of memory, link it to the head of the list of arenas,
return sv;
}
-/* visit(): call the named function for each non-free in SV the arenas. */
+/* visit(): call the named function for each non-free SV in the arenas. */
STATIC I32
S_visit(pTHX_ SVFUNC_t f)
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
- (FCALL)(aTHXo_ sv);
+ (FCALL)(aTHX_ sv);
++visited;
}
}
return visited;
}
+#ifdef DEBUGGING
+
/* called by sv_report_used() for each live SV */
static void
-do_report_used(pTHXo_ SV *sv)
+do_report_used(pTHX_ SV *sv)
{
if (SvTYPE(sv) != SVTYPEMASK) {
PerlIO_printf(Perl_debug_log, "****\n");
sv_dump(sv);
}
}
+#endif
/*
=for apidoc sv_report_used
void
Perl_sv_report_used(pTHX)
{
+#ifdef DEBUGGING
visit(do_report_used);
+#endif
}
/* called by sv_clean_objs() for each live SV */
static void
-do_clean_objs(pTHXo_ SV *sv)
+do_clean_objs(pTHX_ SV *sv)
{
SV* rv;
#ifndef DISABLE_DESTRUCTOR_KLUDGE
static void
-do_clean_named_objs(pTHXo_ SV *sv)
+do_clean_named_objs(pTHX_ SV *sv)
{
if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
if ( SvOBJECT(GvSV(sv)) ||
/* called by sv_clean_all() for each live SV */
static void
-do_clean_all(pTHXo_ SV *sv)
+do_clean_all(pTHX_ SV *sv)
{
DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
Decrement the refcnt of each remaining SV, possibly triggering a
cleanup. This function may have to be called multiple times to free
-SVs which are in complex self-referential heirarchies.
+SVs which are in complex self-referential hierarchies.
=cut
*/
{
if (PL_op)
Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
- " in ", PL_op_desc[PL_op->op_type]);
+ " in ", OP_DESC(PL_op));
else
Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
}
/*
=for apidoc sv_upgrade
-Upgrade an SV to a more complex form. Gnenerally adds a new body type to the
+Upgrade an SV to a more complex form. Generally adds a new body type to the
SV, then copies across as much information as possible from the old body.
-You genrally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
+You generally want to use the C<SvUPGRADE> macro wrapper. See also C<svtype>.
=cut
*/
SvPVX(sv) = 0;
HvFILL(sv) = 0;
HvMAX(sv) = 0;
- HvKEYS(sv) = 0;
- SvNVX(sv) = 0.0;
+ HvTOTALKEYS(sv) = 0;
+ HvPLACEHOLDERS(sv) = 0;
SvMAGIC(sv) = magic;
SvSTASH(sv) = stash;
HvRITER(sv) = 0;
#endif
Renew(s,newlen,char);
}
- else
- New(703,s,newlen,char);
+ else {
+ /* sv_force_normal_flags() must not try to unshare the new
+ PVX we allocate below. AMS 20010713 */
+ if (SvREADONLY(sv) && SvFAKE(sv)) {
+ SvFAKE_off(sv);
+ SvREADONLY_off(sv);
+ }
+ New(703, s, newlen, char);
+ }
SvPV_set(sv, s);
SvLEN_set(sv, newlen);
}
case SVt_PVFM:
case SVt_PVIO:
Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
- PL_op_desc[PL_op->op_type]);
+ OP_DESC(PL_op));
}
(void)SvIOK_only(sv); /* validate number */
SvIVX(sv) = i;
case SVt_PVFM:
case SVt_PVIO:
Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
}
SvNVX(sv) = num;
(void)SvNOK_only(sv); /* validate number */
STATIC void
S_not_a_number(pTHX_ SV *sv)
{
- char tmpbuf[64];
- char *d = tmpbuf;
- char *limit = tmpbuf + sizeof(tmpbuf) - 8;
- /* each *s can expand to 4 chars + "...\0",
- i.e. need room for 8 chars */
-
- 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++ = '-';
- ch &= 127;
- }
- if (ch == '\n') {
- *d++ = '\\';
- *d++ = 'n';
- }
- else if (ch == '\r') {
- *d++ = '\\';
- *d++ = 'r';
- }
- else if (ch == '\f') {
- *d++ = '\\';
- *d++ = 'f';
- }
- else if (ch == '\\') {
- *d++ = '\\';
- *d++ = '\\';
- }
- else if (ch == '\0') {
- *d++ = '\\';
- *d++ = '0';
- }
- else if (isPRINT_LC(ch))
- *d++ = ch;
- else {
- *d++ = '^';
- *d++ = toCTRL(ch);
- }
- }
- if (s < end) {
- *d++ = '.';
- *d++ = '.';
- *d++ = '.';
+ SV *dsv;
+ char tmpbuf[64];
+ char *pv;
+
+ if (DO_UTF8(sv)) {
+ dsv = sv_2mortal(newSVpv("", 0));
+ pv = sv_uni_display(dsv, sv, 10, 0);
+ } else {
+ char *d = tmpbuf;
+ char *limit = tmpbuf + sizeof(tmpbuf) - 8;
+ /* each *s can expand to 4 chars + "...\0",
+ i.e. need room for 8 chars */
+
+ 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++ = '-';
+ ch &= 127;
+ }
+ if (ch == '\n') {
+ *d++ = '\\';
+ *d++ = 'n';
+ }
+ else if (ch == '\r') {
+ *d++ = '\\';
+ *d++ = 'r';
+ }
+ else if (ch == '\f') {
+ *d++ = '\\';
+ *d++ = 'f';
+ }
+ else if (ch == '\\') {
+ *d++ = '\\';
+ *d++ = '\\';
+ }
+ else if (ch == '\0') {
+ *d++ = '\\';
+ *d++ = '0';
+ }
+ else if (isPRINT_LC(ch))
+ *d++ = ch;
+ else {
+ *d++ = '^';
+ *d++ = toCTRL(ch);
+ }
+ }
+ if (s < end) {
+ *d++ = '.';
+ *d++ = '.';
+ *d++ = '.';
+ }
+ *d = '\0';
+ pv = tmpbuf;
}
- *d = '\0';
if (PL_op)
Perl_warner(aTHX_ WARN_NUMERIC,
- "Argument \"%s\" isn't numeric in %s", tmpbuf,
- PL_op_desc[PL_op->op_type]);
+ "Argument \"%s\" isn't numeric in %s", pv,
+ OP_DESC(PL_op));
else
Perl_warner(aTHX_ WARN_NUMERIC,
- "Argument \"%s\" isn't numeric", tmpbuf);
+ "Argument \"%s\" isn't numeric", pv);
}
/*
STATIC int
S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
{
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
) {
SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
+ "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
PTR2UV(sv),
SvNVX(sv),
SvIVX(sv)));
that PV->IV would be better than PV->NV->IV
flags already correct - don't set public IOK. */
DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
+ "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
PTR2UV(sv),
SvNVX(sv),
SvIVX(sv)));
/* SVt_PVNV is one higher than SVt_PVIV, hence this order */
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
- /* It's defintately an integer, only upgrade to PVIV */
+ /* It's definitely an integer, only upgrade to PVIV */
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
SvIVX(sv) = -(IV)value;
} else {
/* Too negative for an IV. This is a double upgrade, but
- I'm assuming it will be be rare. */
+ I'm assuming it will be rare. */
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
SvNOK_on(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
PTR2UV(sv), SvNVX(sv)));
#else
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
PTR2UV(sv), SvNVX(sv)));
#endif
this NV is in the preserved range, therefore: */
if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
< (UV)IV_MAX)) {
- Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+ Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
}
} else {
/* IN_UV NOT_INT
) {
SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
+ "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
PTR2UV(sv),
SvNVX(sv),
SvIVX(sv)));
that PV->IV would be better than PV->NV->IV
flags already correct - don't set public IOK. */
DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
+ "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
PTR2UV(sv),
SvNVX(sv),
SvIVX(sv)));
/* SVt_PVNV is one higher than SVt_PVIV, hence this order */
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
- /* It's defintately an integer, only upgrade to PVIV */
+ /* It's definitely an integer, only upgrade to PVIV */
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
SvIVX(sv) = -(IV)value;
} else {
/* Too negative for an IV. This is a double upgrade, but
- I'm assuming it will be be rare. */
+ I'm assuming it will be rare. */
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
SvNOK_on(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
PTR2UV(sv), SvNVX(sv)));
#else
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
PTR2UV(sv), SvNVX(sv)));
#endif
this NV is in the preserved range, therefore: */
if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
< (UV)IV_MAX)) {
- Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+ Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
}
} else
sv_2iuv_non_preserve (sv, numtype);
#else
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
+ PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
- if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
- SvNOK_on(sv);
+ if (SvNOKp(sv)) {
+ return SvNVX(sv);
}
- else if (SvIOKp(sv)) {
+ if (SvIOKp(sv)) {
SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
#ifdef NV_PRESERVES_UV
SvNOK_on(sv);
#ifdef NV_PRESERVES_UV
if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
== IS_NUMBER_IN_UV) {
- /* It's defintately an integer */
+ /* It's definitely an integer */
SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
} else
SvNVX(sv) = Atof(SvPVX(sv));
#else
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
+ PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
/*
=for apidoc sv_2pv_flags
-Returns pointer to the string value of an SV, and sets *lp to its length.
+Returns a pointer to the string value of an SV, and sets *lp to its length.
If flags includes SV_GMAGIC, does an mg_get() first. Coerces sv to a string
if necessary.
Normally invoked via the C<SvPV_flags> macro. C<sv_2pv()> and C<sv_2pv_nomg>
default: s = "UNKNOWN"; break;
}
tsv = NEWSV(0,0);
- if (SvOBJECT(sv))
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
+ if (SvOBJECT(sv)) {
+ HV *svs = SvSTASH(sv);
+ Perl_sv_setpvf(
+ aTHX_ tsv, "%s=%s",
+ /* [20011101.072] This bandaid for C<package;>
+ should eventually be removed. AMS 20011103 */
+ (svs ? HvNAME(svs) : "<none>"), s
+ );
+ }
else
sv_setpv(tsv, s);
Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
=for apidoc sv_2bool
This function is only called on magical items, and is only used by
-sv_true() or its macro equivalent.
+sv_true() or its macro equivalent.
=cut
*/
if (SvROK(sv)) {
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
- (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
+ (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
return SvTRUE(tmpsv);
return SvRV(sv) != 0;
}
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 = (U8 *) SvPVX(sv);
- e = (U8 *) SvEND(sv);
- t = s;
- while (t < e) {
- U8 ch = *t++;
- if ((hibit = !NATIVE_IS_INVARIANT(ch)))
- break;
- }
- if (hibit) {
- STRLEN len;
-
- 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. */
+ if (PL_encoding)
+ Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
+ else { /* Assume Latin-1/EBCDIC */
+ /* 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 such a flag
+ * make the loop as fast as possible. */
+ s = (U8 *) SvPVX(sv);
+ e = (U8 *) SvEND(sv);
+ t = s;
+ while (t < e) {
+ U8 ch = *t++;
+ if ((hibit = !NATIVE_IS_INVARIANT(ch)))
+ break;
+ }
+ if (hibit) {
+ STRLEN len;
+
+ 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. */
+ }
+ /* Mark as UTF-8 even if no hibit - saves scanning loop */
+ SvUTF8_on(sv);
}
- /* Mark as UTF-8 even if no hibit - saves scanning loop */
- SvUTF8_on(sv);
return SvCUR(sv);
}
if (first && ch > 255) {
if (PL_op)
Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
- PL_op_desc[PL_op->op_type]);
+ OP_DESC(PL_op);
else
Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
first = 0;
else {
if (PL_op)
Perl_croak(aTHX_ "Wide character in %s",
- PL_op_desc[PL_op->op_type]);
+ OP_DESC(PL_op));
else
Perl_croak(aTHX_ "Wide character");
}
case SVt_PVIO:
if (PL_op)
Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
else
Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
break;
Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
GvNAME(dstr));
-#ifdef GV_SHARED_CHECK
- if (GvSHARED((GV*)dstr)) {
+#ifdef GV_UNIQUE_CHECK
+ if (GvUNIQUE((GV*)dstr)) {
Perl_croak(aTHX_ PL_no_modify);
}
#endif
SV *dref = 0;
int intro = GvINTRO(dstr);
-#ifdef GV_SHARED_CHECK
- if (GvSHARED((GV*)dstr)) {
+#ifdef GV_UNIQUE_CHECK
+ if (GvUNIQUE((GV*)dstr)) {
Perl_croak(aTHX_ PL_no_modify);
}
#endif
*SvEND(sv) = '\0';
SvFAKE_off(sv);
SvREADONLY_off(sv);
- unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
+ unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
}
else if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
if (!ssv)
return;
if ((spv = SvPV(ssv, slen))) {
- bool sutf8 = DO_UTF8(ssv);
- bool dutf8;
+ /* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
+ gcc version 2.95.2 20000220 (Debian GNU/Linux) for
+ Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously
+ get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though
+ dsv->sv_flags doesn't have that bit set.
+ Andy Dougherty 12 Oct 2001
+ */
+ I32 sutf8 = DO_UTF8(ssv);
+ I32 dutf8;
if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
mg_get(dsv);
SvMAGIC(sv) = mg;
/* 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. */
+ each other. To prevent 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 == PERL_MAGIC_arylen ||
how == PERL_MAGIC_qr ||
case PERL_MAGIC_dbline:
mg->mg_virtual = &PL_vtbl_dbline;
break;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
case PERL_MAGIC_mutex:
mg->mg_virtual = &PL_vtbl_mutex;
break;
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
#ifdef USE_LOCALE_COLLATE
case PERL_MAGIC_collxfrm:
mg->mg_virtual = &PL_vtbl_collxfrm;
The target SV physically takes over ownership of the body of the source SV
and inherits its flags; however, the target keeps any magic it owns,
and any magic in the source is discarded.
-Note that this a rather specialist SV copying operation; most of the
+Note that this is a rather specialist SV copying operation; most of the
time you'll want to use C<sv_setsv> or one of its many macro front-ends.
=cut
else if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
- unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
+ unsharepvn(SvPVX(sv),
+ SvUTF8(sv) ? -(I32)SvCUR(sv) : SvCUR(sv),
+ SvUVX(sv));
SvFAKE_off(sv);
}
break;
STRLEN
Perl_sv_len(pTHX_ register SV *sv)
{
- char *junk;
STRLEN len;
if (!sv)
if (SvGMAGICAL(sv))
len = mg_length(sv);
else
- junk = SvPV(sv, len);
+ (void)SvPV(sv, len);
return len;
}
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
bool is_utf8 = TRUE;
/* UTF-8ness differs */
- if (PL_hints & HINT_UTF8_DISTINCT)
- return FALSE;
if (SvUTF8(sv1)) {
/* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
/* do not utf8ize the comparands as a side-effect */
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
- if (PL_hints & HINT_UTF8_DISTINCT)
- return SvUTF8(sv1) ? 1 : -1;
-
if (SvUTF8(sv1)) {
pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
pv2tmp = TRUE;
register STDCHAR *bp;
register I32 cnt;
I32 i = 0;
+ I32 rspara = 0;
SV_CHECK_THINKFIRST(sv);
(void)SvUPGRADE(sv, SVt_PV);
SvSCREAM_off(sv);
- if (RsSNARF(PL_rs)) {
+ if (PL_curcop == &PL_compiling) {
+ /* we always read code in line mode */
+ rsptr = "\n";
+ rslen = 1;
+ }
+ else if (RsSNARF(PL_rs)) {
rsptr = NULL;
rslen = 0;
}
else if (RsPARA(PL_rs)) {
rsptr = "\n\n";
rslen = 2;
+ rspara = 1;
}
else {
/* Get $/ i.e. PL_rs into same encoding as stream wants */
rslast = rslen ? rsptr[rslen - 1] : '\0';
- if (RsPARA(PL_rs)) { /* have to do this both before and after */
+ if (rspara) { /* have to do this both before and after */
do { /* to make sure file boundaries work right */
if (PerlIO_eof(fp))
return 0;
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: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
+ "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
for (;;) {
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
PTR2UV(ptr),(long)cnt));
- PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
+ PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
+#if 0
DEBUG_P(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),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+#endif
/* This used to call 'filbuf' in stdio form, but as that behaves like
getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
another abstraction. */
i = PerlIO_getc(fp); /* get more characters */
+#if 0
DEBUG_P(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),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+#endif
cnt = PerlIO_get_cnt(fp);
ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
cnt += shortbuffered;
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
- PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
+ 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),
}
}
- if (RsPARA(PL_rs)) { /* have to do this both before and after */
+ if (rspara) { /* have to do this both before and after */
while (i != EOF) { /* to make sure file boundaries work right */
i = PerlIO_getc(fp);
if (i != '\n') {
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv) && SvFAKE(sv))
+ sv_force_normal(sv);
if (SvREADONLY(sv)) {
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
}
if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
/* It's publicly an integer, or privately an integer-not-float */
+#ifdef PERL_PRESERVE_IVUV
oops_its_int:
+#endif
if (SvIsUV(sv)) {
if (SvUVX(sv) == UV_MAX)
- sv_setnv(sv, (NV)UV_MAX + 1.0);
+ sv_setnv(sv, UV_MAX_P1);
else
(void)SvIOK_only_UV(sv);
++SvUVX(sv);
while (isDIGIT(*d)) d++;
if (*d) {
#ifdef PERL_PRESERVE_IVUV
- /* Got to punt this an an integer if needs be, but we don't issue
+ /* Got to punt this as an integer if needs be, but we don't issue
warnings. Probably ought to make the sv_iv_please() that does
the conversion if possible, and silently. */
int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
SvPVX(sv), SvIVX(sv), SvNVX(sv)));
#else
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
SvPVX(sv), SvIVX(sv), SvNVX(sv)));
#endif
}
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv) && SvFAKE(sv))
+ sv_force_normal(sv);
if (SvREADONLY(sv)) {
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
flags = SvFLAGS(sv);
if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
/* It's publicly an integer, or privately an integer-not-float */
+#ifdef PERL_PRESERVE_IVUV
oops_its_int:
+#endif
if (SvIsUV(sv)) {
if (SvUVX(sv) == 0) {
(void)SvIOK_only(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
SvPVX(sv), SvIVX(sv), SvNVX(sv)));
#else
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
SvPVX(sv), SvIVX(sv), SvNVX(sv)));
#endif
}
=for apidoc sv_mortalcopy
Creates a new SV which is a copy of the original SV (using C<sv_setsv>).
-The new SV is marked as mortal. It will be destroyed when the current
-context ends. See also C<sv_newmortal> and C<sv_2mortal>.
+The new SV is marked as mortal. It will be destroyed "soon", either by an
+explicit call to FREETMPS, or by an implicit call at places such as
+statement boundaries. See also C<sv_newmortal> and C<sv_2mortal>.
=cut
*/
=for apidoc sv_newmortal
Creates a new null SV which is mortal. The reference count of the SV is
-set to 1. It will be destroyed when the current context ends. See
-also C<sv_mortalcopy> and C<sv_2mortal>.
+set to 1. It will be destroyed "soon", either by an explicit call to
+FREETMPS, or by an implicit call at places such as statement boundaries.
+See also C<sv_mortalcopy> and C<sv_2mortal>.
=cut
*/
/*
=for apidoc sv_2mortal
-Marks an existing SV as mortal. The SV will be destroyed when the current
-context ends. See also C<sv_newmortal> and C<sv_mortalcopy>.
+Marks an existing SV as mortal. The SV will be destroyed "soon", either
+by an explicit call to FREETMPS, or by an implicit call at places such as
+statement boundaries. See also C<sv_newmortal> and C<sv_mortalcopy>.
=cut
*/
register SV *sv;
bool is_utf8 = FALSE;
if (len < 0) {
- len = -len;
+ STRLEN tmplen = -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;
return sv;
}
-/* newRV_inc is the offical function name to use now.
+/* newRV_inc is the official function name to use now.
* newRV_inc is in fact #defined to newRV in sv.h
*/
return sv_2pv(sv, lp);
}
+/* For -DCRIPPLED_CC only. See also C<sv_2pv_flags()>.
+ */
+
+char *
+Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
+{
+ if (SvPOK(sv)) {
+ *lp = SvCUR(sv);
+ return SvPVX(sv);
+ }
+ return sv_2pv_flags(sv, lp, 0);
+}
+
/*
=for apidoc sv_pvn_force
else {
if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
- PL_op_name[PL_op->op_type]);
+ OP_NAME(PL_op));
}
else
s = sv_2pv_flags(sv, lp, flags);
char *
Perl_sv_reftype(pTHX_ SV *sv, int ob)
{
- if (ob && SvOBJECT(sv))
- return HvNAME(SvSTASH(sv));
+ if (ob && SvOBJECT(sv)) {
+ HV *svs = SvSTASH(sv);
+ /* [20011101.072] This bandaid for C<package;> should eventually
+ be removed. AMS 20011103 */
+ return (svs ? HvNAME(svs) : "<none>");
+ }
else {
switch (SvTYPE(sv)) {
case SVt_NULL:
else
SvAMAGIC_off(sv);
+ if(SvSMAGICAL(tmpRef))
+ if(mg_find(tmpRef, PERL_MAGIC_ext) || mg_find(tmpRef, PERL_MAGIC_uvar))
+ mg_set(tmpRef);
+
+
+
return sv;
}
I32 svix = 0;
static char nullstr[] = "(null)";
SV *argsv = Nullsv;
+ bool has_utf8 = FALSE; /* has the result utf8? */
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
}
}
+ if (!args && svix < svmax && DO_UTF8(*svargs))
+ has_utf8 = TRUE;
+
patend = (char*)pat + patlen;
for (p = (char*)pat; p < patend; p = q) {
bool alt = FALSE;
bool left = FALSE;
bool vectorize = FALSE;
bool vectorarg = FALSE;
- bool vec_utf = FALSE;
+ bool vec_utf8 = FALSE;
char fill = ' ';
char plus = 0;
char intsize = 0;
STRLEN zeros = 0;
bool has_precis = FALSE;
STRLEN precis = 0;
- bool is_utf = FALSE;
+ bool is_utf8 = FALSE; /* is this item utf8? */
char esignbuf[4];
U8 utf8buf[UTF8_MAXLEN+1];
char c;
int i;
unsigned base = 0;
- IV iv;
- UV uv;
+ IV iv = 0;
+ UV uv = 0;
NV nv;
STRLEN have;
STRLEN need;
svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
dotstr = SvPVx(vecsv, dotstrlen);
if (DO_UTF8(vecsv))
- is_utf = TRUE;
+ is_utf8 = TRUE;
}
if (args) {
vecsv = va_arg(*args, SV*);
vecstr = (U8*)SvPVx(vecsv,veclen);
- vec_utf = DO_UTF8(vecsv);
+ vec_utf8 = DO_UTF8(vecsv);
}
else if (efix ? efix <= svmax : svix < svmax) {
vecsv = svargs[efix ? efix-1 : svix++];
vecstr = (U8*)SvPVx(vecsv,veclen);
- vec_utf = DO_UTF8(vecsv);
+ vec_utf8 = DO_UTF8(vecsv);
}
else {
vecstr = (U8*)"";
q++;
if (*q == '*') {
q++;
- if (EXPECT_NUMBER(q, epix) && *q++ != '$')
+ if (EXPECT_NUMBER(q, epix) && *q++ != '$') /* epix currently unused */
goto unknown;
if (args)
i = va_arg(*args, int);
&& !IN_BYTES) {
eptr = (char*)utf8buf;
elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
- is_utf = TRUE;
+ is_utf8 = TRUE;
}
else {
c = (char)uv;
if (width) { /* fudge width (can't fudge elen) */
width += elen - sv_len_utf8(argsv);
}
- is_utf = TRUE;
+ is_utf8 = TRUE;
}
}
goto string;
argsv = va_arg(*args, SV*);
eptr = SvPVx(argsv, elen);
if (DO_UTF8(argsv))
- is_utf = TRUE;
+ is_utf8 = TRUE;
string:
vectorize = FALSE;
STRLEN ulen;
if (!veclen)
continue;
- if (vec_utf)
- iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
+ if (vec_utf8)
+ uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
+ UTF8_ALLOW_ANYUV);
else {
- iv = *vecstr;
+ uv = *vecstr;
ulen = 1;
}
vecstr += ulen;
veclen -= ulen;
+ if (plus)
+ esignbuf[esignlen++] = plus;
}
else if (args) {
switch (intsize) {
#endif
}
}
- if (iv >= 0) {
- uv = iv;
- if (plus)
- esignbuf[esignlen++] = plus;
- }
- else {
- uv = -iv;
- esignbuf[esignlen++] = '-';
+ if ( !vectorize ) /* we already set uv above */
+ {
+ if (iv >= 0) {
+ uv = iv;
+ if (plus)
+ esignbuf[esignlen++] = plus;
+ }
+ else {
+ uv = -iv;
+ esignbuf[esignlen++] = '-';
+ }
}
base = 10;
goto integer;
vector:
if (!veclen)
continue;
- if (vec_utf)
- uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
+ if (vec_utf8)
+ uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
+ UTF8_ALLOW_ANYUV);
else {
uv = *vecstr;
ulen = 1;
*p++ = '0';
}
if (elen) {
+ if (is_utf8 != has_utf8) {
+ if (is_utf8) {
+ if (SvCUR(sv)) {
+ sv_utf8_upgrade(sv);
+ p = SvEND(sv);
+ }
+ }
+ else {
+ SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
+ sv_utf8_upgrade(nsv);
+ eptr = SvPVX(nsv);
+ elen = SvCUR(nsv);
+ }
+ }
Copy(eptr, p, elen, char);
p += elen;
}
else
vectorize = FALSE; /* done iterating over vecstr */
}
- if (is_utf)
+ if (is_utf8)
+ has_utf8 = TRUE;
+ if (has_utf8)
SvUTF8_on(sv);
*p = '\0';
SvCUR(sv) = p - SvPVX(sv);
#if defined(USE_ITHREADS)
-#if defined(USE_THREADS)
-# include "error: USE_THREADS and USE_ITHREADS are incompatible"
+#if defined(USE_5005THREADS)
+# include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
#endif
#ifndef GpREFCNT_inc
#endif
-#define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
-#define av_dup(s) (AV*)sv_dup((SV*)s)
-#define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
-#define hv_dup(s) (HV*)sv_dup((SV*)s)
-#define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
-#define cv_dup(s) (CV*)sv_dup((SV*)s)
-#define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
-#define io_dup(s) (IO*)sv_dup((SV*)s)
-#define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
-#define gv_dup(s) (GV*)sv_dup((SV*)s)
-#define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
+#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
+#define av_dup(s,t) (AV*)sv_dup((SV*)s,t)
+#define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
+#define hv_dup(s,t) (HV*)sv_dup((SV*)s,t)
+#define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
+#define cv_dup(s,t) (CV*)sv_dup((SV*)s,t)
+#define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t))
+#define io_dup(s,t) (IO*)sv_dup((SV*)s,t)
+#define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t))
+#define gv_dup(s,t) (GV*)sv_dup((SV*)s,t)
+#define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t))
#define SAVEPV(p) (p ? savepv(p) : Nullch)
#define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
-/* duplicate a regexp */
+
+/* Duplicate a regexp. Required reading: pregcomp() and pregfree() in
+ regcomp.c. AMS 20010712 */
REGEXP *
-Perl_re_dup(pTHX_ REGEXP *r)
+Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param)
{
- /* XXX fix when pmop->op_pmregexp becomes shared */
- return ReREFCNT_inc(r);
+ 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;
+
+ Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
+ Copy(r->program, ret->program, len+1, regnode);
+
+ New(0, ret->startp, npar, I32);
+ Copy(r->startp, ret->startp, npar, I32);
+ New(0, ret->endp, npar, I32);
+ Copy(r->startp, ret->startp, npar, I32);
+
+ New(0, 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);
+ }
+
+ ret->regstclass = NULL;
+ if (r->data) {
+ struct reg_data *d;
+ int count = r->data->count;
+
+ Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *),
+ char, struct reg_data);
+ New(0, d->what, count, U8);
+
+ d->count = count;
+ for (i = 0; i < count; i++) {
+ d->what[i] = r->data->what[i];
+ switch (d->what[i]) {
+ 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. */
+ New(0, 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. */
+ d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
+ break;
+ case 'n':
+ d->data[i] = r->data->data[i];
+ break;
+ }
+ }
+
+ ret->data = d;
+ }
+ else
+ ret->data = NULL;
+
+ New(0, ret->offsets, 2*len+1, U32);
+ Copy(r->offsets, ret->offsets, 2*len+1, U32);
+
+ ret->precomp = SAVEPV(r->precomp);
+ 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 = SAVEPV(r->subbeg);
+ else
+ ret->subbeg = Nullch;
+
+ ptr_table_store(PL_ptr_table, r, ret);
+ return ret;
}
-/* duplicate a filke handle */
+/* duplicate a file handle */
PerlIO *
-Perl_fp_dup(pTHX_ PerlIO *fp, char type)
+Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param)
{
PerlIO *ret;
if (!fp)
return ret;
/* create anew and remember what it is */
- ret = PerlIO_fdupopen(aTHX_ fp);
+ ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
ptr_table_store(PL_ptr_table, fp, ret);
return ret;
}
return dp;
}
-/* duplictate a typeglob */
+/* duplicate a typeglob */
GP *
-Perl_gp_dup(pTHX_ GP *gp)
+Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param)
{
GP *ret;
if (!gp)
/* clone */
ret->gp_refcnt = 0; /* must be before any other dups! */
- ret->gp_sv = sv_dup_inc(gp->gp_sv);
- ret->gp_io = io_dup_inc(gp->gp_io);
- ret->gp_form = cv_dup_inc(gp->gp_form);
- ret->gp_av = av_dup_inc(gp->gp_av);
- ret->gp_hv = hv_dup_inc(gp->gp_hv);
- ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
- ret->gp_cv = cv_dup_inc(gp->gp_cv);
+ ret->gp_sv = sv_dup_inc(gp->gp_sv, param);
+ ret->gp_io = io_dup_inc(gp->gp_io, param);
+ ret->gp_form = cv_dup_inc(gp->gp_form, param);
+ ret->gp_av = av_dup_inc(gp->gp_av, param);
+ ret->gp_hv = hv_dup_inc(gp->gp_hv, param);
+ ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */
+ ret->gp_cv = cv_dup_inc(gp->gp_cv, param);
ret->gp_cvgen = gp->gp_cvgen;
ret->gp_flags = gp->gp_flags;
ret->gp_line = gp->gp_line;
/* duplicate a chain of magic */
MAGIC *
-Perl_mg_dup(pTHX_ MAGIC *mg)
+Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
{
MAGIC *mgprev = (MAGIC*)NULL;
MAGIC *mgret;
nmg->mg_type = mg->mg_type;
nmg->mg_flags = mg->mg_flags;
if (mg->mg_type == PERL_MAGIC_qr) {
- nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
+ nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj, param);
+ }
+ else if(mg->mg_type == PERL_MAGIC_backref) {
+ AV *av = (AV*) mg->mg_obj;
+ SV **svp;
+ I32 i;
+ nmg->mg_obj = (SV*)newAV();
+ svp = AvARRAY(av);
+ i = AvFILLp(av);
+ while (i >= 0) {
+ av_push((AV*)nmg->mg_obj,sv_dup(svp[i],param));
+ i--;
+ }
}
else {
nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
- ? sv_dup_inc(mg->mg_obj)
- : sv_dup(mg->mg_obj);
+ ? sv_dup_inc(mg->mg_obj, param)
+ : sv_dup(mg->mg_obj, param);
}
nmg->mg_len = mg->mg_len;
nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
AMT *namtp = (AMT*)nmg->mg_ptr;
I32 i;
for (i = 1; i < NofAMmeth; i++) {
- namtp->table[i] = cv_dup_inc(amtp->table[i]);
+ namtp->table[i] = cv_dup_inc(amtp->table[i], param);
}
}
}
else if (mg->mg_len == HEf_SVKEY)
- nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
+ nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
}
mgprev = nmg;
}
SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
if (GvIO(gv) || GvFORM(gv)) {
- GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
+ GvUNIQUE_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);
+ GvUNIQUE_off(gv);
}
}
- if (!GvSHARED(gv)) {
+ if (!GvUNIQUE(gv)) {
#if 0
PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
HvNAME(GvSTASH(gv)), GvNAME(gv));
/* duplicate an SV of any type (including AV, HV etc) */
SV *
-Perl_sv_dup(pTHX_ SV *sstr)
+Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
{
SV *dstr;
break;
case SVt_RV:
SvANY(dstr) = new_XRV();
- SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
- ? sv_dup(SvRV(sstr))
- : sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
break;
case SVt_PV:
SvANY(dstr) = new_XPV();
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
- ? sv_dup(SvRV(sstr))
- : sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
- ? sv_dup(SvRV(sstr))
- : sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
- ? sv_dup(SvRV(sstr))
- : sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
- ? sv_dup(SvRV(sstr))
- : sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
- ? sv_dup(SvRV(sstr))
- : sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
- ? sv_dup(SvRV(sstr))
- : sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
LvTARGLEN(dstr) = LvTARGLEN(sstr);
- LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
+ LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
LvTYPE(dstr) = LvTYPE(sstr);
break;
case SVt_PVGV:
- if (GvSHARED((GV*)sstr)) {
+ if (GvUNIQUE((GV*)sstr)) {
SV *share;
if ((share = gv_share(sstr))) {
del_SV(dstr);
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
- ? sv_dup(SvRV(sstr))
- : sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
GvNAMELEN(dstr) = GvNAMELEN(sstr);
GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
- GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
+ GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
GvFLAGS(dstr) = GvFLAGS(sstr);
- GvGP(dstr) = gp_dup(GvGP(sstr));
+ GvGP(dstr) = gp_dup(GvGP(sstr), param);
(void)GpREFCNT_inc(GvGP(dstr));
break;
case SVt_PVIO:
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
- ? sv_dup(SvRV(sstr))
- : sv_dup_inc(SvRV(sstr));
+ SvRV(dstr) = SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
- IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
+ IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
if (IoOFP(sstr) == IoIFP(sstr))
IoOFP(dstr) = IoIFP(dstr);
else
- IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
+ IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr), param);
/* PL_rsfp_filters entries have fake IoDIRP() */
if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
- IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
+ IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
- IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
+ IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
- IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
+ IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
IoTYPE(dstr) = IoTYPE(sstr);
IoFLAGS(dstr) = IoFLAGS(sstr);
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
- AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
+ AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr), param);
AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
if (AvARRAY((AV*)sstr)) {
SV **dst_ary, **src_ary;
AvALLOC((AV*)dstr) = dst_ary;
if (AvREAL((AV*)sstr)) {
while (items-- > 0)
- *dst_ary++ = sv_dup_inc(*src_ary++);
+ *dst_ary++ = sv_dup_inc(*src_ary++, param);
}
else {
while (items-- > 0)
- *dst_ary++ = sv_dup(*src_ary++);
+ *dst_ary++ = sv_dup(*src_ary++, param);
}
items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
while (items-- > 0) {
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
if (HvARRAY((HV*)sstr)) {
STRLEN i = 0;
PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
while (i <= sxhv->xhv_max) {
((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
- !!HvSHAREKEYS(sstr));
+ !!HvSHAREKEYS(sstr), param);
++i;
}
- dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
+ dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param);
}
else {
SvPVX(dstr) = Nullch;
}
HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
- /* Record stashes for possible cloning in Perl_clone_using(). */
+ /* Record stashes for possible cloning in Perl_clone(). */
if(HvNAME((HV*)dstr))
- av_push(PL_clone_callbacks, dstr);
+ av_push(param->stashes, dstr);
break;
case SVt_PVFM:
SvANY(dstr) = new_XPVFM();
/* NOTREACHED */
case SVt_PVCV:
SvANY(dstr) = new_XPVCV();
-dup_pvcv:
+ dup_pvcv:
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
- SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
+ SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
+ SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvPVX(sstr) && SvLEN(sstr))
SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
else
SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
- CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
+ CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
CvSTART(dstr) = CvSTART(sstr);
CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
CvXSUB(dstr) = CvXSUB(sstr);
CvXSUBANY(dstr) = CvXSUBANY(sstr);
- CvGV(dstr) = gv_dup(CvGV(sstr));
- CvDEPTH(dstr) = CvDEPTH(sstr);
+ if (CvCONST(sstr)) {
+ CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
+ SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
+ sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
+ }
+ CvGV(dstr) = gv_dup(CvGV(sstr), param);
+ if (param->flags & CLONEf_COPY_STACKS) {
+ CvDEPTH(dstr) = CvDEPTH(sstr);
+ } else {
+ CvDEPTH(dstr) = 0;
+ }
if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
/* XXX padlists are real, but pretend to be not */
AvREAL_on(CvPADLIST(sstr));
- CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
+ CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
AvREAL_off(CvPADLIST(sstr));
AvREAL_off(CvPADLIST(dstr));
}
else
- CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
+ CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr), param);
if (!CvANON(sstr) || CvCLONED(sstr))
- CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
+ CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
else
- CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
+ CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
CvFLAGS(dstr) = CvFLAGS(sstr);
+ CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
break;
default:
Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
++PL_sv_objcount;
return dstr;
-}
+ }
/* duplicate a context */
PERL_CONTEXT *
-Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
+Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param)
{
PERL_CONTEXT *ncxs;
switch (CxTYPE(cx)) {
case CXt_SUB:
ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
- ? cv_dup_inc(cx->blk_sub.cv)
- : cv_dup(cx->blk_sub.cv));
+ ? cv_dup_inc(cx->blk_sub.cv, param)
+ : cv_dup(cx->blk_sub.cv,param));
ncx->blk_sub.argarray = (cx->blk_sub.hasargs
- ? av_dup_inc(cx->blk_sub.argarray)
+ ? av_dup_inc(cx->blk_sub.argarray, param)
: Nullav);
- ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
+ ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param);
ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
ncx->blk_sub.lval = cx->blk_sub.lval;
case CXt_EVAL:
ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
- ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
+ ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param);;
ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
- ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
+ ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param);
break;
case CXt_LOOP:
ncx->blk_loop.label = cx->blk_loop.label;
ncx->blk_loop.last_op = cx->blk_loop.last_op;
ncx->blk_loop.iterdata = (CxPADLOOP(cx)
? cx->blk_loop.iterdata
- : gv_dup((GV*)cx->blk_loop.iterdata));
+ : gv_dup((GV*)cx->blk_loop.iterdata, param));
ncx->blk_loop.oldcurpad
= (SV**)ptr_table_fetch(PL_ptr_table,
cx->blk_loop.oldcurpad);
- ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
- ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
- ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
+ ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param);
+ ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param);
+ ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param);
ncx->blk_loop.iterix = cx->blk_loop.iterix;
ncx->blk_loop.itermax = cx->blk_loop.itermax;
break;
case CXt_FORMAT:
- ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
- ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
- ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
+ ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param);
+ ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param);
+ ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param);
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
break;
case CXt_BLOCK:
/* duplicate a stack info structure */
PERL_SI *
-Perl_si_dup(pTHX_ PERL_SI *si)
+Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param)
{
PERL_SI *nsi;
Newz(56, nsi, 1, PERL_SI);
ptr_table_store(PL_ptr_table, si, nsi);
- nsi->si_stack = av_dup_inc(si->si_stack);
+ nsi->si_stack = av_dup_inc(si->si_stack, param);
nsi->si_cxix = si->si_cxix;
nsi->si_cxmax = si->si_cxmax;
- nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
+ nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax, param);
nsi->si_type = si->si_type;
- nsi->si_prev = si_dup(si->si_prev);
- nsi->si_next = si_dup(si->si_next);
+ nsi->si_prev = si_dup(si->si_prev, param);
+ nsi->si_next = si_dup(si->si_next, param);
nsi->si_markoff = si->si_markoff;
return nsi;
/* see if it is part of the interpreter structure */
if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
- ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
+ ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
else
ret = v;
/* duplicate the save stack */
ANY *
-Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
+Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
{
ANY *ss = proto_perl->Tsavestack;
I32 ix = proto_perl->Tsavestack_ix;
GP *gp;
IV iv;
I32 i;
- char *c;
+ char *c = NULL;
void (*dptr) (void*);
- void (*dxptr) (pTHXo_ void*);
+ void (*dxptr) (pTHX_ void*);
OP *o;
Newz(54, nss, max, ANY);
switch (i) {
case SAVEt_ITEM: /* normal string */
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ 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);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup_inc(gv);
+ TOPPTR(nss,ix) = gv_dup_inc(gv, param);
break;
case SAVEt_GENERIC_PVREF: /* generic char* */
c = (char*)POPPTR(ss,ix);
case SAVEt_GENERIC_SVREF: /* generic sv */
case SAVEt_SVREF: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
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);
+ TOPPTR(nss,ix) = av_dup_inc(av, param);
gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup(gv);
+ 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);
+ TOPPTR(nss,ix) = hv_dup_inc(hv, param);
gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup(gv);
+ TOPPTR(nss,ix) = gv_dup(gv, param);
break;
case SAVEt_INT: /* int reference */
ptr = POPPTR(ss,ix);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup(sv);
+ TOPPTR(nss,ix) = sv_dup(sv, param);
break;
case SAVEt_VPTR: /* random* reference */
ptr = POPPTR(ss,ix);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup(hv);
+ 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);
+ TOPPTR(nss,ix) = av_dup(av, param);
break;
case SAVEt_NSTAB:
gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup(gv);
+ TOPPTR(nss,ix) = gv_dup(gv, param);
break;
case SAVEt_GP: /* scalar reference */
gp = (GP*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gp = gp_dup(gp);
+ TOPPTR(nss,ix) = gp = gp_dup(gp, param);
(void)GpREFCNT_inc(gp);
gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup_inc(c);
+ TOPPTR(nss,ix) = gv_dup_inc(gv, param);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup(c);
iv = POPIV(ss,ix);
case SAVEt_FREESV:
case SAVEt_MORTALIZESV:
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
break;
case SAVEt_FREEOP:
ptr = POPPTR(ss,ix);
break;
case SAVEt_DELETE:
hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup_inc(hv);
+ TOPPTR(nss,ix) = hv_dup_inc(hv, param);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup_inc(c);
i = POPINT(ss,ix);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
dxptr = POPDXPTR(ss,ix);
- TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
+ TOPDXPTR(nss,ix) = (void (*)(pTHX_ void*))any_dup((void *)dxptr, proto_perl);
break;
case SAVEt_REGCONTEXT:
case SAVEt_ALLOC:
break;
case SAVEt_AELEM: /* array element */
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup_inc(av);
+ TOPPTR(nss,ix) = av_dup_inc(av, param);
break;
case SAVEt_HELEM: /* hash element */
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup_inc(hv);
+ TOPPTR(nss,ix) = hv_dup_inc(hv, param);
break;
case SAVEt_OP:
ptr = POPPTR(ss,ix);
break;
case SAVEt_COMPPAD:
av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup(av);
+ TOPPTR(nss,ix) = av_dup(av, param);
break;
case SAVEt_PADSV:
longval = (long)POPLONG(ss,ix);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup(sv);
+ TOPPTR(nss,ix) = sv_dup(sv, param);
break;
default:
Perl_croak(aTHX_ "panic: ss_dup inconsistency");
return nss;
}
-#ifdef PERL_OBJECT
-#include "XSUB.h"
-#endif
-
/*
=for apidoc perl_clone
*/
/* XXX the above needs expanding by someone who actually understands it ! */
+EXTERN_C PerlInterpreter *
+perl_clone_host(PerlInterpreter* proto_perl, UV flags);
PerlInterpreter *
perl_clone(PerlInterpreter *proto_perl, UV flags)
{
-#ifdef PERL_OBJECT
- CPerlObj *pPerl = (CPerlObj*)proto_perl;
-#endif
-
#ifdef PERL_IMPLICIT_SYS
- return perl_clone_using(proto_perl, flags,
+
+ /* perlhost.h so we need to call into it
+ to clone the host, CPerlHost should have a c interface, sky */
+
+ if (flags & CLONEf_CLONE_HOST) {
+ return perl_clone_host(proto_perl,flags);
+ }
+ return perl_clone_using(proto_perl, flags,
proto_perl->IMem,
proto_perl->IMemShared,
proto_perl->IMemParse,
* their pointers copied. */
IV i;
-# ifdef PERL_OBJECT
- CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
- ipD, ipS, ipP);
- PERL_SET_THX(pPerl);
-# else /* !PERL_OBJECT */
+ CLONE_PARAMS clone_params;
+ CLONE_PARAMS* param = &clone_params;
+
PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
PERL_SET_THX(my_perl);
-# ifdef DEBUGGING
+# ifdef DEBUGGING
memset(my_perl, 0xab, sizeof(PerlInterpreter));
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
PL_retstack = 0;
PL_sig_pending = 0;
-# else /* !DEBUGGING */
+ Zero(&PL_debug_pad, 1, struct perl_debug_pad);
+# else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
-# endif /* DEBUGGING */
+# endif /* DEBUGGING */
/* host pointers */
PL_Mem = ipM;
PL_Dir = ipD;
PL_Sock = ipS;
PL_Proc = ipP;
-# endif /* PERL_OBJECT */
#else /* !PERL_IMPLICIT_SYS */
IV i;
+ CLONE_PARAMS clone_params;
+ CLONE_PARAMS* param = &clone_params;
PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
PERL_SET_THX(my_perl);
+
+
# ifdef DEBUGGING
memset(my_perl, 0xab, sizeof(PerlInterpreter));
PL_markstack = 0;
PL_savestack = 0;
PL_retstack = 0;
PL_sig_pending = 0;
+ Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
# endif /* DEBUGGING */
#endif /* PERL_IMPLICIT_SYS */
+ param->flags = flags;
/* arena roots */
PL_xiv_arenaroot = NULL;
PL_debug = proto_perl->Idebug;
+#ifdef USE_REENTRANT_API
+ New(31337, PL_reentrant_buffer,1, REBUF);
+ New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
+#endif
+
/* create SV map for pointer relocation */
PL_ptr_table = ptr_table_new();
SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
-#ifdef PERL_OBJECT
- SvUPGRADE(&PL_sv_no, SVt_PVNV);
-#else
SvANY(&PL_sv_no) = new_XPVNV();
-#endif
SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
SvNVX(&PL_sv_no) = 0;
ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
-#ifdef PERL_OBJECT
- SvUPGRADE(&PL_sv_yes, SVt_PVNV);
-#else
SvANY(&PL_sv_yes) = new_XPVNV();
-#endif
SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
PL_compiling.cop_file = SAVEPV(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);
+ 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);
+ PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
/* pseudo environmental stuff */
while (i-- > 0) {
PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
}
- PL_clone_callbacks = newAV(); /* Setup array of objects to callbackon */
- PL_envgv = gv_dup(proto_perl->Ienvgv);
- PL_incgv = gv_dup(proto_perl->Iincgv);
- PL_hintgv = gv_dup(proto_perl->Ihintgv);
+
+ param->stashes = newAV(); /* Setup array of objects to call clone on */
+
+#ifdef PERLIO_LAYERS
+ /* Clone PerlIO tables as soon as we can handle general xx_dup() */
+ 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_origfilename = SAVEPV(proto_perl->Iorigfilename);
- PL_diehook = sv_dup_inc(proto_perl->Idiehook);
- PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
+ PL_diehook = sv_dup_inc(proto_perl->Idiehook, param);
+ PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook, param);
/* switches */
PL_minus_c = proto_perl->Iminus_c;
- PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
+ PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param);
PL_localpatches = proto_perl->Ilocalpatches;
PL_splitstr = proto_perl->Isplitstr;
PL_preprocess = proto_perl->Ipreprocess;
PL_sawampersand = proto_perl->Isawampersand;
PL_unsafe = proto_perl->Iunsafe;
PL_inplace = SAVEPV(proto_perl->Iinplace);
- PL_e_script = sv_dup_inc(proto_perl->Ie_script);
+ PL_e_script = sv_dup_inc(proto_perl->Ie_script, param);
PL_perldb = proto_perl->Iperldb;
PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
+ PL_exit_flags = proto_perl->Iexit_flags;
/* magical thingies */
/* XXX time(&PL_basetime) when asked for? */
PL_basetime = proto_perl->Ibasetime;
- PL_formfeed = sv_dup(proto_perl->Iformfeed);
+ PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
PL_maxsysfd = proto_perl->Imaxsysfd;
PL_multiline = proto_perl->Imultiline;
#ifdef VMS
PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
#endif
+ PL_encoding = sv_dup(proto_perl->Iencoding, param);
+
+ /* Clone the regex array */
+ PL_regex_padav = newAV();
+ {
+ I32 len = av_len((AV*)proto_perl->Iregex_padav);
+ SV** regexen = AvARRAY((AV*)proto_perl->Iregex_padav);
+ av_push(PL_regex_padav,
+ sv_dup_inc(regexen[0],param));
+ for(i = 1; i <= len; i++) {
+ if(SvREPADTMP(regexen[i])) {
+ av_push(PL_regex_padav, sv_dup_inc(regexen[i], param));
+ } else {
+ av_push(PL_regex_padav,
+ SvREFCNT_inc(
+ newSViv(PTR2IV(re_dup(INT2PTR(REGEXP *,
+ SvIVX(regexen[i])), param)))
+ ));
+ }
+ }
+ }
+ PL_regex_pad = AvARRAY(PL_regex_padav);
/* shortcuts to various I/O objects */
- PL_stdingv = gv_dup(proto_perl->Istdingv);
- PL_stderrgv = gv_dup(proto_perl->Istderrgv);
- 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_inc(proto_perl->Iargvout_stack);
+ 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_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);
+ PL_replgv = gv_dup(proto_perl->Ireplgv, param);
/* shortcuts to misc objects */
- PL_errgv = gv_dup(proto_perl->Ierrgv);
+ PL_errgv = gv_dup(proto_perl->Ierrgv, param);
/* shortcuts to debugging objects */
- PL_DBgv = gv_dup(proto_perl->IDBgv);
- PL_DBline = gv_dup(proto_perl->IDBline);
- PL_DBsub = gv_dup(proto_perl->IDBsub);
- PL_DBsingle = sv_dup(proto_perl->IDBsingle);
- PL_DBtrace = sv_dup(proto_perl->IDBtrace);
- PL_DBsignal = sv_dup(proto_perl->IDBsignal);
- PL_lineary = av_dup(proto_perl->Ilineary);
- PL_dbargs = av_dup(proto_perl->Idbargs);
+ 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_DBsingle = sv_dup(proto_perl->IDBsingle, param);
+ PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
+ PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
+ PL_lineary = av_dup(proto_perl->Ilineary, param);
+ PL_dbargs = av_dup(proto_perl->Idbargs, param);
/* symbol tables */
- PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
- PL_curstash = hv_dup(proto_perl->Tcurstash);
- PL_debstash = hv_dup(proto_perl->Idebstash);
- PL_globalstash = hv_dup(proto_perl->Iglobalstash);
- PL_curstname = sv_dup_inc(proto_perl->Icurstname);
-
- PL_beginav = av_dup_inc(proto_perl->Ibeginav);
- PL_endav = av_dup_inc(proto_perl->Iendav);
- PL_checkav = av_dup_inc(proto_perl->Icheckav);
- PL_initav = av_dup_inc(proto_perl->Iinitav);
+ PL_defstash = hv_dup_inc(proto_perl->Tdefstash, param);
+ PL_curstash = hv_dup(proto_perl->Tcurstash, param);
+ PL_nullstash = hv_dup(proto_perl->Inullstash, param);
+ PL_debstash = hv_dup(proto_perl->Idebstash, param);
+ PL_globalstash = hv_dup(proto_perl->Iglobalstash, param);
+ PL_curstname = sv_dup_inc(proto_perl->Icurstname, param);
+
+ PL_beginav = av_dup_inc(proto_perl->Ibeginav, param);
+ PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param);
+ PL_endav = av_dup_inc(proto_perl->Iendav, param);
+ PL_checkav = av_dup_inc(proto_perl->Icheckav, param);
+ PL_initav = av_dup_inc(proto_perl->Iinitav, param);
PL_sub_generation = proto_perl->Isub_generation;
PL_forkprocess = proto_perl->Iforkprocess;
/* subprocess state */
- PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
+ PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param);
/* internal state */
PL_tainting = proto_perl->Itainting;
PL_op_mask = Nullch;
/* current interpreter roots */
- PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
+ PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
PL_main_start = proto_perl->Imain_start;
PL_eval_root = proto_perl->Ieval_root;
PL_Cmd = Nullch;
PL_gensym = proto_perl->Igensym;
PL_preambled = proto_perl->Ipreambled;
- PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
+ PL_preambleav = av_dup_inc(proto_perl->Ipreambleav, param);
PL_laststatval = proto_perl->Ilaststatval;
PL_laststype = proto_perl->Ilaststype;
PL_mess_sv = Nullsv;
- PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
+ PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv, param);
PL_ofmt = SAVEPV(proto_perl->Iofmt);
/* interpreter atexit processing */
}
else
PL_exitlist = (PerlExitListEntry*)NULL;
- PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
+ PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param);
+ PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param);
+ PL_custom_op_descs = hv_dup_inc(proto_perl->Icustom_op_descs,param);
PL_profiledata = NULL;
- PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
+ PL_rsfp = fp_dup(proto_perl->Irsfp, '<', param);
/* PL_rsfp_filters entries have fake IoDIRP() */
- PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
+ PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters, param);
- PL_compcv = cv_dup(proto_perl->Icompcv);
- PL_comppad = av_dup(proto_perl->Icomppad);
- PL_comppad_name = av_dup(proto_perl->Icomppad_name);
+ PL_compcv = cv_dup(proto_perl->Icompcv, param);
+ PL_comppad = av_dup(proto_perl->Icomppad, param);
+ PL_comppad_name = av_dup(proto_perl->Icomppad_name, param);
PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
/* more statics moved here */
PL_generation = proto_perl->Igeneration;
- PL_DBcv = cv_dup(proto_perl->IDBcv);
+ PL_DBcv = cv_dup(proto_perl->IDBcv, param);
PL_in_clean_objs = proto_perl->Iin_clean_objs;
PL_in_clean_all = proto_perl->Iin_clean_all;
PL_origalen = proto_perl->Iorigalen;
PL_pidstatus = newHV(); /* XXX flag for cloning? */
PL_osname = SAVEPV(proto_perl->Iosname);
- PL_sh_path = SAVEPV(proto_perl->Ish_path);
+ PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */
PL_sighandlerp = proto_perl->Isighandlerp;
#ifdef CSH
PL_cshlen = proto_perl->Icshlen;
- PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
+ PL_cshname = proto_perl->Icshname; /* XXX never deallocated */
#endif
PL_lex_state = proto_perl->Ilex_state;
PL_lex_formbrack = proto_perl->Ilex_formbrack;
PL_lex_dojoin = proto_perl->Ilex_dojoin;
PL_lex_starts = proto_perl->Ilex_starts;
- PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
- PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
+ PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff, param);
+ PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl, param);
PL_lex_op = proto_perl->Ilex_op;
PL_lex_inpat = proto_perl->Ilex_inpat;
PL_lex_inwhat = proto_perl->Ilex_inwhat;
Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
PL_nexttoke = proto_perl->Inexttoke;
- PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
+ PL_linestr = sv_dup_inc(proto_perl->Ilinestr, param);
i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
PL_error_count = proto_perl->Ierror_count;
PL_subline = proto_perl->Isubline;
- PL_subname = sv_dup_inc(proto_perl->Isubname);
+ PL_subname = sv_dup_inc(proto_perl->Isubname, param);
PL_min_intro_pending = proto_perl->Imin_intro_pending;
PL_max_intro_pending = proto_perl->Imax_intro_pending;
PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
PL_last_lop_op = proto_perl->Ilast_lop_op;
PL_in_my = proto_perl->Iin_my;
- PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
+ PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash, param);
#ifdef FCRYPT
PL_cryptseen = proto_perl->Icryptseen;
#endif
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_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
+ PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
#endif /* !USE_LOCALE_NUMERIC */
/* utf8 character classes */
- PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
- PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
- PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
- PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
- PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
- PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
- PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
- PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
- PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
- PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
- PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
- PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
- PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
- PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
- PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
- PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
- PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
+ PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum, param);
+ PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc, param);
+ PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii, param);
+ PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha, param);
+ PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space, param);
+ PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl, param);
+ PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph, param);
+ PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit, param);
+ PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper, param);
+ PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower, param);
+ PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print, param);
+ PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct, param);
+ PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit, param);
+ PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param);
+ PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
+ PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
+ PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
+ PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
/* swatch cache */
PL_last_swash_hv = Nullhv; /* reinits on demand */
Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
Newz(0, PL_psig_name, SIG_SIZE, SV*);
for (i = 1; i < SIG_SIZE; i++) {
- PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
- PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
+ PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param);
+ PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param);
}
}
else {
Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
i = 0;
while (i <= PL_tmps_ix) {
- PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
+ PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param);
++i;
}
Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
/* NOTE: si_dup() looks at PL_markstack */
- PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
+ PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);
/* PL_curstack = PL_curstackinfo->si_stack; */
- PL_curstack = av_dup(proto_perl->Tcurstack);
- PL_mainstack = av_dup(proto_perl->Tmainstack);
+ PL_curstack = av_dup(proto_perl->Tcurstack, param);
+ PL_mainstack = av_dup(proto_perl->Tmainstack, param);
/* next PUSHs() etc. set *(PL_stack_sp+1) */
PL_stack_base = AvARRAY(PL_curstack);
PL_savestack_ix = proto_perl->Tsavestack_ix;
PL_savestack_max = proto_perl->Tsavestack_max;
/*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
- PL_savestack = ss_dup(proto_perl);
+ PL_savestack = ss_dup(proto_perl, param);
}
else {
init_stacks();
PL_statbuf = proto_perl->Tstatbuf;
PL_statcache = proto_perl->Tstatcache;
- PL_statgv = gv_dup(proto_perl->Tstatgv);
- PL_statname = sv_dup_inc(proto_perl->Tstatname);
+ PL_statgv = gv_dup(proto_perl->Tstatgv, param);
+ PL_statname = sv_dup_inc(proto_perl->Tstatname, param);
#ifdef HAS_TIMES
PL_timesbuf = proto_perl->Ttimesbuf;
#endif
PL_tainted = proto_perl->Ttainted;
PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
- PL_nrs = sv_dup_inc(proto_perl->Tnrs);
- PL_rs = sv_dup_inc(proto_perl->Trs);
- PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
- PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
- PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
+ PL_rs = sv_dup_inc(proto_perl->Trs, param);
+ PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv, param);
+ PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv, param);
+ PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv, param);
PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
- PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
- PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
- PL_formtarget = sv_dup(proto_perl->Tformtarget);
+ PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget, param);
+ PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget, param);
+ PL_formtarget = sv_dup(proto_perl->Tformtarget, param);
PL_restartop = proto_perl->Trestartop;
PL_in_eval = proto_perl->Tin_eval;
#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = proto_perl->Tprotect;
#endif
- PL_errors = sv_dup_inc(proto_perl->Terrors);
+ PL_errors = sv_dup_inc(proto_perl->Terrors, param);
PL_av_fetch_sv = Nullsv;
PL_hv_fetch_sv = Nullsv;
Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
PL_dumpindent = proto_perl->Tdumpindent;
PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
- PL_sortstash = hv_dup(proto_perl->Tsortstash);
- PL_firstgv = gv_dup(proto_perl->Tfirstgv);
- PL_secondgv = gv_dup(proto_perl->Tsecondgv);
+ PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
+ PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
+ PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
PL_sortcxix = proto_perl->Tsortcxix;
PL_efloatbuf = Nullch; /* reinits on demand */
PL_efloatsize = 0; /* reinits on demand */
PL_reg_re = (regexp*)NULL;
PL_reg_ganch = Nullch;
PL_reg_sv = Nullsv;
+ PL_reg_match_utf8 = FALSE;
PL_reg_magic = (MAGIC*)NULL;
PL_reg_oldpos = 0;
PL_reg_oldcurpm = (PMOP*)NULL;
PL_reginterp_cnt = 0;
PL_reg_starttry = 0;
+ /* Pluggable optimizer */
+ PL_peepp = proto_perl->Tpeepp;
+
if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
}
-
+
/* Call the ->CLONE method, if it exists, for each of the stashes
identified by sv_dup() above.
*/
- while(av_len(PL_clone_callbacks) != -1) {
- HV* stash = (HV*) av_shift(PL_clone_callbacks);
+ while(av_len(param->stashes) != -1) {
+ HV* stash = (HV*) av_shift(param->stashes);
GV* cloner = gv_fetchmethod_autoload(stash, "CLONE", 0);
if (cloner && GvCV(cloner)) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
- XPUSHs(newSVpv(HvNAME(stash), 0));
+ XPUSHs(sv_2mortal(newSVpv(HvNAME(stash), 0)));
PUTBACK;
call_sv((SV*)GvCV(cloner), G_DISCARD);
FREETMPS;
}
}
-#ifdef PERL_OBJECT
- return (PerlInterpreter*)pPerl;
-#else
+ SvREFCNT_dec(param->stashes);
+
return my_perl;
-#endif
}
-#else /* !USE_ITHREADS */
+#endif /* USE_ITHREADS */
-#ifdef PERL_OBJECT
-#include "XSUB.h"
-#endif
+/*
+=head1 Unicode Support
-#endif /* USE_ITHREADS */
+=for apidoc sv_recode_to_utf8
+
+The encoding is assumed to be an Encode object, on entry the PV
+of the sv is assumed to be octets in that encoding, and the sv
+will be converted into Unicode (and UTF-8).
+
+If the sv already is UTF-8 (or if it is not POK), or if the encoding
+is not a reference, nothing is done to the sv. If the encoding is not
+an C<Encode::XS> Encoding object, bad things will happen.
+(See F<lib/encoding.pm> and L<Encode>).
+
+The PV of the sv is returned.
+
+=cut */
+
+char *
+Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
+{
+ if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) {
+ SV *uni;
+ STRLEN len;
+ char *s;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ EXTEND(SP, 3);
+ XPUSHs(encoding);
+ XPUSHs(sv);
+ XPUSHs(&PL_sv_yes);
+ PUTBACK;
+ call_method("decode", G_SCALAR);
+ SPAGAIN;
+ uni = POPs;
+ PUTBACK;
+ s = SvPV(uni, len);
+ if (s != SvPVX(sv)) {
+ SvGROW(sv, len);
+ Move(s, SvPVX(sv), len, char);
+ SvCUR_set(sv, len);
+ }
+ FREETMPS;
+ LEAVE;
+ SvUTF8_on(sv);
+ }
+ return SvPVX(sv);
+}
https://perl5.git.perl.org / perl5.git / blobdiff