X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/61b16eb90f32a2433d6de43e477a03b8d9fed039..274ed8ae511aa4c52d0c3e975eb44853d4f5336f:/sv.c diff --git a/sv.c b/sv.c index f2908e0..7f33794 100644 --- a/sv.c +++ b/sv.c @@ -403,34 +403,6 @@ S_del_sv(pTHX_ SV *p) #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 @@ -1525,7 +1497,11 @@ wrapper instead. =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; @@ -1541,9 +1517,9 @@ Perl_sv_backoff(SV *const sv) 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; } /* @@ -2420,7 +2396,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) =for apidoc sv_2iv_flags Return the integer value of an SV, doing any necessary string -conversion. If C includes C, does an C first. +conversion. If C has the C bit set, does an C first. Normally used via the C and C macros. =cut @@ -2516,7 +2492,7 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) =for apidoc sv_2uv_flags Return the unsigned integer value of an SV, doing any necessary string -conversion. If C includes C, does an C first. +conversion. If C has the C bit set, does an C first. Normally used via the C and C macros. =cut @@ -2599,7 +2575,7 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) =for apidoc sv_2nv_flags Return the num value of an SV, doing any necessary string or integer -conversion. If C includes C, does an C first. +conversion. If C has the C bit set, does an C first. Normally used via the C and C macros. =cut @@ -2925,7 +2901,7 @@ S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char plus) { =for apidoc sv_2pv_flags Returns a pointer to the string value of an SV, and sets C<*lp> to its length. -If flags includes C, does an C first. Coerces C to a +If flags has the C bit set, does an C first. Coerces C to a string if necessary. Normally invoked via the C macro. C and C usually end up here too. @@ -3236,7 +3212,7 @@ Like C, but doesn't invoke get magic first. =for apidoc sv_copypv_flags Implementation of C and C. Calls get magic iff flags -include C. +has the C bit set. =cut */ @@ -4180,9 +4156,18 @@ Perl_gv_setref(pTHX_ SV *const dstr, SV *const sstr) } 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 @@ -4259,25 +4244,83 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) 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 */ @@ -5408,8 +5451,8 @@ and C>. Concatenates the string from SV C onto the end of the string in SV C. If C is null, does nothing; otherwise modifies only C. -If C include C bit set, will call C on both SVs if -appropriate. If C include C, C will be called on +If C has the C bit set, will call C on both SVs if +appropriate. If C has the C bit set, C will be called on the modified SV afterward, if appropriate. C, C, and C are implemented in terms of this function. @@ -5753,10 +5796,9 @@ S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U3 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; } @@ -6838,7 +6880,7 @@ Perl_sv_newref(pTHX_ SV *const sv) Decrement an SV's reference count, and if it drops to zero, call C 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. =cut @@ -7637,7 +7679,7 @@ coerce its args to strings if necessary. Returns a boolean indicating whether the strings in the two SVs are identical. Is UTF-8 and S> aware and coerces its args to strings -if necessary. If C includes C, it handles get-magic, too. +if necessary. If the flags has the C bit set, it handles get-magic, too. =cut */ @@ -7730,7 +7772,7 @@ coerce its args to strings if necessary. See also C>. Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the string in C is less than, equal to, or greater than the string in C. Is UTF-8 and S> aware and will coerce its args to strings -if necessary. If the flags includes C, it handles get magic. See +if necessary. If the flags has the C bit set, it handles get magic. See also C>. =cut @@ -8769,6 +8811,10 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) 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)); @@ -8948,6 +8994,11 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) 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); @@ -9825,7 +9876,7 @@ can't cope with complex macro expressions. Always use the macro instead. =for apidoc sv_pvn_force_flags Get a sensible string out of the SV somehow. -If C has C bit set, will C on C if +If C has the C bit set, will C on C if appropriate, else not. C and C are implemented in terms of this function. You normally want to use the various wrapper macros instead: see @@ -9929,6 +9980,9 @@ Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp) 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 */ @@ -9987,6 +10041,12 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) 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 */ @@ -10817,7 +10877,7 @@ When running with taint checks enabled, indicates via C if results are untrustworthy (often due to the use of locales). -If called as C or flags include C, calls get magic. +If called as C or flags has the C bit set, calls get magic. Usually used via one of its frontends C and C. @@ -11444,9 +11504,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p 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 *); @@ -12309,6 +12370,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p 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 @@ -12316,6 +12378,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p 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. * @@ -12340,7 +12403,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p # endif #endif - if (fv < 0) + if (fv < 0 + || Perl_signbit(nv) + ) *p++ = '-'; else if (plus) *p++ = plus; @@ -12362,8 +12427,6 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } if (vfnz) { - U8* vlnz = NULL; /* The last non-zero. */ - /* Find the last non-zero xdigit. */ for (v = vend - 1; v >= vhex; v--) { if (*v) { @@ -12423,9 +12486,24 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p 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 @@ -12441,17 +12519,17 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } 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; @@ -12562,7 +12640,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p 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); } @@ -12690,7 +12768,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } - 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(); @@ -12931,7 +13010,11 @@ Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param) 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; } @@ -13889,24 +13972,22 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) 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 @@ -13920,33 +14001,50 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) 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; } } @@ -14404,9 +14502,11 @@ perl_clone(PerlInterpreter *proto_perl, UV flags) /* 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, @@ -15286,7 +15386,7 @@ will be converted into Unicode (and UTF-8). If C already is UTF-8 (or if it is not C), or if C is not a reference, nothing is done to C. If C is not an C Encoding object, bad things will happen. -(See F and L.) +(See F and L.) The PV of C is returned. @@ -15359,7 +15459,7 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) C is assumed to be an C object, the PV of C is assumed to be octets in that encoding and decoding the input starts from the position which S> pointed to. C will be -concatenated the decoded UTF-8 string from C. Decoding will terminate +concatenated with the decoded UTF-8 string from C. Decoding will terminate when the string C appears in decoding output or the input ends on the PV of C. The value which C points will be modified to the last input position on C. @@ -16235,13 +16335,10 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) 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);