# define ASSERT_UTF8_CACHE(cache) NOOP
#endif
+static const char S_destroy[] = "DESTROY";
+#define S_destroy_len (sizeof(S_destroy)-1)
+
/* ============================================================================
=head1 Allocation and deallocation of SVs.
if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \
} STMT_END
# define DEBUG_SV_SERIAL(sv) \
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) del_SV\n", \
PTR2UV(sv), (long)(sv)->sv_debug_serial))
#else
# define FREE_SV_DEBUG_FILE(sv)
sv->sv_debug_serial = PL_sv_serial++;
MEM_LOG_NEW_SV(sv, file, line, func);
- DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n",
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) new_SV (from %s:%d [%s])\n",
PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func));
return sv;
}
if (!ok) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free non-arena SV: 0x%"UVxf
+ "Attempt to free non-arena SV: 0x%" UVxf
pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
return;
}
#endif /* DEBUGGING */
-/*
- * Bodyless IVs and NVs!
- *
- * Since 5.9.2, we can avoid allocating a body for SVt_IV-type SVs.
- * Since the larger IV-holding variants of SVs store their integer
- * values in their respective bodies, the family of SvIV() accessor
- * macros would naively have to branch on the SV type to find the
- * integer value either in the HEAD or BODY. In order to avoid this
- * expensive branch, a clever soul has deployed a great hack:
- * We set up the SvANY pointer such that instead of pointing to a
- * real body, it points into the memory before the location of the
- * head. We compute this pointer such that the location of
- * the integer member of the hypothetical body struct happens to
- * be the same as the location of the integer member of the bodyless
- * SV head. This now means that the SvIV() family of accessors can
- * always read from the (hypothetical or real) body via SvANY.
- *
- * Since the 5.21 dev series, we employ the same trick for NVs
- * if the architecture can support it (NVSIZE <= IVSIZE).
- */
-
-/* The following two macros compute the necessary offsets for the above
- * trick and store them in SvANY for SvIV() (and friends) to use. */
-#define SET_SVANY_FOR_BODYLESS_IV(sv) \
- SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv))
-
-#define SET_SVANY_FOR_BODYLESS_NV(sv) \
- SvANY(sv) = (XPVNV*)((char*)&(sv->sv_u.svu_nv) - STRUCT_OFFSET(XPVNV, xnv_u.xnv_nv))
/*
=head1 SV Manipulation Functions
/* don't clean pid table and strtab */
return;
}
- DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%" UVxf "\n", PTR2UV(sv)) ));
SvFLAGS(sv) |= SVf_BREAK;
SvREFCNT_dec_NN(sv);
}
Newx(adesc->arena, good_arena_size, char);
adesc->size = good_arena_size;
adesc->utype = sv_type;
- DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %"UVuf"\n",
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %" UVuf "\n",
curr, (void*)adesc->arena, (UV)good_arena_size));
start = (char *) adesc->arena;
const struct body_details *new_type_details;
const struct body_details *old_type_details
= bodies_by_type + old_type;
- SV *referant = NULL;
+ SV *referent = NULL;
PERL_ARGS_ASSERT_SV_UPGRADE;
break;
case SVt_IV:
if (SvROK(sv)) {
- referant = SvRV(sv);
+ referent = SvRV(sv);
old_type_details = &fake_rv;
if (new_type == SVt_NV)
new_type = SVt_PVNV;
if (UNLIKELY(new_type == SVt_REGEXP))
sv->sv_u.svu_rx = (regexp *)new_body;
else if (old_type < SVt_PV) {
- /* referant will be NULL unless the old type was SVt_IV emulating
+ /* referent will be NULL unless the old type was SVt_IV emulating
SVt_RV */
- sv->sv_u.svu_rv = referant;
+ sv->sv_u.svu_rv = referent;
}
break;
default:
* to store the COW count. So in general, allocate one more byte than
* asked for, to make it likely this byte is always spare: and thus
* make more strings COW-able.
- * If the new size is a big power of two, don't bother: we assume the
- * caller wanted a nice 2^N sized block and will be annoyed at getting
- * 2^N+1.
+ *
* Only increment if the allocation isn't MEM_SIZE_MAX,
* otherwise it will wrap to 0.
*/
- if (newlen & 0xff && newlen != MEM_SIZE_MAX)
+ if ( newlen != MEM_SIZE_MAX )
newlen++;
#endif
else {
s = (char*)safemalloc(newlen);
if (SvPVX_const(sv) && SvCUR(sv)) {
- Move(SvPVX_const(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
+ Move(SvPVX_const(sv), s, SvCUR(sv), char);
}
}
SvPV_set(sv, s);
PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE;
PERL_UNUSED_CONTEXT;
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(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_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
{
bool pok = cBOOL(SvPOK(sv));
bool nok = FALSE;
+#ifdef NV_INF
if ((numtype & IS_NUMBER_INFINITY)) {
SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
nok = TRUE;
- }
- else if ((numtype & IS_NUMBER_NAN)) {
+ } else
+#endif
+#ifdef NV_NAN
+ if ((numtype & IS_NUMBER_NAN)) {
SvNV_set(sv, NV_NAN);
nok = TRUE;
- }
- else if (pok) {
+ } else
+#endif
+ if (pok) {
SvNV_set(sv, Atof(SvPVX_const(sv)));
/* Purposefully no true nok here, since we don't want to blow
* away the possible IOK/UV of an existing sv. */
/* scalar has trailing garbage, eg "42a" */
}
DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" iv(%"NVgf" => %"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(%"NVgf" => %"IVdf") (imprecise)\n",
+ "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (imprecise)\n",
PTR2UV(sv),
SvNVX(sv),
SvIVX(sv)));
SvIOK_on(sv);
SvIsUV_on(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
+ "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n",
PTR2UV(sv),
SvUVX(sv),
SvUVX(sv)));
}
else if (SvPOKp(sv)) {
UV value;
- const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value);
+ int numtype;
+ const char *s = SvPVX_const(sv);
+ const STRLEN cur = SvCUR(sv);
+
+ /* short-cut for a single digit string like "1" */
+
+ if (cur == 1) {
+ char c = *s;
+ if (isDIGIT(c)) {
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+ SvIV_set(sv, (IV)(c - '0'));
+ return FALSE;
+ }
+ }
+
+ numtype = grok_number(s, cur, &value);
/* We want to avoid a possible problem when we cache an IV/ a UV which
may be later translated to an NV, and the resulting NV is not
the same as the direct translation of the initial string
if (! numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" NVgf ")\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv)));
#ifdef NV_PRESERVES_UV
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((double)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);
+ Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)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
}
if (SvVALID(sv) || isREGEXP(sv)) {
- /* FBMs use the space for SvIVX and SvNVX for other purposes, and use
- the same flag bit as SVf_IVisUV, so must not let them cache IVs.
+ /* FBMs use the space for SvIVX and SvNVX for other purposes, so
+ must not let them cache IVs.
In practice they are extremely unlikely to actually get anywhere
accessible by user Perl code - the only way that I'm aware of is when
a constant subroutine which is used as the second argument to index.
return 0;
}
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" IVdf ")\n",
PTR2UV(sv),SvIVX(sv)));
return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
}
return 0;
}
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2uv(%" UVuf ")\n",
PTR2UV(sv),SvUVX(sv)));
return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
}
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
PerlIO_printf(Perl_debug_log,
- "0x%"UVxf" num(%" NVgf ")\n",
+ "0x%" UVxf " num(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
}
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" NVgf ")\n",
+ PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
STORE_LC_NUMERIC_SET_TO_NEEDED();
- local_radix =
- PL_numeric_local &&
- PL_numeric_radix_sv &&
- SvUTF8(PL_numeric_radix_sv);
+ local_radix = PL_numeric_local && PL_numeric_radix_sv;
if (local_radix && SvLEN(PL_numeric_radix_sv) > 1) {
size += SvLEN(PL_numeric_radix_sv) - 1;
s = SvGROW_mutable(sv, size);
/* If the radix character is UTF-8, and actually is in the
* output, turn on the UTF-8 flag for the scalar */
- if (local_radix &&
- instr(s, SvPVX_const(PL_numeric_radix_sv))) {
+ if ( local_radix
+ && SvUTF8(PL_numeric_radix_sv)
+ && instr(s, SvPVX_const(PL_numeric_radix_sv)))
+ {
SvUTF8_on(sv);
}
*lp = len;
SvCUR_set(sv, len);
}
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n",
PTR2UV(sv),SvPVX_const(sv)));
if (flags & SV_CONST_RETURN)
return (char *)SvPVX_const(sv);
S_sv_uncow(aTHX_ sv, 0);
}
- if (IN_ENCODING && !(flags & SV_UTF8_NO_ENCODING)) {
- sv_recode_to_utf8(sv, _get_encoding());
- if (extra) SvGROW(sv, SvCUR(sv) + extra);
- return SvCUR(sv);
- }
-
if (SvCUR(sv) == 0) {
if (extra) SvGROW(sv, extra);
} else { /* Assume Latin-1/EBCDIC */
/*
=for apidoc sv_utf8_decode
-If the PV of the SV is an octet sequence in UTF-8
+If the PV of the SV is an octet sequence in Perl's extended UTF-8
and contains a multiple-byte character, the C<SvUTF8> flag is turned on
so that it looks like a character. If the PV contains only single-byte
characters, the C<SvUTF8> flag stays off.
-Scans PV for validity and returns false if the PV is invalid UTF-8.
+Scans PV for validity and returns FALSE if the PV is invalid UTF-8.
=cut
*/
if (SvPOKp(sv)) {
const U8 *start, *c;
- const U8 *e;
/* The octets may have got themselves encoded - get them back as
* bytes
c = start = (const U8 *) SvPVX_const(sv);
if (!is_utf8_string(c, SvCUR(sv)))
return FALSE;
- e = (const U8 *) SvEND(sv);
- while (c < e) {
- const U8 ch = *c++;
- if (!UTF8_IS_INVARIANT(ch)) {
- SvUTF8_on(sv);
- break;
- }
+ if (! is_utf8_invariant_string(c, SvCUR(sv))) {
+ SvUTF8_on(sv);
}
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
/* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC
CvCONST((const CV *)sref)
? cv_const_sv((const CV *)sref)
: NULL;
+ HV * const stash = GvSTASH((const GV *)dstr);
report_redefined_cv(
- sv_2mortal(Perl_newSVpvf(aTHX_
- "%"HEKf"::%"HEKf,
- HEKfARG(
- HvNAME_HEK(GvSTASH((const GV *)dstr))
- ),
- HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr)))
- )),
+ sv_2mortal(
+ stash
+ ? Perl_newSVpvf(aTHX_
+ "%" HEKf "::%" HEKf,
+ HEKfARG(HvNAME_HEK(stash)),
+ HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))))
+ : Perl_newSVpvf(aTHX_
+ "%" HEKf,
+ HEKfARG(GvENAME_HEK(MUTABLE_GV(dstr))))
+ ),
cv,
CvCONST((const CV *)sref) ? &new_const_sv : NULL
);
}
else
{
+ SSize_t i;
sv_magic(
sref, omg ? omg->mg_obj : dstr, PERL_MAGIC_isa, NULL, 0
);
+ for (i = 0; i <= AvFILL(sref); ++i) {
+ SV **elem = av_fetch ((AV*)sref, i, 0);
+ if (elem) {
+ sv_magic(
+ *elem, sref, PERL_MAGIC_isaelem, NULL, i
+ );
+ }
+ }
mg = mg_find(sref, PERL_MAGIC_isa);
}
/* Since the *ISA assignment could have affected more than
U32 sflags;
int dtype;
svtype stype;
+ unsigned int both_type;
PERL_ARGS_ASSERT_SV_SETSV_FLAGS;
if (UNLIKELY( sstr == dstr ))
return;
- if (SvIS_FREED(dstr)) {
- Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
- " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
- }
- SV_CHECK_THINKFIRST_COW_DROP(dstr);
if (UNLIKELY( !sstr ))
sstr = &PL_sv_undef;
- if (SvIS_FREED(sstr)) {
- Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
- (void*)sstr, (void*)dstr);
- }
+
stype = SvTYPE(sstr);
dtype = SvTYPE(dstr);
+ both_type = (stype | dtype);
+
+ /* with these values, we can check that both SVs are NULL/IV (and not
+ * freed) just by testing the or'ed types */
+ STATIC_ASSERT_STMT(SVt_NULL == 0);
+ STATIC_ASSERT_STMT(SVt_IV == 1);
+ if (both_type <= 1) {
+ /* both src and dst are UNDEF/IV/RV, so we can do a lot of
+ * special-casing */
+ U32 sflags;
+ U32 new_dflags;
+ SV *old_rv = NULL;
+
+ /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dstr) */
+ if (SvREADONLY(dstr))
+ Perl_croak_no_modify();
+ if (SvROK(dstr)) {
+ if (SvWEAKREF(dstr))
+ sv_unref_flags(dstr, 0);
+ else
+ old_rv = SvRV(dstr);
+ }
+
+ assert(!SvGMAGICAL(sstr));
+ assert(!SvGMAGICAL(dstr));
+
+ sflags = SvFLAGS(sstr);
+ if (sflags & (SVf_IOK|SVf_ROK)) {
+ SET_SVANY_FOR_BODYLESS_IV(dstr);
+ new_dflags = SVt_IV;
+
+ if (sflags & SVf_ROK) {
+ dstr->sv_u.svu_rv = SvREFCNT_inc(SvRV(sstr));
+ new_dflags |= SVf_ROK;
+ }
+ else {
+ /* both src and dst are <= SVt_IV, so sv_any points to the
+ * head; so access the head directly
+ */
+ assert( &(sstr->sv_u.svu_iv)
+ == &(((XPVIV*) SvANY(sstr))->xiv_iv));
+ assert( &(dstr->sv_u.svu_iv)
+ == &(((XPVIV*) SvANY(dstr))->xiv_iv));
+ dstr->sv_u.svu_iv = sstr->sv_u.svu_iv;
+ new_dflags |= (SVf_IOK|SVp_IOK|(sflags & SVf_IVisUV));
+ }
+ }
+ else {
+ new_dflags = dtype; /* turn off everything except the type */
+ }
+ SvFLAGS(dstr) = new_dflags;
+ SvREFCNT_dec(old_rv);
+
+ return;
+ }
+
+ if (UNLIKELY(both_type == SVTYPEMASK)) {
+ if (SvIS_FREED(dstr)) {
+ Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
+ " to a freed scalar %p", SVfARG(sstr), (void *)dstr);
+ }
+ if (SvIS_FREED(sstr)) {
+ Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
+ (void*)sstr, (void*)dstr);
+ }
+ }
+
+
+
+ SV_CHECK_THINKFIRST_COW_DROP(dstr);
+ dtype = SvTYPE(dstr); /* THINKFIRST may have changed type */
/* There's a lot of redundancy below but we're going for speed here */
}
if (sflags & SVp_IOK) {
SvIV_set(dstr, SvIVX(sstr));
- /* Must do this otherwise some other overloaded use of 0x80000000
- gets confused. I guess SVpbm_VALID */
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
}
SvTAINT(dstr);
}
+
+/*
+=for apidoc sv_set_undef
+
+Equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but more efficient.
+Doesn't handle set magic.
+
+The perl equivalent is C<$sv = undef;>. Note that it doesn't free any string
+buffer, unlike C<undef $sv>.
+
+Introduced in perl 5.26.0.
+
+=cut
+*/
+
+void
+Perl_sv_set_undef(pTHX_ SV *sv)
+{
+ U32 type = SvTYPE(sv);
+
+ PERL_ARGS_ASSERT_SV_SET_UNDEF;
+
+ /* shortcut, NULL, IV, RV */
+
+ if (type <= SVt_IV) {
+ assert(!SvGMAGICAL(sv));
+ if (SvREADONLY(sv)) {
+ /* does undeffing PL_sv_undef count as modifying a read-only
+ * variable? Some XS code does this */
+ if (sv == &PL_sv_undef)
+ return;
+ Perl_croak_no_modify();
+ }
+
+ if (SvROK(sv)) {
+ if (SvWEAKREF(sv))
+ sv_unref_flags(sv, 0);
+ else {
+ SV *rv = SvRV(sv);
+ SvFLAGS(sv) = type; /* quickly turn off all flags */
+ SvREFCNT_dec_NN(rv);
+ return;
+ }
+ }
+ SvFLAGS(sv) = type; /* quickly turn off all flags */
+ return;
+ }
+
+ if (SvIS_FREED(sv))
+ Perl_croak(aTHX_ "panic: attempt to undefine a freed scalar %p",
+ (void *)sv);
+
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
+
+ if (isGV_with_GP(sv))
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Undefined value assigned to typeglob");
+ else
+ SvOK_off(sv);
+}
+
+
+
/*
=for apidoc sv_setsv_mg
#endif
/*
+=for apidoc sv_setpv_bufsize
+
+Sets the SV to be a string of cur bytes length, with at least
+len bytes available. Ensures that there is a null byte at SvEND.
+Returns a char * pointer to the SvPV buffer.
+
+=cut
+*/
+
+char *
+Perl_sv_setpv_bufsize(pTHX_ SV *const sv, const STRLEN cur, const STRLEN len)
+{
+ char *pv;
+
+ PERL_ARGS_ASSERT_SV_SETPV_BUFSIZE;
+
+ SV_CHECK_THINKFIRST_COW_DROP(sv);
+ SvUPGRADE(sv, SVt_PV);
+ pv = SvGROW(sv, len + 1);
+ SvCUR_set(sv, cur);
+ *(SvEND(sv))= '\0';
+ (void)SvPOK_only_UTF8(sv); /* validate pointer */
+
+ SvTAINT(sv);
+ if (SvTYPE(sv) == SVt_PVCV) CvAUTOLOAD_off(sv);
+ return pv;
+}
+
+/*
=for apidoc sv_setpvn
Copies a string (possibly containing embedded C<NUL> characters) into an SV.
=for apidoc sv_setpv
Copies a string into an SV. The string must be terminated with a C<NUL>
-character.
+character, and not contain embeded C<NUL>'s.
Does not handle 'set' magic. See C<L</sv_setpv_mg>>.
=cut
sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1);
dlen = SvCUR(dsv);
}
- else SvGROW(dsv, dlen + slen + 1);
+ else SvGROW(dsv, dlen + slen + 3);
if (sstr == dstr)
sstr = SvPVX_const(dsv);
Move(sstr, SvPVX(dsv) + dlen, slen, char);
bytes *and* utf8, which would indicate a bug elsewhere. */
assert(sstr != dstr);
- SvGROW(dsv, dlen + slen * 2 + 1);
+ SvGROW(dsv, dlen + slen * 2 + 3);
d = (U8 *)SvPVX(dsv) + dlen;
while (sstr < send) {
*/
if (!obj || obj == sv ||
how == PERL_MAGIC_arylen ||
- how == PERL_MAGIC_symtab ||
+ how == PERL_MAGIC_regdata ||
+ how == PERL_MAGIC_regdatum ||
+ how == PERL_MAGIC_symtab ||
(SvTYPE(obj) == SVt_PVGV &&
(GvSV(obj) == sv || GvHV(obj) == (const HV *)sv
|| GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv
if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */
mg_magical(sv); /* else fix the flags now */
}
- else {
+ else
SvMAGICAL_off(sv);
- SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
- }
+
return 0;
}
} else {
Perl_croak(aTHX_
- "panic: magic_killbackrefs (flags=%"UVxf")",
+ "panic: magic_killbackrefs (flags=%" UVxf ")",
(UV)SvFLAGS(referrer));
}
{
if (PL_stashcache) {
DEBUG_o(Perl_deb(aTHX_
- "sv_clear clearing PL_stashcache for '%"HEKf
+ "sv_clear clearing PL_stashcache for '%" HEKf
"'\n",
HEKfARG(hek)));
(void)hv_deletehek(PL_stashcache,
/* If we're in a stash, we don't own a reference to it.
* However it does have a back reference to us, which
* needs to be cleared. */
- if (!SvVALID(sv) && (stash = GvSTASH(sv)))
+ if ((stash = GvSTASH(sv)))
sv_del_backref(MUTABLE_SV(stash), sv);
}
/* FIXME. There are probably more unreferenced pointers to SVs
#ifdef DEBUGGING
if (SvTEMP(sv)) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
- "Attempt to free temp prematurely: SV 0x%"UVxf
+ "Attempt to free temp prematurely: SV 0x%" UVxf
pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
continue;
}
assert(SvTYPE(stash) == SVt_PVHV);
if (HvNAME(stash)) {
CV* destructor = NULL;
+ struct mro_meta *meta;
+
assert (SvOOK(stash));
- if (!SvOBJECT(stash)) destructor = (CV *)SvSTASH(stash);
- if (!destructor || HvMROMETA(stash)->destroy_gen
- != PL_sub_generation)
- {
- GV * const gv =
- gv_fetchmeth_autoload(stash, "DESTROY", 7, 0);
- if (gv) destructor = GvCV(gv);
- if (!SvOBJECT(stash))
- {
- SvSTASH(stash) =
- destructor ? (HV *)destructor : ((HV *)0)+1;
- HvAUX(stash)->xhv_mro_meta->destroy_gen =
- PL_sub_generation;
- }
+
+ DEBUG_o( Perl_deb(aTHX_ "Looking for DESTROY method for %s\n",
+ HvNAME(stash)) );
+
+ /* don't make this an initialization above the assert, since it needs
+ an AUX structure */
+ meta = HvMROMETA(stash);
+ if (meta->destroy_gen && meta->destroy_gen == PL_sub_generation) {
+ destructor = meta->destroy;
+ DEBUG_o( Perl_deb(aTHX_ "Using cached DESTROY method %p for %s\n",
+ (void *)destructor, HvNAME(stash)) );
+ }
+ else {
+ bool autoload = FALSE;
+ GV *gv =
+ gv_fetchmeth_pvn(stash, S_destroy, S_destroy_len, -1, 0);
+ if (gv)
+ destructor = GvCV(gv);
+ if (!destructor) {
+ gv = gv_autoload_pvn(stash, S_destroy, S_destroy_len,
+ GV_AUTOLOAD_ISMETHOD);
+ if (gv)
+ destructor = GvCV(gv);
+ if (destructor)
+ autoload = TRUE;
+ }
+ /* we don't cache AUTOLOAD for DESTROY, since this code
+ would then need to set $__PACKAGE__::AUTOLOAD, or the
+ equivalent for XS AUTOLOADs */
+ if (!autoload) {
+ meta->destroy_gen = PL_sub_generation;
+ meta->destroy = destructor;
+
+ DEBUG_o( Perl_deb(aTHX_ "Set cached DESTROY method %p for %s\n",
+ (void *)destructor, HvNAME(stash)) );
+ }
+ else {
+ DEBUG_o( Perl_deb(aTHX_ "Not caching AUTOLOAD for DESTROY method for %s\n",
+ HvNAME(stash)) );
+ }
}
- assert(!destructor || destructor == ((CV *)0)+1
- || SvTYPE(destructor) == SVt_PVCV);
- if (destructor && destructor != ((CV *)0)+1
+ assert(!destructor || SvTYPE(destructor) == SVt_PVCV);
+ if (destructor
/* A constant subroutine can have no side effects, so
don't bother calling it. */
&& !CvCONST(destructor)
if (check_refcnt && SvREFCNT(sv)) {
if (PL_in_clean_objs)
Perl_croak(aTHX_
- "DESTROY created new reference to dead object '%"HEKf"'",
+ "DESTROY created new reference to dead object '%" HEKf "'",
HEKfARG(HvNAME_HEK(stash)));
/* DESTROY gave object new lease on life */
return FALSE;
#ifdef DEBUGGING
if (SvTEMP(sv)) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
- "Attempt to free temp prematurely: SV 0x%"UVxf
+ "Attempt to free temp prematurely: SV 0x%" UVxf
pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
return;
}
#endif
/* This may not return: */
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Attempt to free unreferenced scalar: SV 0x%"UVxf
+ "Attempt to free unreferenced scalar: SV 0x%" UVxf
pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
#endif
}
s = (const U8*)SvPV_flags(sv, blen, flags);
if (blen < offset)
- Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%"UVuf
- ", byte=%"UVuf, (UV)blen, (UV)offset);
+ Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%" UVuf
+ ", byte=%" UVuf, (UV)blen, (UV)offset);
send = s + offset;
while printing error messages. */
SAVEI8(PL_utf8cache);
PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: %s cache %"UVuf" real %"UVuf" for %"SVf,
+ Perl_croak(aTHX_ "panic: %s cache %" UVuf " real %" UVuf " for %" SVf,
func, (UV) from_cache, (UV) real, SVfARG(sv));
}
pv2 = SvPV_flags_const(sv2, cur2, flags);
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
- /* Differing utf8ness.
- * Do not UTF8size the comparands as a side-effect. */
- if (IN_ENCODING) {
- if (SvUTF8(sv1)) {
- svrecode = newSVpvn(pv2, cur2);
- sv_recode_to_utf8(svrecode, _get_encoding());
- pv2 = SvPV_const(svrecode, cur2);
- }
- else {
- svrecode = newSVpvn(pv1, cur1);
- sv_recode_to_utf8(svrecode, _get_encoding());
- pv1 = SvPV_const(svrecode, cur1);
- }
- /* Now both are in UTF-8. */
- if (cur1 != cur2) {
- SvREFCNT_dec_NN(svrecode);
- return FALSE;
- }
- }
- else {
- if (SvUTF8(sv1)) {
+ /* Differing utf8ness. */
+ if (SvUTF8(sv1)) {
/* sv1 is the UTF-8 one */
return bytes_cmp_utf8((const U8*)pv2, cur2,
(const U8*)pv1, cur1) == 0;
- }
- else {
+ }
+ else {
/* sv2 is the UTF-8 one */
return bytes_cmp_utf8((const U8*)pv1, cur1,
(const U8*)pv2, cur2) == 0;
- }
- }
+ }
}
if (cur1 == cur2)
pv2 = SvPV_flags_const(sv2, cur2, flags);
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
- /* Differing utf8ness.
- * Do not UTF8size the comparands as a side-effect. */
+ /* Differing utf8ness. */
if (SvUTF8(sv1)) {
- if (IN_ENCODING) {
- svrecode = newSVpvn(pv2, cur2);
- sv_recode_to_utf8(svrecode, _get_encoding());
- pv2 = SvPV_const(svrecode, cur2);
- }
- else {
const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2,
(const U8*)pv1, cur1);
return retval ? retval < 0 ? -1 : +1 : 0;
- }
}
else {
- if (IN_ENCODING) {
- svrecode = newSVpvn(pv1, cur1);
- sv_recode_to_utf8(svrecode, _get_encoding());
- pv1 = SvPV_const(svrecode, cur1);
- }
- else {
const int retval = bytes_cmp_utf8((const U8*)pv1, cur1,
(const U8*)pv2, cur2);
return retval ? retval < 0 ? -1 : +1 : 0;
- }
}
}
if (PL_collation_standard)
goto raw_compare;
- len1 = 0;
- pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
- len2 = 0;
- pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
+ len1 = len2 = 0;
+
+ /* Revert to using raw compare if both operands exist, but either one
+ * doesn't transform properly for collation */
+ if (sv1 && sv2) {
+ pv1 = sv_collxfrm_flags(sv1, &len1, flags);
+ if (! pv1) {
+ goto raw_compare;
+ }
+ pv2 = sv_collxfrm_flags(sv2, &len2, flags);
+ if (! pv2) {
+ goto raw_compare;
+ }
+ }
+ else {
+ pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
+ pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
+ }
if (!pv1 || !len1) {
if (pv2 && len2)
PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
+
+ /* If we don't have collation magic on 'sv', or the locale has changed
+ * since the last time we calculated it, get it and save it now */
if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
const char *s;
char *xf;
STRLEN len, xlen;
+ /* Free the old space */
if (mg)
Safefree(mg->mg_ptr);
+
s = SvPV_flags_const(sv, len, flags);
- if ((xf = mem_collxfrm(s, len, &xlen))) {
+ if ((xf = _mem_collxfrm(s, len, &xlen, cBOOL(SvUTF8(sv))))) {
if (! mg) {
mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm,
0, 0);
}
}
}
+
if (mg && mg->mg_ptr) {
*nxp = mg->mg_len;
return mg->mg_ptr + sizeof(PL_collation_ix);
/* some trace debug output */
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
+ "Screamer: entering, ptr=%" UVuf ", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"
- UVuf"\n",
+ "Screamer: entering: PerlIO * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%"
+ UVuf "\n",
PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
if (cnt > 0) {
/* if there is a separator */
if (rslen) {
- /* loop until we hit the end of the read-ahead buffer */
- while (cnt > 0) { /* this | eat */
- /* scan forward copying and searching for rslast as we go */
- cnt--;
- if ((*bp++ = *ptr++) == rslast) /* really | dust */
- goto thats_all_folks; /* screams | sed :-) */
- }
+ /* find next rslast */
+ STDCHAR *p;
+
+ /* shortcut common case of blank line */
+ cnt--;
+ if ((*bp++ = *ptr++) == rslast)
+ goto thats_all_folks;
+
+ p = (STDCHAR *)memchr(ptr, rslast, cnt);
+ if (p) {
+ SSize_t got = p - ptr + 1;
+ Copy(ptr, bp, got, STDCHAR);
+ ptr += got;
+ bp += got;
+ cnt -= got;
+ goto thats_all_folks;
+ }
+ Copy(ptr, bp, cnt, STDCHAR);
+ ptr += cnt;
+ bp += cnt;
+ cnt = 0;
}
else {
/* no separator, slurp the full buffer */
/* we need to refill the read-ahead buffer if possible */
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: going to getc, ptr=%"UVuf", cnt=%"IVdf"\n",
+ "Screamer: going to getc, ptr=%" UVuf ", cnt=%" IVdf "\n",
PTR2UV(ptr),(IV)cnt));
PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
DEBUG_Pv(PerlIO_printf(Perl_debug_log,
- "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf"\n",
+ "Screamer: pre: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n",
PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
i = PerlIO_getc(fp); /* get more characters */
DEBUG_Pv(PerlIO_printf(Perl_debug_log,
- "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%"IVdf", base=%"UVuf"\n",
+ "Screamer: post: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n",
PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
cnt = PerlIO_get_cnt(fp);
ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: after getc, ptr=%"UVuf", cnt=%"IVdf"\n",
+ "Screamer: after getc, ptr=%" UVuf ", cnt=%" IVdf "\n",
PTR2UV(ptr),(IV)cnt));
if (i == EOF) /* all done for ever? */
if (shortbuffered)
cnt += shortbuffered;
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: quitting, ptr=%"UVuf", cnt=%"IVdf"\n",PTR2UV(ptr),(IV)cnt));
+ "Screamer: quitting, ptr=%" UVuf ", cnt=%" IVdf "\n",PTR2UV(ptr),(IV)cnt));
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=%"IVdf", base=%"UVuf
+ "Screamer: end: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf
"\n",
PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
return;
}
+ /* treat AV/HV/CV/FM/IO and non-fake GVs as immutable */
+ if (SvTYPE(sv) >= SVt_PVAV || (isGV_with_GP(sv) && !SvFAKE(sv)))
+ Perl_croak_no_modify();
+
if (!(flags & SVp_POK) || !*SvPVX_const(sv)) {
if ((flags & SVTYPEMASK) < SVt_PVIV)
sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV));
/* I don't think we can get here. Maybe I should assert this
And if we do get here I suspect that sv_setnv will croak. NWC
Fall through. */
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\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_const(sv), SvIVX(sv), SvNVX(sv)));
}
#endif /* PERL_PRESERVE_IVUV */
return;
}
}
+
+ /* treat AV/HV/CV/FM/IO and non-fake GVs as immutable */
+ if (SvTYPE(sv) >= SVt_PVAV || (isGV_with_GP(sv) && !SvFAKE(sv)))
+ Perl_croak_no_modify();
+
if (!(flags & SVp_POK)) {
if ((flags & SVTYPEMASK) < SVt_PVIV)
sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV);
/* I don't think we can get here. Maybe I should assert this
And if we do get here I suspect that sv_setnv will croak. NWC
Fall through. */
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\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_const(sv), SvIVX(sv), SvNVX(sv)));
}
}
if (!todo[(U8)*HeKEY(entry)])
continue;
gv = MUTABLE_GV(HeVAL(entry));
+ if (!isGV(gv))
+ continue;
sv = GvSV(gv);
if (sv && !SvREADONLY(sv)) {
SV_CHECK_THINKFIRST_COW_DROP(sv);
gv = MUTABLE_GV(sv);
io = GvIO(gv);
if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %"HEKf,
+ Perl_croak(aTHX_ "Bad filehandle: %" HEKf,
HEKfARG(GvNAME_HEK(gv)));
break;
}
newsv = sv_newmortal();
sv_setsv_nomg(newsv, sv);
}
- Perl_croak(aTHX_ "Bad filehandle: %"SVf, SVfARG(newsv));
+ Perl_croak(aTHX_ "Bad filehandle: %" SVf, SVfARG(newsv));
}
break;
}
if (!SvPOK(sv)) {
SvPOK_on(sv); /* validate pointer */
SvTAINT(sv);
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n",
PTR2UV(sv),SvPVX_const(sv)));
}
}
Returns a string describing what the SV is a reference to.
+If ob is true and the SV is blessed, the string is the class name,
+otherwise it is the type of the SV, "SCALAR", "ARRAY" etc.
+
=cut
*/
Returns a SV describing what the SV passed in is a reference to.
+dst can be a SV to be set to the description or NULL, in which case a
+mortal SV is returned.
+
+If ob is true and the SV is blessed, the description is the class
+name, otherwise it is the type of the SV, "SCALAR", "ARRAY" etc.
+
=cut
*/
if (ob && SvOBJECT(sv)) {
HvNAME_get(SvSTASH(sv))
? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv)))
- : sv_setpvn(dst, "__ANON__", 8);
+ : sv_setpvs(dst, "__ANON__");
}
else {
const char * reftype = sv_reftype(sv, 0);
PERL_ARGS_ASSERT_SV_SETREF_PV;
if (!pv) {
- sv_setsv(rv, &PL_sv_undef);
+ sv_set_undef(rv);
SvSETMAGIC(rv);
}
else
return FALSE;
}
+#ifndef NO_MATHOMS /* Can't move these to mathoms.c because call uiv_2buf(),
+ private to this file */
+
/*
=for apidoc sv_setpviv
SvSETMAGIC(sv);
}
+#endif /* NO_MATHOMS */
+
#if defined(PERL_IMPLICIT_CONTEXT)
/* pTHX_ magic can't cope with varargs, so this is a no-context
=for apidoc sv_vcatpvf
Processes its arguments like C<sv_catpvfn> called with a non-null C-style
-variable argument list, and appends the formatted
+variable argument list, and appends the formatted output
to an SV. Does not handle 'set' magic. See C<L</sv_vcatpvf_mg>>.
Usually used via its frontend C<sv_catpvf>.
{
PERL_ARGS_ASSERT_SV_VSETPVFN;
- sv_setpvs(sv, "");
+ SvPVCLEAR(sv);
sv_vcatpvfn_flags(sv, pat, patlen, args, svargs, svmax, maybe_tainted, 0);
}
* the hexadecimal values (for %a/%A). The nv is the NV where the value
* are being extracted from (either directly from the long double in-memory
* presentation, or from the uquad computed via frexp+ldexp). frexp also
- * is used to update the exponent. vhex is the pointer to the beginning
- * of the output buffer (of VHEX_SIZE).
+ * is used to update the exponent. The subnormal is set to true
+ * for IEEE 754 subnormals/denormals (including the x86 80-bit format).
+ * The vhex is the pointer to the beginning of the output buffer of VHEX_SIZE.
*
* The tricky part is that S_hextract() needs to be called twice:
* the first time with vend as NULL, and the second time with vend as
* (the extraction of the hexadecimal values) takes place.
* Sanity failures cause fatal failures during both rounds. */
STATIC U8*
-S_hextract(pTHX_ const NV nv, int* exponent, U8* vhex, U8* vend)
+S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal,
+ U8* vhex, U8* vend)
{
U8* v = vhex;
int ix;
int ixmin = 0, ixmax = 0;
- /* XXX Inf/NaN/denormal handling in the HEXTRACT_IMPLICIT_BIT,
- * and elsewhere. */
+ /* XXX Inf/NaN are not handled here, since it is
+ * assumed they are to be output as "Inf" and "NaN". */
/* These macros are just to reduce typos, they have multiple
* repetitions below, but usually only one (or sometimes two)
for (ix = a; ix >= b; ix--) { HEXTRACT_BYTE(ix); }
#define HEXTRACT_BYTES_BE(a, b) \
for (ix = a; ix <= b; ix++) { HEXTRACT_BYTE(ix); }
+#define HEXTRACT_GET_SUBNORMAL(nv) *subnormal = Perl_fp_class_denorm(nv)
#define HEXTRACT_IMPLICIT_BIT(nv) \
STMT_START { \
- if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
+ if (!*subnormal) { \
+ if (vend) *v++ = ((nv) == 0.0) ? 0 : 1; else v++; \
+ } \
} STMT_END
-/* Most formats do. Those which don't should undef this. */
+/* Most formats do. Those which don't should undef this.
+ *
+ * But also note that IEEE 754 subnormals do not have it, or,
+ * expressed alternatively, their implicit bit is zero. */
#define HEXTRACT_HAS_IMPLICIT_BIT
+
/* Many formats do. Those which don't should undef this. */
#define HEXTRACT_HAS_TOP_NYBBLE
const U8* vmaxend = vhex + HEXTRACTSIZE;
PERL_UNUSED_VAR(ix); /* might happen */
(void)Perl_frexp(PERL_ABS(nv), exponent);
+ *subnormal = FALSE;
if (vend && (vend <= vhex || vend > vmaxend)) {
/* diag_listed_as: Hexadecimal float: internal error (%s) */
Perl_croak(aTHX_ "Hexadecimal float: internal error (entry)");
#if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE)
# if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
/* Used in e.g. VMS and HP-UX IA-64, e.g. -0.1L:
- * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb 3f */
+ * 9a 99 99 99 99 99 99 99 99 99 99 99 99 99 fb bf */
/* The bytes 13..0 are the mantissa/fraction,
* the 15,14 are the sign+exponent. */
const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_IMPLICIT_BIT(nv);
# undef HEXTRACT_HAS_TOP_NYBBLE
HEXTRACT_BYTES_LE(13, 0);
/* The bytes 2..15 are the mantissa/fraction,
* the 0,1 are the sign+exponent. */
const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_IMPLICIT_BIT(nv);
# undef HEXTRACT_HAS_TOP_NYBBLE
HEXTRACT_BYTES_BE(2, 15);
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN
/* x86 80-bit "extended precision", 64 bits of mantissa / fraction /
- * significand, 15 bits of exponent, 1 bit of sign. NVSIZE can
- * be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux and OS X),
- * meaning that 2 or 6 bytes are empty padding. */
- /* The bytes 7..0 are the mantissa/fraction */
+ * significand, 15 bits of exponent, 1 bit of sign. No implicit bit.
+ * NVSIZE can be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux
+ * and OS X), meaning that 2 or 6 bytes are empty padding. */
+ /* The bytes 0..1 are the sign+exponent,
+ * the bytes 2..9 are the mantissa/fraction. */
const U8* nvp = (const U8*)(&nv);
# undef HEXTRACT_HAS_IMPLICIT_BIT
# undef HEXTRACT_HAS_TOP_NYBBLE
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_BYTES_LE(7, 0);
# elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN
/* Does this format ever happen? (Wikipedia says the Motorola
const U8* nvp = (const U8*)(&nv);
# undef HEXTRACT_HAS_IMPLICIT_BIT
# undef HEXTRACT_HAS_TOP_NYBBLE
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_BYTES_BE(0, 7);
# else
# define HEXTRACT_FALLBACK
# ifdef HEXTRACT_LITTLE_ENDIAN
/* 0 1 2 3 4 5 6 7 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_IMPLICIT_BIT(nv);
HEXTRACT_TOP_NYBBLE(6);
HEXTRACT_BYTES_LE(5, 0);
# elif defined(HEXTRACT_BIG_ENDIAN)
/* 7 6 5 4 3 2 1 0 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */
const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_IMPLICIT_BIT(nv);
HEXTRACT_TOP_NYBBLE(1);
HEXTRACT_BYTES_BE(2, 7);
# elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE
/* 4 5 6 7 0 1 2 3 (MSB = 7, LSB = 0, 6:7 = nybble:exponent:sign) */
const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_IMPLICIT_BIT(nv);
HEXTRACT_TOP_NYBBLE(2); /* 6 */
HEXTRACT_BYTE(1); /* 5 */
# elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE
/* 3 2 1 0 7 6 5 4 (MSB = 7, LSB = 0, 7:6 = sign:exponent:nybble) */
const U8* nvp = (const U8*)(&nv);
+ HEXTRACT_GET_SUBNORMAL(nv);
HEXTRACT_IMPLICIT_BIT(nv);
HEXTRACT_TOP_NYBBLE(5); /* 6 */
HEXTRACT_BYTE(6); /* 5 */
# endif
#endif /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) #else */
# ifdef HEXTRACT_FALLBACK
+ HEXTRACT_GET_SUBNORMAL(nv);
# undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */
/* The fallback is used for the double-double format, and
* for unknown long double formats, and for unknown double
* vectorize happen normally
*/
if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) {
- if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) {
+ if ( hv_existss(MUTABLE_HV(SvRV(vecsv)), "alpha") ) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF),
"vector argument not supported with alpha versions");
goto vdblank;
if (vectorize)
goto unknown;
if (infnan)
- Perl_croak(aTHX_ "Cannot printf %"NVgf" with '%c'",
+ Perl_croak(aTHX_ "Cannot printf %" NVgf " with '%c'",
/* no va_arg() case */
SvNV_nomg(argsv), (int)c);
uv = (args) ? va_arg(*args, int) : SvIV_nomg(argsv);
i = PERL_INT_MIN;
(void)Perl_frexp((NV)fv, &i);
if (i == PERL_INT_MIN)
- Perl_die(aTHX_ "panic: frexp: %"FV_GF, fv);
+ Perl_die(aTHX_ "panic: frexp: %" FV_GF, fv);
/* Do not set hexfp earlier since we want to printf
* Inf/NaN for Inf/NaN, not their hexfp. */
hexfp = isALPHA_FOLD_EQ(c, 'a');
U8* v = vhex; /* working pointer to vhex */
U8* vend; /* pointer to one beyond last digit of vhex */
U8* vfnz = NULL; /* first non-zero */
+ U8* vlnz = NULL; /* last non-zero */
+ U8* v0 = NULL; /* first output */
const bool lower = (c == 'a');
/* At output the values of vhex (up to vend) will
* be mapped through the xdig to get the actual
const char* xdig = PL_hexdigit;
int zerotail = 0; /* how many extra zeros to append */
int exponent = 0; /* exponent of the floating point input */
+ bool hexradix = FALSE; /* should we output the radix */
+ bool subnormal = FALSE; /* IEEE 754 subnormal/denormal */
+ bool negative = FALSE;
- /* XXX: denormals, NaN, Inf.
+ /* XXX: NaN, Inf -- though they are printed as "NaN" and "Inf".
*
* For example with denormals, (assuming the vanilla
* 64-bit double): the exponent is zero. 1xp-1074 is
* the smallest denormal and the smallest double, it
- * should be output as 0x0.0000000000001p-1022 to
+ * could be output also as 0x0.0000000000001p-1022 to
* match its internal structure. */
- vend = S_hextract(aTHX_ nv, &exponent, vhex, NULL);
- S_hextract(aTHX_ nv, &exponent, vhex, vend);
+ vend = S_hextract(aTHX_ nv, &exponent, &subnormal, vhex, NULL);
+ S_hextract(aTHX_ nv, &exponent, &subnormal, vhex, vend);
#if NVSIZE > DOUBLESIZE
# ifdef HEXTRACT_HAS_IMPLICIT_BIT
/* In this case there is an implicit bit,
- * and therefore the exponent is shifted shift by one. */
+ * and therefore the exponent is shifted by one. */
exponent--;
# else
- /* In this case there is no implicit bit,
- * and the exponent is shifted by the first xdigit. */
- exponent -= 4;
+# ifdef 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()
+ * returned the scientific-style floating exponent. We want
+ * to map the last one as:
+ * -16831..-16384 -> -16382 (the last normal is 0x1p-16382)
+ * -16835..-16388 -> -16384
+ * since we want to keep the first hexdigit
+ * as one of the [8421]. */
+ exponent = -4 * ( (exponent + 1) / -4) - 2;
+ } else {
+ exponent -= 4;
+ }
+# endif
+ /* TBD: other non-implicit-bit platforms than the x86-80. */
# endif
#endif
- if (fv < 0)
+ negative = fv < 0 || Perl_signbit(nv);
+ if (negative)
*p++ = '-';
else if (plus)
*p++ = plus;
}
if (vfnz) {
- U8* vlnz = NULL; /* The last non-zero. */
-
/* Find the last non-zero xdigit. */
for (v = vend - 1; v >= vhex; v--) {
if (*v) {
exponent--;
#endif
- if (precis > 0) {
- if ((SSize_t)(precis + 1) < vend - vhex) {
- bool round;
+ if (subnormal) {
+#ifndef NV_X86_80_BIT
+ if (vfnz[0] > 1) {
+ /* IEEE 754 subnormals (but not the x86 80-bit):
+ * we want "normalize" the subnormal,
+ * so we need to right shift the hex nybbles
+ * so that the output of the subnormal starts
+ * from the first true bit. (Another, equally
+ * valid, policy would be to dump the subnormal
+ * nybbles as-is, to display the "physical" layout.) */
+ int i, n;
+ U8 *vshr;
+ /* Find the ceil(log2(v[0])) of
+ * the top non-zero nybble. */
+ for (i = vfnz[0], n = 0; i > 1; i >>= 1, n++) { }
+ assert(n < 4);
+ vlnz[1] = 0;
+ for (vshr = vlnz; vshr >= vfnz; vshr--) {
+ vshr[1] |= (vshr[0] & (0xF >> (4 - n))) << (4 - n);
+ vshr[0] >>= n;
+ }
+ if (vlnz[1]) {
+ vlnz++;
+ }
+ }
+#endif
+ v0 = vfnz;
+ } else {
+ v0 = vhex;
+ }
- v = vhex + precis + 1;
- /* Round away from zero: if the tail
- * beyond the precis xdigits is equal to
- * or greater than 0x8000... */
- round = *v > 0x8;
- if (!round && *v == 0x8) {
- for (v++; v < vend; v++) {
- if (*v) {
- round = TRUE;
- break;
- }
+ if (has_precis) {
+ U8* ve = (subnormal ? vlnz + 1 : vend);
+ SSize_t vn = ve - (subnormal ? vfnz : vhex);
+ if ((SSize_t)(precis + 1) < vn) {
+ bool overflow = FALSE;
+ if (v0[precis + 1] < 0x8) {
+ /* Round down, nothing to do. */
+ } else if (v0[precis + 1] > 0x8) {
+ /* Round up. */
+ v0[precis]++;
+ overflow = v0[precis] > 0xF;
+ v0[precis] &= 0xF;
+ } else { /* v0[precis] == 0x8 */
+ /* Half-point: round towards the one
+ * with the even least-significant digit:
+ * 08 -> 0 88 -> 8
+ * 18 -> 2 98 -> a
+ * 28 -> 2 a8 -> a
+ * 38 -> 4 b8 -> c
+ * 48 -> 4 c8 -> c
+ * 58 -> 6 d8 -> e
+ * 68 -> 6 e8 -> e
+ * 78 -> 8 f8 -> 10 */
+ if ((v0[precis] & 0x1)) {
+ v0[precis]++;
}
+ overflow = v0[precis] > 0xF;
+ v0[precis] &= 0xF;
}
- if (round) {
- for (v = vhex + precis; v >= vhex; v--) {
- if (*v < 0xF) {
- (*v)++;
+
+ if (overflow) {
+ for (v = v0 + precis - 1; v >= v0; v--) {
+ (*v)++;
+ overflow = *v > 0xF;
+ (*v) &= 0xF;
+ if (!overflow) {
break;
}
- *v = 0;
- if (v == vhex) {
- /* If the carry goes all the way to
- * the front, we need to output
- * a single '1'. This goes against
- * the "xdigit and then radix"
- * but since this is "cannot happen"
- * category, that is probably good. */
- *p++ = xdig[1];
- }
+ }
+ if (v == v0 - 1 && overflow) {
+ /* If the overflow goes all the
+ * way to the front, we need to
+ * insert 0x1 in front, and adjust
+ * the exponent. */
+ Move(v0, v0 + 1, vn, char);
+ *v0 = 0x1;
+ exponent += 4;
}
}
+
/* The new effective "last non zero". */
- vlnz = vhex + precis;
+ vlnz = v0 + precis;
}
else {
- zerotail = precis - (vlnz - vhex);
+ zerotail =
+ subnormal ? precis - vn + 1 :
+ precis - (vlnz - vhex);
}
}
- v = vhex;
+ v = v0;
*p++ = xdig[*v++];
- /* The radix is always output after the first
- * non-zero xdigit, or if alt. */
- if (vfnz < vlnz || alt) {
+ /* If there are non-zero xdigits, the radix
+ * is output after the first one. */
+ if (vfnz < vlnz) {
+ hexradix = TRUE;
+ }
+ }
+ else {
+ *p++ = '0';
+ exponent = 0;
+ zerotail = precis;
+ }
+
+ /* The radix is always output if precis, or if alt. */
+ if (precis > 0 || alt) {
+ hexradix = TRUE;
+ }
+
+ if (hexradix) {
#ifndef USE_LOCALE_NUMERIC
*p++ = '.';
#else
}
RESTORE_LC_NUMERIC();
#endif
- }
+ }
+ if (vlnz) {
while (v <= vlnz)
*p++ = xdig[*v++];
-
- while (zerotail--)
- *p++ = '0';
}
- else {
+
+ if (zerotail > 0) {
+ while (zerotail--) {
*p++ = '0';
- exponent = 0;
+ }
}
elen = p - PL_efloatbuf;
memset(PL_efloatbuf + elen, ' ', width - elen);
}
else if (fill == '0') {
- /* Insert the zeros between the "0x" and
- * the digits, otherwise we end up with
- * "0000xHHH..." */
+ /* Insert the zeros after the "0x" and the
+ * the potential sign, but before the digits,
+ * otherwise we end up with "0000xH.HHH...",
+ * when we want "0x000H.HHH..." */
STRLEN nzero = width - elen;
char* zerox = PL_efloatbuf + 2;
- Move(zerox, zerox + nzero, elen - 2, char);
+ STRLEN nmove = elen - 2;
+ if (negative || plus) {
+ zerox++;
+ nmove--;
+ }
+ Move(zerox, zerox + nzero, nmove, char);
memset(zerox, fill, nzero);
}
else {
elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize,
qfmt, nv);
if ((IV)elen == -1)
- Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s|'", qfmt);
+ Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt);
if (qfmt != ptr)
Safefree(qfmt);
}
sv_catpvn_nomg(msg, f, 1);
} else {
Perl_sv_catpvf(aTHX_ msg,
- "\\%03"UVof, (UV)*f & 0xFF);
+ "\\%03" UVof, (UV)*f & 0xFF);
}
}
sv_catpvs(msg, "\"");
} else {
sv_catpvs(msg, "end of string");
}
- Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */
+ Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%" SVf, SVfARG(msg)); /* yes, this is reentrant */
}
/* output mangled stuff ... */
parser->old_parser = NULL;
parser->stack = NULL;
parser->ps = NULL;
- parser->stack_size = 0;
+ parser->stack_max1 = 0;
/* XXX parser->stack->state = 0; */
/* XXX eventually, just Copy() most of the parser struct ? */
parser->multi_start = proto->multi_start;
parser->multi_end = proto->multi_end;
parser->preambled = proto->preambled;
- parser->sublex_info = proto->sublex_info; /* XXX not quite right */
+ parser->lex_super_state = proto->lex_super_state;
+ parser->lex_sub_inwhat = proto->lex_sub_inwhat;
+ parser->lex_sub_op = proto->lex_sub_op;
+ parser->lex_sub_repl= sv_dup_inc(proto->lex_sub_repl, param);
parser->linestr = sv_dup_inc(proto->linestr, param);
parser->expect = proto->expect;
parser->copline = proto->copline;
parser->in_my = proto->in_my;
parser->in_my_stash = hv_dup(proto->in_my_stash, param);
parser->error_count = proto->error_count;
-
-
+ parser->sig_elems = proto->sig_elems;
+ parser->sig_optelems= proto->sig_optelems;
+ parser->sig_slurpy = proto->sig_slurpy;
parser->linestr = sv_dup_inc(proto->linestr, param);
{
#if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR)
DIR *pwd;
const Direntry_t *dirent;
- char smallbuf[256];
+ char smallbuf[256]; /* XXX MAXPATHLEN, surely? */
char *name = NULL;
STRLEN len = 0;
long pos;
pos = PerlDir_tell(dp);
if ((dirent = PerlDir_read(dp))) {
len = d_namlen(dirent);
+ if (len > sizeof(dirent->d_name) && sizeof(dirent->d_name) > PTRSIZE) {
+ /* If the len is somehow magically longer than the
+ * maximum length of the directory entry, even though
+ * we could fit it in a buffer, we could not copy it
+ * from the dirent. Bail out. */
+ PerlDir_close(ret);
+ return (DIR*)NULL;
+ }
if (len <= sizeof smallbuf) name = smallbuf;
else Newx(name, len, char);
Move(dirent->d_name, name, len, char);
? SvREFCNT_inc(av_dup_inc((const AV *)
nmg->mg_obj, param))
: sv_dup_inc(nmg->mg_obj, param)
- : sv_dup(nmg->mg_obj, param);
+ : (nmg->mg_type == PERL_MAGIC_regdatum ||
+ nmg->mg_type == PERL_MAGIC_regdata)
+ ? nmg->mg_obj
+ : sv_dup(nmg->mg_obj, param);
if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) {
if (nmg->mg_len > 0) {
}
daux->xhv_name_count = saux->xhv_name_count;
- daux->xhv_fill_lazy = saux->xhv_fill_lazy;
daux->xhv_aux_flags = saux->xhv_aux_flags;
#ifdef PERL_HASH_RANDOMIZE_KEYS
daux->xhv_rand = saux->xhv_rand;
ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl);
switch (CxTYPE(ncx)) {
case CXt_SUB:
- ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0
- ? cv_dup_inc(ncx->blk_sub.cv, param)
- : cv_dup(ncx->blk_sub.cv,param));
+ ncx->blk_sub.cv = cv_dup_inc(ncx->blk_sub.cv, param);
if(CxHASARGS(ncx)){
- ncx->blk_sub.argarray = av_dup_inc(ncx->blk_sub.argarray,param);
ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,param);
} else {
- ncx->blk_sub.argarray = NULL;
ncx->blk_sub.savearray = NULL;
}
- ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
- ncx->blk_sub.oldcomppad);
+ ncx->blk_sub.prevcomppad = (PAD*)ptr_table_fetch(PL_ptr_table,
+ ncx->blk_sub.prevcomppad);
break;
case CXt_EVAL:
ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv,
param);
+ /* XXX should this sv_dup_inc? Or only if CxEVAL_TXT_REFCNTED ???? */
ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param);
ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param);
+ /* XXX what do do with cur_top_env ???? */
break;
case CXt_LOOP_LAZYSV:
ncx->blk_loop.state_u.lazysv.end
assert ((void *) &ncx->blk_loop.state_u.ary.ary ==
(void *) &ncx->blk_loop.state_u.lazysv.cur);
/* FALLTHROUGH */
- case CXt_LOOP_FOR:
+ case CXt_LOOP_ARY:
ncx->blk_loop.state_u.ary.ary
= av_dup_inc(ncx->blk_loop.state_u.ary.ary, param);
/* FALLTHROUGH */
+ case CXt_LOOP_LIST:
case CXt_LOOP_LAZYIV:
- case CXt_LOOP_PLAIN:
- /* code common to all CXt_LOOP_* types */
+ /* code common to all 'for' CXt_LOOP_* types */
+ ncx->blk_loop.itersave =
+ sv_dup_inc(ncx->blk_loop.itersave, param);
if (CxPADLOOP(ncx)) {
- ncx->blk_loop.itervar_u.oldcomppad
- = (PAD*)ptr_table_fetch(PL_ptr_table,
- ncx->blk_loop.itervar_u.oldcomppad);
- } else {
+ PADOFFSET off = ncx->blk_loop.itervar_u.svp
+ - &CX_CURPAD_SV(ncx->blk_loop, 0);
+ ncx->blk_loop.oldcomppad =
+ (PAD*)ptr_table_fetch(PL_ptr_table,
+ ncx->blk_loop.oldcomppad);
+ ncx->blk_loop.itervar_u.svp =
+ &CX_CURPAD_SV(ncx->blk_loop, off);
+ }
+ else {
+ /* this copies the GV if CXp_FOR_GV, or the SV for an
+ * alias (for \$x (...)) - relies on gv_dup being the
+ * same as sv_dup */
ncx->blk_loop.itervar_u.gv
= gv_dup((const GV *)ncx->blk_loop.itervar_u.gv,
param);
}
break;
+ case CXt_LOOP_PLAIN:
+ break;
case CXt_FORMAT:
- ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param);
+ ncx->blk_format.prevcomppad =
+ (PAD*)ptr_table_fetch(PL_ptr_table,
+ ncx->blk_format.prevcomppad);
+ ncx->blk_format.cv = cv_dup_inc(ncx->blk_format.cv, param);
ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param);
ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv,
param);
break;
+ case CXt_GIVEN:
+ ncx->blk_givwhen.defsv_save =
+ sv_dup_inc(ncx->blk_givwhen.defsv_save, param);
+ break;
case CXt_BLOCK:
case CXt_NULL:
case CXt_WHEN:
- case CXt_GIVEN:
break;
}
}
{
dVAR;
ANY * const ss = proto_perl->Isavestack;
- const I32 max = proto_perl->Isavestack_max;
+ const I32 max = proto_perl->Isavestack_max + SS_MAXPUSH;
I32 ix = proto_perl->Isavestack_ix;
ANY *nss;
const SV *sv;
iv = POPIV(ss,ix);
TOPIV(nss,ix) = iv;
break;
+ case SAVEt_TMPSFLOOR:
+ iv = POPIV(ss,ix);
+ TOPIV(nss,ix) = iv;
+ break;
case SAVEt_HPTR: /* HV* reference */
case SAVEt_APTR: /* AV* reference */
case SAVEt_SPTR: /* SV* reference */
break;
default:
Perl_croak(aTHX_
- "panic: ss_dup inconsistency (%"IVdf")", (IV) type);
+ "panic: ss_dup inconsistency (%" IVdf ")", (IV) type);
}
}
PL_forkprocess = proto_perl->Iforkprocess;
/* internal state */
- PL_maxo = proto_perl->Imaxo;
-
PL_main_start = proto_perl->Imain_start;
PL_eval_root = proto_perl->Ieval_root;
PL_eval_start = proto_perl->Ieval_start;
PL_collation_standard = proto_perl->Icollation_standard;
PL_collxfrm_base = proto_perl->Icollxfrm_base;
PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
+ PL_strxfrm_max_cp = proto_perl->Istrxfrm_max_cp;
#endif /* USE_LOCALE_COLLATE */
#ifdef USE_LOCALE_NUMERIC
/* Did the locale setup indicate UTF-8? */
PL_utf8locale = proto_perl->Iutf8locale;
PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale;
+ PL_in_utf8_COLLATE_locale = proto_perl->Iin_utf8_COLLATE_locale;
/* Unicode features (see perlrun/-C) */
PL_unicode = proto_perl->Iunicode;
/* magical thingies */
- PL_encoding = sv_dup(proto_perl->Iencoding, param);
- PL_lex_encoding = sv_dup(proto_perl->Ilex_encoding, param);
-
- sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */
- sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */
- sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */
+ SvPVCLEAR(PERL_DEBUG_PAD(0)); /* For regex debugging. */
+ SvPVCLEAR(PERL_DEBUG_PAD(1)); /* ext/re needs these */
+ SvPVCLEAR(PERL_DEBUG_PAD(2)); /* even without DEBUGGING. */
/* Clone the regex array */
PL_GCB_invlist = sv_dup_inc(proto_perl->IGCB_invlist, param);
PL_SB_invlist = sv_dup_inc(proto_perl->ISB_invlist, param);
PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param);
+ PL_seen_deprecated_macro = hv_dup_inc(proto_perl->Iseen_deprecated_macro, 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_watchok = PL_watchaddr ? * PL_watchaddr : NULL;
if (PL_debug && PL_watchaddr) {
PerlIO_printf(Perl_debug_log,
- "WATCHING: %"UVxf" cloned as %"UVxf" with value %"UVxf"\n",
+ "WATCHING: %" UVxf " cloned as %" UVxf " with value %" UVxf "\n",
PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr),
PTR2UV(PL_watchok));
}
If C<sv> already is UTF-8 (or if it is not C<POK>), or if C<encoding>
is not a reference, nothing is done to C<sv>. If C<encoding> is not
an C<Encode::XS> Encoding object, bad things will happen.
-(See F<lib/encoding.pm> and L<Encode>.)
+(See F<cpan/Encode/encoding.pm> and L<Encode>.)
The PV of C<sv> is returned.
/* Look for an entry in the array whose value has the same SV as val;
* If so, return the index, otherwise return -1. */
-STATIC I32
+STATIC SSize_t
S_find_array_subscript(pTHX_ const AV *const av, const SV *const val)
{
PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT;
if (val != &PL_sv_undef) {
SV ** const svp = AvARRAY(av);
- I32 i;
+ SSize_t i;
for (i=AvFILLp(av); i>=0; i--)
if (svp[i] == val)
SV*
Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ,
- const SV *const keyname, I32 aindex, int subscript_type)
+ const SV *const keyname, SSize_t aindex, int subscript_type)
{
SV * const name = sv_newmortal();
if (subscript_type == FUV_SUBSCRIPT_HASH) {
SV * const sv = newSV(0);
+ STRLEN len;
+ const char * const pv = SvPV_nomg_const((SV*)keyname, len);
+
*SvPVX(name) = '$';
Perl_sv_catpvf(aTHX_ name, "{%s}",
- pv_pretty(sv, SvPVX_const(keyname), SvCUR(keyname), 32, NULL, NULL,
+ pv_pretty(sv, pv, len, 32, NULL, NULL,
PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT ));
SvREFCNT_dec_NN(sv);
}
else if (subscript_type == FUV_SUBSCRIPT_ARRAY) {
*SvPVX(name) = '$';
- Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex);
+ Perl_sv_catpvf(aTHX_ name, "[%" IVdf "]", (IV)aindex);
}
else if (subscript_type == FUV_SUBSCRIPT_WITHIN) {
/* We know that name has no magic, so can use 0 instead of SV_GMAGIC */
switch (obase->op_type) {
+ case OP_UNDEF:
+ /* undef should care if its args are undef - any warnings
+ * will be from tied/magic vars */
+ break;
+
case OP_RV2AV:
case OP_RV2HV:
case OP_PADAV:
|| (obase->op_type == OP_PADRANGE
&& SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV)
);
- I32 index = 0;
+ SSize_t index = 0;
SV *keysv = NULL;
int subscript_type = FUV_SUBSCRIPT_WITHIN;
keysv, 0, FUV_SUBSCRIPT_HASH);
}
else {
- const I32 index
+ const SSize_t index
= find_array_subscript((const AV *)sv, uninit_sv);
if (index >= 0)
return varname(gv, '@', o->op_targ,
/* If we were executing OP_MULTIDEREF when the undef warning
* triggered, then it must be one of the index values within
* that triggered it. If not, then the only possibility is that
- * the value retrieved by the last aggregate lookup might be the
+ * the value retrieved by the last aggregate index might be the
* culprit. For the former, we set PL_multideref_pc each time before
* using an index, so work though the item list until we reach
* that point. For the latter, just work through the entire item
* list; the last aggregate retrieved will be the candidate.
+ * There is a third rare possibility: something triggered
+ * magic while fetching an array/hash element. Just display
+ * nothing in this case.
*/
/* the named aggregate, if any */
if ( index_type == MDEREF_INDEX_none
|| (actions & MDEREF_FLAG_last)
- || (last && items == last)
+ || (last && items >= last)
)
break;
} /* while */
if (PL_op == obase) {
- /* index was undef */
+ /* most likely index was undef */
*desc_p = ( (actions & MDEREF_FLAG_last)
&& (obase->op_private
: "delete"
: is_hv ? "hash element" : "array element";
assert(index_type != MDEREF_INDEX_none);
- if (index_gv)
- return varname(index_gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE);
- if (index_targ)
- return varname(NULL, '$', index_targ,
+ if (index_gv) {
+ if (GvSV(index_gv) == uninit_sv)
+ return varname(index_gv, '$', 0, NULL, 0,
+ FUV_SUBSCRIPT_NONE);
+ else
+ return NULL;
+ }
+ if (index_targ) {
+ if (PL_curpad[index_targ] == uninit_sv)
+ return varname(NULL, '$', index_targ,
NULL, 0, FUV_SUBSCRIPT_NONE);
- assert(is_hv); /* AV index is an IV and can't be undef */
- /* can a const HV index ever be undef? */
+ else
+ return NULL;
+ }
+ /* If we got to this point it was undef on a const subscript,
+ * so magic probably involved, e.g. $ISA[0]. Give up. */
return NULL;
}
keysv, 0, FUV_SUBSCRIPT_HASH);
}
else {
- const I32 index
+ const SSize_t index
= find_array_subscript((const AV *)sv, uninit_sv);
if (index >= 0)
return varname(agg_gv, '@', agg_targ,
*/
break;
}
+ match = 1;
goto do_op;
/* ops where $_ may be an implicit arg */
case OP_ALARM:
case OP_SEMGET:
case OP_GETLOGIN:
- case OP_UNDEF:
case OP_SUBSTR:
case OP_AEACH:
case OP_EACH:
sv_insert(varname, 0, 0, " ", 1);
}
}
- else if (PL_curstackinfo->si_type == PERLSI_SORT
- && CxMULTICALL(&cxstack[cxstack_ix]))
- {
+ else if (PL_curstackinfo->si_type == PERLSI_SORT && cxstack_ix == 0)
/* we've reached the end of a sort block or sub,
* and the uninit value is probably what that code returned */
desc = "sort";
- }
/* PL_warn_uninit_sv is constant */
GCC_DIAG_IGNORE(-Wformat-nonliteral);
https://perl5.git.perl.org / perl5.git / blobdiff