X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=718e3056466f7606f8806cc00b0945a9f01a2a45;hb=bb8b33994a53bb53afb58737d43f046bfaebb2a9;hp=e5f7beaf4bc0f3a09fa49aebb61a20c92b41ecfd;hpb=c41f7ed2fea446da54380eaaa979695a710fbcb8;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index e5f7bea..718e305 100644 --- a/sv.c +++ b/sv.c @@ -544,7 +544,8 @@ Perl_sv_clean_all(pTHX) memory in the last arena-set (1/2 on average). In trade, we get back the 1st slot in each arena (ie 1.7% of a CV-arena, less for smaller types). The recovery of the wasted space allows use of - small arenas for large, rare body types, + small arenas for large, rare body types, by changing array* fields + in body_details_by_type[] below. */ struct arena_desc { char *arena; /* the raw storage, allocated aligned */ @@ -555,7 +556,7 @@ struct arena_desc { struct arena_set; /* Get the maximum number of elements in set[] such that struct arena_set - will fit within PERL_ARENA_SIZE, which is probabably just under 4K, and + will fit within PERL_ARENA_SIZE, which is probably just under 4K, and therefore likely to be 1 aligned memory page. */ #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \ @@ -2501,6 +2502,29 @@ Perl_sv_2nv(pTHX_ register SV *sv) return SvNVX(sv); } +/* +=for apidoc sv_2num + +Return an SV with the numeric value of the source SV, doing any necessary +reference or overload conversion. You must use the C macro to +access this function. + +=cut +*/ + +SV * +Perl_sv_2num(pTHX_ register SV *sv) +{ + if (!SvROK(sv)) + return sv; + if (SvAMAGIC(sv)) { + SV * const tmpsv = AMG_CALLun(sv,numer); + if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) + return sv_2num(tmpsv); + } + return sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))); +} + /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or * UV as a string towards the end of buf, and return pointers to start and * end of it. @@ -2769,8 +2793,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } errno = olderrno; #ifdef FIXNEGATIVEZERO - if (*s == '-' && s[1] == '0' && !s[2]) - my_strlcpy(s, "0", SvLEN(s)); + if (*s == '-' && s[1] == '0' && !s[2]) { + s[0] = '0'; + s[1] = 0; + } #endif while (*s) s++; #ifdef hcx @@ -3536,7 +3562,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } if (dtype >= SVt_PV) { - if (dtype == SVt_PVGV) { + if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { glob_assign_ref(dstr, sstr); return; } @@ -5073,7 +5099,9 @@ Perl_sv_clear(pTHX_ register SV *sv) } if (SvOBJECT(sv)) { - if (PL_defstash) { /* Still have a symbol table? */ + if (PL_defstash && /* Still have a symbol table? */ + SvDESTROYABLE(sv)) + { dSP; HV* stash; do { @@ -7951,6 +7979,8 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) Perl_croak(aTHX_ "Can't bless non-reference value"); tmpRef = SvRV(sv); if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { + if (SvIsCOW(tmpRef)) + sv_force_normal_flags(tmpRef, 0); if (SvREADONLY(tmpRef)) Perl_croak(aTHX_ PL_no_modify); if (SvOBJECT(tmpRef)) { @@ -8601,10 +8631,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV %p include pointer address (standard) %-p (SVf) include an SV (previously %_) %-p include an SV with precision - %1p (VDf) include a v-string (as %vd) %p reserved for future extensions Robin Barker 2005-07-14 + + %1p (VDf) removed. RMB 2007-10-19 */ char* r = q; bool sv = FALSE; @@ -8624,13 +8655,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV is_utf8 = TRUE; goto string; } -#if vdNUMBER - else if (n == vdNUMBER) { /* VDf */ - vectorize = TRUE; - VECTORIZE_ARGS - goto format_vd; - } -#endif else if (n) { if (ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ packWARN(WARN_INTERNAL), @@ -9996,10 +10020,10 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) /** We are joining here so we don't want do clone something that is bad **/ if (SvTYPE(sstr) == SVt_PVHV) { - const char * const hvname = HvNAME_get(sstr); + const HEK * const hvname = HvNAME_HEK(sstr); if (hvname) /** don't clone stashes if they already exist **/ - return (SV*)gv_stashpv(hvname,0); + return (SV*)gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0); } } @@ -10029,8 +10053,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) /* don't clone objects whose class has asked us not to */ if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) { - SvFLAGS(dstr) &= ~SVTYPEMASK; - SvOBJECT_off(dstr); + SvFLAGS(dstr) = 0; return dstr; } @@ -11347,6 +11370,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_lockhook = proto_perl->Ilockhook; PL_unlockhook = proto_perl->Iunlockhook; PL_threadhook = proto_perl->Ithreadhook; + PL_destroyhook = proto_perl->Idestroyhook; #ifdef THREADS_HAVE_PIDS PL_ppid = proto_perl->Ippid; @@ -12070,10 +12094,18 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) case OP_RV2SV: case OP_CUSTOM: - case OP_ENTERSUB: match = 1; /* XS or custom code could trigger random warnings */ goto do_op; + case OP_ENTERSUB: + case OP_GOTO: + /* XXX tmp hack: these two may call an XS sub, and currently + XS subs don't have a SUB entry on the context stack, so CV and + pad determination goes wrong, and BAD things happen. So, just + don't try to determine the value under those circumstances. + Need a better fix at dome point. DAPM 11/2007 */ + break; + case OP_POS: /* def-ness of rval pos() is independent of the def-ness of its arg */ if ( !(obase->op_flags & OPf_MOD))