case SVt_PVGV:
if (!isGV_with_GP(sv))
break;
+ /* FALLTHROUGH */
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
case SVt_PVGV:
if (!isGV_with_GP(sv))
break;
+ /* FALLTHROUGH */
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
/* The logic to use SVt_PVNV if necessary is in sv_upgrade. */
sv_upgrade(sv, SVt_NV);
DEBUG_c({
- STORE_NUMERIC_LOCAL_SET_STANDARD();
+ STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
PerlIO_printf(Perl_debug_log,
"0x%" UVxf " num(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv));
- RESTORE_NUMERIC_LOCAL();
+ RESTORE_LC_NUMERIC_UNDERLYING();
});
}
else if (SvTYPE(sv) < SVt_PVNV)
return 0.0;
}
DEBUG_c({
- STORE_NUMERIC_LOCAL_SET_STANDARD();
+ STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv));
- RESTORE_NUMERIC_LOCAL();
+ RESTORE_LC_NUMERIC_UNDERLYING();
});
return SvNVX(sv);
}
DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
STORE_LC_NUMERIC_SET_TO_NEEDED();
- local_radix = PL_numeric_local && PL_numeric_radix_sv;
+ local_radix = PL_numeric_underlying && PL_numeric_radix_sv;
if (local_radix && SvCUR(PL_numeric_radix_sv) > 1) {
size += SvCUR(PL_numeric_radix_sv) - 1;
s = SvGROW_mutable(sv, size);
if (isREGEXP(sv))
return
RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0');
+
+ if (SvNOK(sv) && !SvPOK(sv))
+ return SvNVX(sv) != 0.0;
+
return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
}
}
}
- if (SvUTF8(sv)) {
+ /* SVt_REGEXP's shouldn't be upgraded to UTF8 - they're already
+ * compiled and individual nodes will remain non-utf8 even if the
+ * stringified version of the pattern gets upgraded. Whether the
+ * PVX of a REGEXP should be grown or we should just croak, I don't
+ * know - DAPM */
+ if (SvUTF8(sv) || isREGEXP(sv)) {
if (extra) SvGROW(sv, SvCUR(sv) + extra);
return SvCUR(sv);
}
glob to begin with. */
if(dtype == SVt_PVGV) {
const char * const name = GvNAME((const GV *)dstr);
- if(
- strEQ(name,"ISA")
+ const STRLEN len = GvNAMELEN(dstr);
+ if(memEQs(name, len, "ISA")
/* The stash may have been detached from the symbol table, so
check its name. */
&& GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
)
mro_changes = 2;
else {
- const STRLEN len = GvNAMELEN(dstr);
if ((len > 1 && name[len-2] == ':' && name[len-1] == ':')
|| (len == 1 && name[0] == ':')) {
mro_changes = 3;
}
else if (
stype == SVt_PVAV && sref != dref
- && strEQ(GvNAME((GV*)dstr), "ISA")
+ && memEQs(GvNAME((GV*)dstr), GvNAMELEN((GV*)dstr), "ISA")
/* The stash may have been detached from the symbol table, so
check its name before doing anything. */
&& GvSTASH(dstr) && HvENAME(GvSTASH(dstr))
) {
/* Either it's a shared hash key, or it's suitable for
copy-on-write. */
+#ifdef DEBUGGING
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
sv_dump(sstr);
sv_dump(dstr);
}
+#endif
#ifdef PERL_ANY_COW
if (!(sflags & SVf_IsCOW)) {
SvIsCOW_on(sstr);
#endif
PERL_ARGS_ASSERT_SV_SETSV_COW;
-
+#ifdef DEBUGGING
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
(void*)sstr, (void*)dstr);
if (dstr)
sv_dump(dstr);
}
-
+#endif
if (dstr) {
if (SvTHINKFIRST(dstr))
sv_force_normal_flags(dstr, SV_COW_DROP_PV);
SvUTF8_on(dstr);
SvLEN_set(dstr, len);
SvCUR_set(dstr, cur);
- if (DEBUG_C_TEST) {
- sv_dump(dstr);
- }
+#ifdef DEBUGGING
+ if (DEBUG_C_TEST)
+ sv_dump(dstr);
+#endif
return dstr;
}
#endif
const STRLEN len = SvLEN(sv);
const STRLEN cur = SvCUR(sv);
+#ifdef DEBUGGING
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log,
"Copy on write: Force normal %ld\n",
(long) flags);
sv_dump(sv);
}
+#endif
SvIsCOW_off(sv);
# ifdef PERL_COPY_ON_WRITE
if (len) {
} else {
unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
}
- if (DEBUG_C_TEST) {
+#ifdef DEBUGGING
+ if (DEBUG_C_TEST)
sv_dump(sv);
- }
+#endif
}
#else
const char * const pvx = SvPVX_const(sv);
referred-to SV C<PERL_MAGIC_backref> magic if it hasn't already; and
push a back-reference to this RV onto the array of backreferences
associated with that magic. If the RV is magical, set magic will be
-called after the RV is cleared.
+called after the RV is cleared. Silently ignores C<undef> and warns
+on already-weak references.
=cut
*/
}
/*
+=for apidoc sv_rvunweaken
+
+Unweaken a reference: Clear the C<SvWEAKREF> flag on this RV; remove
+the backreference to this RV from the array of backreferences
+associated with the target SV, increment the refcount of the target.
+Silently ignores C<undef> and warns on non-weak references.
+
+=cut
+*/
+
+SV *
+Perl_sv_rvunweaken(pTHX_ SV *const sv)
+{
+ SV *tsv;
+
+ PERL_ARGS_ASSERT_SV_RVUNWEAKEN;
+
+ if (!SvOK(sv)) /* let undefs pass */
+ return sv;
+ if (!SvROK(sv))
+ Perl_croak(aTHX_ "Can't unweaken a nonreference");
+ else if (!SvWEAKREF(sv)) {
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is not weak");
+ return sv;
+ }
+ else if (SvREADONLY(sv)) croak_no_modify();
+
+ tsv = SvRV(sv);
+ SvWEAKREF_off(sv);
+ SvROK_on(sv);
+ SvREFCNT_inc_NN(tsv);
+ Perl_sv_del_backref(aTHX_ tsv, sv);
+ return sv;
+}
+
+/*
=for apidoc sv_get_backrefs
If C<sv> is the target of a weak reference then it returns the back
goto freescalar;
case SVt_REGEXP:
/* FIXME for plugins */
- freeregexp:
pregfree2((REGEXP*) sv);
goto freescalar;
case SVt_PVCV:
}
else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
SvREFCNT_dec(LvTARG(sv));
- if (isREGEXP(sv)) goto freeregexp;
+ if (isREGEXP(sv)) {
+ /* SvLEN points to a regex body. Free the body, then
+ * set SvLEN to whatever value was in the now-freed
+ * regex body. The PVX buffer is shared by multiple re's
+ * and only freed once, by the re whose len in non-null */
+ STRLEN len = ReANY(sv)->xpv_len;
+ pregfree2((REGEXP*) sv);
+ SvLEN_set((sv), len);
+ goto freescalar;
+ }
/* FALLTHROUGH */
case SVt_PVGV:
if (isGV_with_GP(sv)) {
&& !(IoFLAGS(sv) & IOf_FAKE_DIRP)))
{
if (SvIsCOW(sv)) {
+#ifdef DEBUGGING
if (DEBUG_C_TEST) {
PerlIO_printf(Perl_debug_log, "Copy on write: clear\n");
sv_dump(sv);
}
+#endif
if (SvLEN(sv)) {
if (CowREFCNT(sv)) {
sv_buf_to_rw(sv);
if (flags & SVp_NOK) {
const NV was = SvNVX(sv);
if (LIKELY(!Perl_isinfnan(was)) &&
- NV_OVERFLOWS_INTEGERS_AT &&
+ NV_OVERFLOWS_INTEGERS_AT != 0.0 &&
was >= NV_OVERFLOWS_INTEGERS_AT) {
/* diag_listed_as: Lost precision when %s %f by 1 */
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
{
const NV was = SvNVX(sv);
if (LIKELY(!Perl_isinfnan(was)) &&
- NV_OVERFLOWS_INTEGERS_AT &&
+ NV_OVERFLOWS_INTEGERS_AT != 0.0 &&
was <= -NV_OVERFLOWS_INTEGERS_AT) {
/* diag_listed_as: Lost precision when %s %f by 1 */
Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION),
/* In this case there is an implicit bit,
* and therefore the exponent is shifted by one. */
exponent--;
-# else
-# ifdef NV_X86_80_BIT
+# elif defined(NV_X86_80_BIT)
if (subnormal) {
/* The subnormals of the x86-80 have a base exponent of -16382,
* (while the physical exponent bits are zero) but the frexp()
} else {
exponent -= 4;
}
-# endif
/* TBD: other non-implicit-bit platforms than the x86-80. */
# endif
#endif
#ifndef USE_LOCALE_NUMERIC
*p++ = '.';
#else
- if (PL_numeric_radix_sv) {
+ if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) {
STRLEN n;
const char* r = SvPV(PL_numeric_radix_sv, n);
- assert(IN_LC(LC_NUMERIC));
Copy(r, p, n, char);
p += n;
}
bool has_utf8 = DO_UTF8(sv); /* has the result utf8? */
const bool pat_utf8 = has_utf8; /* the pattern is in utf8? */
/* Times 4: a decimal digit takes more than 3 binary digits.
- * NV_DIG: mantissa takes than many decimal digits.
+ * NV_DIG: mantissa takes that many decimal digits.
* Plus 32: Playing safe. */
char ebuf[IV_DIG * 4 + NV_DIG + 32];
bool no_redundant_warning = FALSE; /* did we use any explicit format parameter index? */
if (args) {
eptr = va_arg(*args, char*);
if (eptr)
- elen = strlen(eptr);
+ if (has_precis)
+ elen = my_strnlen(eptr, precis);
+ else
+ elen = strlen(eptr);
else {
eptr = (char *)nullstr;
elen = sizeof nullstr - 1;
lc_numeric_set = TRUE;
}
- if (PL_numeric_radix_sv) {
- assert(IN_LC(LC_NUMERIC));
+ if (PL_numeric_radix_sv && IN_LC(LC_NUMERIC)) {
/* this can't wrap unless PL_numeric_radix_sv is a string
* consuming virtually all the 32-bit or 64-bit address
* space
? my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv)
: my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, (double)fv));
#else
- elen = my_sprintf(PL_efloatbuf, ptr, fv);
+ elen = my_snprintf(PL_efloatbuf, PL_efloatsize, ptr, fv);
#endif
GCC_DIAG_RESTORE;
}
Newxz(parser, 1, yy_parser);
ptr_table_store(PL_ptr_table, proto, parser);
- /* XXX these not yet duped */
- parser->old_parser = NULL;
- parser->stack = NULL;
- parser->ps = NULL;
- parser->stack_max1 = 0;
- /* XXX parser->stack->state = 0; */
-
/* XXX eventually, just Copy() most of the parser struct ? */
parser->lex_brackets = proto->lex_brackets;
parser->sig_optelems= proto->sig_optelems;
parser->sig_slurpy = proto->sig_slurpy;
parser->recheck_utf8_validity = proto->recheck_utf8_validity;
- parser->linestr = sv_dup_inc(proto->linestr, param);
{
char * const ols = SvPVX(proto->linestr);
else
LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param);
if (isREGEXP(sstr)) goto duprex;
+ /* FALLTHROUGH */
case SVt_PVGV:
/* non-GP case already handled above */
if(isGV_with_GP(sstr)) {
SSize_t items = AvFILLp((const AV *)sstr) + 1;
src_ary = AvARRAY((const AV *)sstr);
- Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
+ Newx(dst_ary, AvMAX((const AV *)sstr)+1, SV*);
ptr_table_store(PL_ptr_table, src_ary, dst_ary);
AvARRAY(MUTABLE_AV(dstr)) = dst_ary;
AvALLOC((const AV *)dstr) = dst_ary;
param);
break;
case CXt_GIVEN:
- ncx->blk_givwhen.defsv_save =
- sv_dup_inc(ncx->blk_givwhen.defsv_save, param);
+ ncx->blk_loop.itersave =
+ sv_dup_inc(ncx->blk_loop.itersave, param);
break;
case CXt_BLOCK:
case CXt_NULL:
return nsi;
/* create anew and remember what it is */
- Newxz(nsi, 1, PERL_SI);
+ Newx(nsi, 1, PERL_SI);
ptr_table_store(PL_ptr_table, si, nsi);
nsi->si_stack = av_dup_inc(si->si_stack, param);
nsi->si_prev = si_dup(si->si_prev, param);
nsi->si_next = si_dup(si->si_next, param);
nsi->si_markoff = si->si_markoff;
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+ nsi->si_stack_hwm = 0;
+#endif
return nsi;
}
PERL_ARGS_ASSERT_SS_DUP;
- Newxz(nss, max, ANY);
+ Newx(nss, max, ANY);
while (ix > 0) {
const UV uv = POPUV(ss,ix);
case SAVEt_AELEM: /* array element */
sv = (const SV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param));
- i = POPINT(ss,ix);
- TOPINT(nss,ix) = i;
+ iv = POPIV(ss,ix);
+ TOPIV(nss,ix) = iv;
av = (const AV *)POPPTR(ss,ix);
TOPPTR(nss,ix) = av_dup_inc(av, param);
break;
#ifdef USE_LOCALE_NUMERIC
PL_numeric_standard = proto_perl->Inumeric_standard;
- PL_numeric_local = proto_perl->Inumeric_local;
+ PL_numeric_underlying = proto_perl->Inumeric_underlying;
#endif /* !USE_LOCALE_NUMERIC */
/* Did the locale setup indicate UTF-8? */
PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv, param);
#endif /* !USE_LOCALE_NUMERIC */
+ PL_langinfo_buf = NULL;
+ PL_langinfo_bufsize = 0;
+
/* Unicode inversion lists */
PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param);
PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param);
/* next PUSHMARK() sets *(PL_markstack_ptr+1) */
i = proto_perl->Imarkstack_max - proto_perl->Imarkstack;
- Newxz(PL_markstack, i, I32);
+ Newx(PL_markstack, i, I32);
PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max
- proto_perl->Imarkstack);
PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr
/* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
* NOTE: unlike the others! */
- Newxz(PL_scopestack, PL_scopestack_max, I32);
+ Newx(PL_scopestack, PL_scopestack_max, I32);
Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32);
#ifdef DEBUGGING
- Newxz(PL_scopestack_name, PL_scopestack_max, const char *);
+ Newx(PL_scopestack_name, PL_scopestack_max, const char *);
Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *);
#endif
/* reset stack AV to correct length before its duped via
SvREFCNT(&PL_sv_zero) = SvREFCNT_IMMORTAL;
SvFLAGS(&PL_sv_zero) = SVt_PVNV|SVf_READONLY|SVf_PROTECT
|SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK
- |SVp_POK|SVf_POK;
+ |SVp_POK|SVf_POK
+ |SVs_PADTMP;
SvPV_set(&PL_sv_no, (char*)PL_No);
SvCUR_set(&PL_sv_no, 0);
SvNV_set(&PL_sv_zero, 0);
PadnamePV(&PL_padname_const) = (char *)PL_No;
+
+ assert(SvIMMORTAL_INTERP(&PL_sv_yes));
+ assert(SvIMMORTAL_INTERP(&PL_sv_undef));
+ assert(SvIMMORTAL_INTERP(&PL_sv_no));
+ assert(SvIMMORTAL_INTERP(&PL_sv_zero));
+
+ assert(SvIMMORTAL(&PL_sv_yes));
+ assert(SvIMMORTAL(&PL_sv_undef));
+ assert(SvIMMORTAL(&PL_sv_no));
+ assert(SvIMMORTAL(&PL_sv_zero));
+
+ assert( SvIMMORTAL_TRUE(&PL_sv_yes));
+ assert(!SvIMMORTAL_TRUE(&PL_sv_undef));
+ assert(!SvIMMORTAL_TRUE(&PL_sv_no));
+ assert(!SvIMMORTAL_TRUE(&PL_sv_zero));
+
+ assert( SvTRUE_nomg_NN(&PL_sv_yes));
+ assert(!SvTRUE_nomg_NN(&PL_sv_undef));
+ assert(!SvTRUE_nomg_NN(&PL_sv_no));
+ assert(!SvTRUE_nomg_NN(&PL_sv_zero));
}
/*
/* def-ness of rval pos() is independent of the def-ness of its arg */
if ( !(obase->op_flags & OPf_MOD))
break;
+ /* FALLTHROUGH */
case OP_SCHOMP:
case OP_CHOMP:
if (PL_op) {
desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded
? "join or string"
+ : PL_op->op_type == OP_MULTICONCAT
+ && (PL_op->op_private & OPpMULTICONCAT_FAKE)
+ ? "sprintf"
: OP_DESC(PL_op);
if (uninit_sv && PL_curpad) {
varname = find_uninit_var(PL_op, uninit_sv, 0, &desc);
https://perl5.git.perl.org / perl5.git / blobdiff