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.
+
Note we cannot do this to avoid self-tie loops as intervening RV must
- have its REFCNT incremented to keep it in existence - instead special
- case them in sv_free().
- */
+ have its REFCNT incremented to keep it in existence - instead we could
+ special case them in sv_free() -- NI-S
+
+ */
if (!obj || obj == sv ||
how == PERL_MAGIC_arylen ||
how == PERL_MAGIC_qr ||
return;
}
ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
- if (!refcount_is_zero) {
- if (SvREFCNT(sv) == 1) {
- /* Break self-tie loops */
- MAGIC *mg = 0;
- SV *obj;
- if (SvTYPE(sv) == SVt_PVGV)
- sv = (SV *)GvIO(sv);
- if (!sv || !SvMAGICAL(sv) || SvTYPE(sv) < SVt_PVMG)
- return;
- mg = SvTIED_mg(sv, PERL_MAGIC_tiedscalar);
- if (mg && (obj = mg->mg_obj) && SvROK(obj) &&
- (SvRV(obj) == sv || GvIO(SvRV(obj)) == (IO *) sv)) {
- sv_unmagic(sv, PERL_MAGIC_tiedscalar);
- }
- }
+ if (!refcount_is_zero)
return;
- }
#ifdef DEBUGGING
if (SvTEMP(sv)) {
if (ckWARN_d(WARN_DEBUGGING))
/* Accomodate broken VAXC compiler, which applies U8 cast to
* both args of ?: operator, causing EOF to change into 255
*/
- if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
+ if (cnt > 0) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
}
- if (append)
- sv_catpvn(sv, (char *) buf, cnt);
- else
- sv_setpvn(sv, (char *) buf, cnt);
+ if (cnt > 0) {
+ if (append)
+ sv_catpvn(sv, (char *) buf, cnt);
+ else
+ sv_setpvn(sv, (char *) buf, cnt);
+ }
if (i != EOF && /* joy */
(!rslen ||
Perl_sv_mortalcopy(pTHX_ SV *oldstr)
{
register SV *sv;
+
new_SV(sv);
sv_setsv(sv,oldstr);
EXTEND_MORTAL(1);
unsigned base = 0;
IV iv = 0;
UV uv = 0;
+ /* we need a long double target in case HAS_LONG_DOUBLE but
+ not USE_LONG_DOUBLE
+ */
+#if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE
+ long double nv;
+#else
NV nv;
+#endif
STRLEN have;
STRLEN need;
STRLEN gap;
q++;
break;
#endif
-#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
+#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
case 'L': /* Ld */
/* FALL THROUGH */
-#endif
#ifdef HAS_QUAD
case 'q': /* qd */
+#endif
intsize = 'q';
q++;
break;
#endif
case 'l':
-#if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
+#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
if (*(q + 1) == 'l') { /* lld, llf */
intsize = 'q';
q += 2;
/* This is evil, but floating point is even more evil */
vectorize = FALSE;
- nv = args ? va_arg(*args, NV) : SvNVx(argsv);
+ /* for SV-style calling, we can only get NV
+ for C-style calling, we assume %f is double;
+ for simplicity we allow any of %Lf, %llf, %qf for long double
+ */
+ switch (intsize) {
+ case 'V':
+#if defined(USE_LONG_DOUBLE)
+ intsize = 'q';
+#endif
+ break;
+ default:
+#if defined(USE_LONG_DOUBLE)
+ intsize = args ? 0 : 'q';
+#endif
+ break;
+ case 'q':
+#if defined(HAS_LONG_DOUBLE)
+ break;
+#else
+ /* FALL THROUGH */
+#endif
+ case 'h':
+ /* FALL THROUGH */
+ case 'l':
+ goto unknown;
+ }
+
+ /* now we need (long double) if intsize == 'q', else (double) */
+ nv = args ?
+#if LONG_DOUBLESIZE > DOUBLESIZE
+ intsize == 'q' ?
+ va_arg(*args, long double) :
+ va_arg(*args, double)
+#else
+ va_arg(*args, double)
+#endif
+ : SvNVx(argsv);
need = 0;
if (c != 'e' && c != 'E') {
i = PERL_INT_MIN;
+ /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this
+ will cast our (long double) to (double) */
(void)Perl_frexp(nv, &i);
if (i == PERL_INT_MIN)
Perl_die(aTHX_ "panic: frexp");
eptr = ebuf + sizeof ebuf;
*--eptr = '\0';
*--eptr = c;
-#if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
- {
+ /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */
+#if defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl)
+ if (intsize == 'q') {
/* Copy the one or more characters in a long double
* format before the 'base' ([efgEFG]) character to
* the format string. */
/* No taint. Otherwise we are in the strange situation
* where printf() taints but print($float) doesn't.
* --jhi */
+#if defined(HAS_LONG_DOUBLE)
+ if (intsize == 'q')
+ (void)sprintf(PL_efloatbuf, eptr, nv);
+ else
+ (void)sprintf(PL_efloatbuf, eptr, (double)nv);
+#else
(void)sprintf(PL_efloatbuf, eptr, nv);
-
+#endif
eptr = PL_efloatbuf;
elen = strlen(PL_efloatbuf);
break;
for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
if (tblent->oldval == oldv) {
tblent->newval = newv;
- tbl->tbl_items++;
return;
}
}
/* attempt to make everything in the typeglob readonly */
STATIC SV *
-S_gv_share(pTHX_ SV *sstr)
+S_gv_share(pTHX_ SV *sstr, CLONE_PARAMS *param)
{
GV *gv = (GV*)sstr;
- SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
+ SV *sv = ¶m->proto_perl->Isv_no; /* just need SvREADONLY-ness */
if (GvIO(gv) || GvFORM(gv)) {
GvUNIQUE_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
}
else {
/* CvPADLISTs cannot be shared */
- if (!CvXSUB(GvCV(gv))) {
+ if (!SvREADONLY(GvCV(gv)) && !CvXSUB(GvCV(gv))) {
GvUNIQUE_off(gv);
}
}
case SVt_PVGV:
if (GvUNIQUE((GV*)sstr)) {
SV *share;
- if ((share = gv_share(sstr))) {
+ if ((share = gv_share(sstr, param))) {
del_SV(dstr);
dstr = share;
+ ptr_table_store(PL_ptr_table, sstr, dstr);
#if 0
PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
HvNAME(GvSTASH(share)), GvNAME(share));
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, param);;
+ 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, param);
break;
# endif /* DEBUGGING */
#endif /* PERL_IMPLICIT_SYS */
param->flags = flags;
+ param->proto_perl = proto_perl;
/* arena roots */
PL_xiv_arenaroot = NULL;
projects / p5sagit/p5-mst-13.2.git / blobdiff