# 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.
#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
* 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 < 0x1000 || (newlen & (newlen - 1)))
+ && newlen != MEM_SIZE_MAX
+ )
newlen++;
#endif
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);
}
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 */
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)
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);
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);
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>.
#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);
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
/* 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)) {
PADOFFSET off = ncx->blk_loop.itervar_u.svp
- &CX_CURPAD_SV(ncx->blk_loop, 0);
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 */
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;
https://perl5.git.perl.org / perl5.git / blobdiff