* "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.
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;
}
}
/* 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");
/* 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
*/
#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 */
if (PL_op)
Perl_warner(aTHX_ WARN_NUMERIC,
"Argument \"%s\" isn't numeric in %s", tmpbuf,
- PL_op_desc[PL_op->op_type]);
+ OP_DESC(PL_op));
else
Perl_warner(aTHX_ WARN_NUMERIC,
"Argument \"%s\" isn't numeric", tmpbuf);
) {
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);
) {
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);
}
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));
/*
=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>
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);
mg->mg_moremagic = SvMAGIC(sv);
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
+ /* Some magic contains a reference loop, where the sv and object refer to
+ each other. To 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 == PERL_MAGIC_arylen ||
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;
}
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);
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);
=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
*/
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);
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);
#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
#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 file handle */
return dp;
}
-/* duplictate a typeglob */
+/* duplicate a typeglob */
GP *
Perl_gp_dup(pTHX_ GP *gp, clone_params* param)
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 *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));
break;
case SVt_RV:
SvANY(dstr) = new_XRV();
- SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
+ SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
: sv_dup_inc(SvRV(sstr), param);
break;
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ SvRV(dstr) = SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
: sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ SvRV(dstr) = SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
: sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ SvRV(dstr) = SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
: sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ SvRV(dstr) = SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
: sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ SvRV(dstr) = SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
: sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ SvRV(dstr) = SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
: sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
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);
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ SvRV(dstr) = SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
: sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(SvRV(sstr))
+ SvRV(dstr) = SvWEAKREF(sstr)
? sv_dup(SvRV(sstr), param)
: sv_dup_inc(SvRV(sstr), param);
else if (SvPVX(sstr) && SvLEN(sstr))
}
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(param->stashes, dstr);
break;
CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
CvXSUB(dstr) = CvXSUB(sstr);
CvXSUBANY(dstr) = CvXSUBANY(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
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));
/* 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;
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);
TOPPTR(nss,ix) = gp = gp_dup(gp, param);
(void)GpREFCNT_inc(gp);
gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup_inc(c, param);
+ TOPPTR(nss,ix) = gv_dup_inc(gv, param);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup(c);
iv = POPIV(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:
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,
IV i;
clone_params* param = (clone_params*) malloc(sizeof(clone_params));
-
-
-# ifdef PERL_OBJECT
- CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
- ipD, ipS, ipP);
- PERL_SET_THX(pPerl);
-# else /* !PERL_OBJECT */
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 */
+# 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* param = (clone_params*) malloc(sizeof(clone_params));
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_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_statusvalue_vms = proto_perl->Istatusvalue_vms;
#endif
+ /* 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);
+ for(i = 0; i <= len; i++) {
+ av_push(PL_regex_padav,
+ SvREFCNT_inc(
+ newSViv((IV)re_dup((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, param);
PL_stderrgv = gv_dup(proto_perl->Istderrgv, param);
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_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;
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);
+ Safefree(param);
+
return my_perl;
-#endif
}
-#else /* !USE_ITHREADS */
-
-#ifdef PERL_OBJECT
-#include "XSUB.h"
-#endif
-
#endif /* USE_ITHREADS */
-
-
-
-
-
projects / p5sagit/p5-mst-13.2.git / blobdiff