#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
=cut
*/
-int
+/* prior to 5.000 stable, this function returned the new OOK-less SvFLAGS
+ prior to 5.23.4 this function always returned 0
+*/
+
+void
Perl_sv_backoff(SV *const sv)
{
STRLEN delta;
SvLEN_set(sv, SvLEN(sv) + delta);
SvPV_set(sv, SvPVX(sv) - delta);
- Move(s, SvPVX(sv), SvCUR(sv)+1, char);
SvFLAGS(sv) &= ~SVf_OOK;
- return 0;
+ Move(s, SvPVX(sv), SvCUR(sv)+1, char);
+ return;
}
/*
}
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;
+
+ /* minimal subset of SV_CHECK_THINKFIRST_COW_DROP(dstr) */
+ if (SvREADONLY(dstr))
+ Perl_croak_no_modify();
+ if (SvROK(dstr))
+ sv_unref_flags(dstr, 0);
+
+ 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;
+
+ 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 (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;
}
Decrement an SV's reference count, and if it drops to zero, call
C<sv_clear> to invoke destructors and free up any memory used by
-the body; finally, deallocate the SV's head itself.
+the body; finally, deallocating the SV's head itself.
Normally called via a wrapper macro C<SvREFCNT_dec>.
=cut
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));
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);
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
*/
is safe. */
is_utf8 = (bool)va_arg(*args, int);
elen = va_arg(*args, UV);
- if ((IV)elen < 0) {
- /* check if utf8 length is larger than 0 when cast to IV */
- assert( (IV)elen >= 0 ); /* in DEBUGGING build we want to crash */
+ /* if utf8 length is larger than 0x7ffff..., then it might
+ * have been a signed value that wrapped */
+ if (elen > ((~(STRLEN)0) >> 1)) {
+ assert(0); /* in DEBUGGING build we want to crash */
elen= 0; /* otherwise we want to treat this as an empty string */
}
eptr = va_arg(*args, char *);
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 */
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 */
/* XXX: denormals, NaN, Inf.
*
# endif
#endif
- if (fv < 0)
+ if (fv < 0
+ || Perl_signbit(nv)
+ )
*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) {
v = vhex;
*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;
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);
}
}
}
- assert((IV)elen >= 0); /* here zero elen is fine */
+ /* signed value that's wrapped? */
+ assert(elen <= ((~(STRLEN)0) >> 1));
have = esignlen + zeros + elen;
if (have < zeros)
croak_memory_wrap();
return ret;
/* create anew and remember what it is */
+#ifdef __amigaos4__
+ ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE|PERLIO_DUP_FD);
+#else
ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
+#endif
ptr_table_store(PL_ptr_table, fp, ret);
return ret;
}
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 SvSCREAM ???? */
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 */
+ 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_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;
}
}
/* perlhost.h so we need to call into it
to clone the host, CPerlHost should have a c interface, sky */
+#ifndef __amigaos4__
if (flags & CLONEf_CLONE_HOST) {
return perl_clone_host(proto_perl,flags);
}
+#endif
return perl_clone_using(proto_perl, flags,
proto_perl->IMem,
proto_perl->IMemShared,
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.
C<encoding> is assumed to be an C<Encode> object, the PV of C<ssv> is
assumed to be octets in that encoding and decoding the input starts
from the position which S<C<(PV + *offset)>> pointed to. C<dsv> will be
-concatenated the decoded UTF-8 string from C<ssv>. Decoding will terminate
+concatenated with the decoded UTF-8 string from C<ssv>. Decoding will terminate
when the string C<tstr> appears in decoding output or the input ends on
the PV of C<ssv>. The value which C<offset> points will be modified
to the last input position on C<ssv>.
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