X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/29f4f0ab0cd22a86a6abeeb9b5de96d9506fd84a..0f722b558ffdeebb2a4a1827ea54471c04bdd41d:/sv.c diff --git a/sv.c b/sv.c index 8820f2a..c509b03 100644 --- a/sv.c +++ b/sv.c @@ -1277,13 +1277,11 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) assert(SvPVX_const(sv) == 0); } - /* Could put this in the else clause below, as PVMG must have SvPVX - 0 already (the assertion above) */ - SvPV_set(sv, NULL); - if (old_type >= SVt_PVMG) { SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); + } else { + sv->sv_u.svu_array = NULL; /* or svu_hash */ } break; @@ -2544,87 +2542,6 @@ S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) return ptr; } -/* stringify_regexp(): private routine for use by sv_2pv_flags(): converts - * a regexp to its stringified form. - */ - -static char * -S_stringify_regexp(pTHX_ SV *sv, MAGIC *mg, STRLEN *lp) { - dVAR; - const regexp * const re = (regexp *)mg->mg_obj; - - if (!mg->mg_ptr) { - const char *fptr = "msix"; - char reflags[6]; - char ch; - int left = 0; - int right = 4; - bool need_newline = 0; - U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); - - while((ch = *fptr++)) { - if(reganch & 1) { - reflags[left++] = ch; - } - else { - reflags[right--] = ch; - } - reganch >>= 1; - } - if(left != 4) { - reflags[left] = '-'; - left = 5; - } - - mg->mg_len = re->prelen + 4 + left; - /* - * If /x was used, we have to worry about a regex ending with a - * comment later being embedded within another regex. If so, we don't - * want this regex's "commentization" to leak out to the right part of - * the enclosing regex, we must cap it with a newline. - * - * So, if /x was used, we scan backwards from the end of the regex. If - * we find a '#' before we find a newline, we need to add a newline - * ourself. If we find a '\n' first (or if we don't find '#' or '\n'), - * we don't need to add anything. -jfriedl - */ - if (PMf_EXTENDED & re->reganch) { - const char *endptr = re->precomp + re->prelen; - while (endptr >= re->precomp) { - const char c = *(endptr--); - if (c == '\n') - break; /* don't need another */ - if (c == '#') { - /* we end while in a comment, so we need a newline */ - mg->mg_len++; /* save space for it */ - need_newline = 1; /* note to add it */ - break; - } - } - } - - Newx(mg->mg_ptr, mg->mg_len + 1 + left, char); - mg->mg_ptr[0] = '('; - mg->mg_ptr[1] = '?'; - Copy(reflags, mg->mg_ptr+2, left, char); - *(mg->mg_ptr+left+2) = ':'; - Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); - if (need_newline) - mg->mg_ptr[mg->mg_len - 2] = '\n'; - mg->mg_ptr[mg->mg_len - 1] = ')'; - mg->mg_ptr[mg->mg_len] = 0; - } - PL_reginterp_cnt += re->program[0].next_off; - - if (re->reganch & ROPT_UTF8) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - if (lp) - *lp = mg->mg_len; - return mg->mg_ptr; -} - /* =for apidoc sv_2pv_flags @@ -2742,8 +2659,18 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) && ((SvFLAGS(referent) & (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) == (SVs_OBJECT|SVs_SMG)) - && (mg = mg_find(referent, PERL_MAGIC_qr))) { - return stringify_regexp(sv, mg, lp); + && (mg = mg_find(referent, PERL_MAGIC_qr))) + { + char *str = NULL; + I32 haseval = 0; + U32 flags = 0; + (str) = CALLREG_AS_STR(mg,lp,&flags,&haseval); + if (flags & 1) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + PL_reginterp_cnt += haseval; + return str; } else { const char *const typestr = sv_reftype(referent, 0); const STRLEN typelen = strlen(typestr); @@ -3583,7 +3510,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } (void)SvOK_off(dstr); SvRV_set(dstr, SvREFCNT_inc(SvRV(sstr))); - SvFLAGS(dstr) |= sflags & (SVf_ROK|SVf_AMAGIC); + SvFLAGS(dstr) |= sflags & SVf_ROK; assert(!(sflags & SVp_NOK)); assert(!(sflags & SVp_IOK)); assert(!(sflags & SVf_NOK)); @@ -3612,6 +3539,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) * possible small lose on short strings, but a big win on long ones. * It might even be a win on short strings if SvPVX_const(dstr) * has to be allocated and SvPVX_const(sstr) has to be freed. + * Likewise if we can set up COW rather than doing an actual copy, we + * drop to the else clause, as the swipe code and the COW setup code + * have much in common. */ /* Whichever path we take through the next code, we want this true, @@ -3619,10 +3549,28 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) (void)SvPOK_only(dstr); if ( - /* We're not already COW */ - ((sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY) + /* If we're already COW then this clause is not true, and if COW + is allowed then we drop down to the else and make dest COW + with us. If caller hasn't said that we're allowed to COW + shared hash keys then we don't do the COW setup, even if the + source scalar is a shared hash key scalar. */ + (((flags & SV_COW_SHARED_HASH_KEYS) + ? (sflags & (SVf_FAKE|SVf_READONLY)) != (SVf_FAKE|SVf_READONLY) + : 1 /* If making a COW copy is forbidden then the behaviour we + desire is as if the source SV isn't actually already + COW, even if it is. So we act as if the source flags + are not COW, rather than actually testing them. */ + ) #ifndef PERL_OLD_COPY_ON_WRITE - /* or we are, but dstr isn't a suitable target. */ + /* The change that added SV_COW_SHARED_HASH_KEYS makes the logic + when PERL_OLD_COPY_ON_WRITE is defined a little wrong. + Conceptually PERL_OLD_COPY_ON_WRITE being defined should + override SV_COW_SHARED_HASH_KEYS, because it means "always COW" + but in turn, it's somewhat dead code, never expected to go + live, but more kept as a placeholder on how to do it better + in a newer implementation. */ + /* If we are COW and dstr is a suitable target then we drop down + into the else and make dest a COW of us. */ || (SvFLAGS(dstr) & CAN_COW_MASK) != CAN_COW_FLAGS #endif ) @@ -3736,8 +3684,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } - SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8 - |SVf_AMAGIC); + SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); { const MAGIC * const smg = SvVSTRING_mg(sstr); if (smg) { @@ -3749,8 +3696,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } else if (sflags & (SVp_IOK|SVp_NOK)) { (void)SvOK_off(dstr); - SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK - |SVf_AMAGIC); + SvFLAGS(dstr) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK); if (sflags & SVp_IOK) { /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ SvIV_set(dstr, SvIVX(sstr)); @@ -3770,7 +3716,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvFAKE_off(sstr); gv_efullname3(dstr, (GV *)sstr, "*"); SvFLAGS(sstr) |= wasfake; - SvFLAGS(dstr) |= sflags & SVf_AMAGIC; } else (void)SvOK_off(dstr); @@ -5687,18 +5632,7 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, if (PL_utf8cache < 0) { const U8 *start = (const U8 *) SvPVX_const(sv); - const U8 *const end = start + byte; - STRLEN realutf8 = 0; - - while (start < end) { - start += UTF8SKIP(start); - realutf8++; - } - - /* Can't use S_sv_pos_b2u_forwards as it will scream warnings on - surrogates. FIXME - is it inconsistent that b2u warns, but u2b - doesn't? I don't know whether this difference was introduced with - the caching code in 5.8.1. */ + const STRLEN realutf8 = utf8_length(start, start + byte); if (realutf8 != utf8) { /* Need to turn the assertions off otherwise we may recurse @@ -5809,29 +5743,6 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, ASSERT_UTF8_CACHE(cache); } -/* If we don't know the character offset of the end of a region, our only - option is to walk forwards to the target byte offset. */ -static STRLEN -S_sv_pos_b2u_forwards(pTHX_ const U8 *s, const U8 *const target) -{ - STRLEN len = 0; - while (s < target) { - STRLEN n = 1; - - /* Call utf8n_to_uvchr() to validate the sequence - * (unless a simple non-UTF character) */ - if (!UTF8_IS_INVARIANT(*s)) - utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0); - if (n > 0) { - s += n; - len++; - } - else - break; - } - return len; -} - /* We already know all of the way, now we may be able to walk back. The same assumption is made as in S_sv_pos_u2b_midway(), namely that walking backward is half the speed of walking forward. */ @@ -5843,7 +5754,7 @@ S_sv_pos_b2u_midway(pTHX_ const U8 *s, const U8 *const target, const U8 *end, STRLEN backw = end - target; if (forw < 2 * backw) { - return S_sv_pos_b2u_forwards(aTHX_ s, target); + return utf8_length(s, target); } while (end > target) { @@ -5916,8 +5827,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send, s + blen, mg->mg_len - cache[0]); } else { - len = cache[0] - + S_sv_pos_b2u_forwards(aTHX_ s + cache[1], send); + len = cache[0] + utf8_length(s + cache[1], send); } } else if (cache[3] < byte) { @@ -5943,7 +5853,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) } } if (!found || PL_utf8cache < 0) { - const STRLEN real_len = S_sv_pos_b2u_forwards(aTHX_ s, send); + const STRLEN real_len = utf8_length(s, send); if (found && PL_utf8cache < 0) { if (len != real_len) { @@ -9039,6 +8949,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV base = 10; goto uns_integer; + case 'B': case 'b': base = 2; goto uns_integer; @@ -9132,7 +9043,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } while (uv >>= 1); if (tempalt) { esignbuf[esignlen++] = '0'; - esignbuf[esignlen++] = 'b'; + esignbuf[esignlen++] = c; } break; default: /* it had better be ten or less */ @@ -9147,7 +9058,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (has_precis) { if (precis > elen) zeros = precis - elen; - else if (precis == 0 && elen == 1 && *eptr == '0') + else if (precis == 0 && elen == 1 && *eptr == '0' + && !(base == 8 && alt)) /* "%#.0o" prints "0" */ elen = 0; /* a precision nullifies the 0 flag. */ @@ -9530,8 +9442,8 @@ ptr_table_* functions. /* Certain cases in Perl_ss_dup have been merged, by relying on the fact - that currently av_dup and hv_dup are the same as sv_dup. If this changes, - please unmerge ss_dup. */ + that currently av_dup, gv_dup and hv_dup are the same as sv_dup. + If this changes, please unmerge ss_dup. */ #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t)) #define av_dup(s,t) (AV*)sv_dup((SV*)s,t) @@ -10098,7 +10010,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) src_ary = AvARRAY((AV*)sstr); Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*); ptr_table_store(PL_ptr_table, src_ary, dst_ary); - SvPV_set(dstr, (char*)dst_ary); + AvARRAY((AV*)dstr) = dst_ary; AvALLOC((AV*)dstr) = dst_ary; if (AvREAL((AV*)sstr)) { while (items-- > 0) @@ -10114,7 +10026,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) } } else { - SvPV_set(dstr, NULL); + AvARRAY((AV*)dstr) = NULL; AvALLOC((AV*)dstr) = (SV**)NULL; } break; @@ -10161,7 +10073,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) } } else - SvPV_set(dstr, NULL); + HvARRAY((HV*)dstr) = NULL; break; case SVt_PVCV: if (!(param->flags & CLONEf_COPY_STACKS)) { @@ -10387,6 +10299,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) long longval; GP *gp; IV iv; + I32 i; char *c = NULL; void (*dptr) (void*); void (*dxptr) (pTHX_ void*); @@ -10394,13 +10307,20 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) Newxz(nss, max, ANY); while (ix > 0) { - I32 i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - switch (i) { + const I32 type = POPINT(ss,ix); + TOPINT(nss,ix) = type; + switch (type) { + case SAVEt_HELEM: /* hash element */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + /* fall through */ case SAVEt_ITEM: /* normal string */ case SAVEt_SV: /* scalar reference */ sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); + /* fall through */ + case SAVEt_FREESV: + case SAVEt_MORTALIZESV: sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; @@ -10421,8 +10341,11 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case SAVEt_AV: /* array reference */ sv = (SV*) POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); - gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup(gv, param); + /* fall through */ + case SAVEt_COMPPAD: + case SAVEt_NSTAB: + sv = (SV*) POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv, param); break; case SAVEt_INT: /* int reference */ ptr = POPPTR(ss,ix); @@ -10433,6 +10356,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case SAVEt_LONG: /* long reference */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + /* fall through */ + case SAVEt_CLEARSV: longval = (long)POPLONG(ss,ix); TOPLONG(nss,ix) = longval; break; @@ -10472,28 +10397,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup(c); break; - case SAVEt_NSTAB: - gv = (GV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup(gv, param); - break; case SAVEt_GP: /* scalar reference */ gp = (GP*)POPPTR(ss,ix); TOPPTR(nss,ix) = gp = gp_dup(gp, param); (void)GpREFCNT_inc(gp); gv = (GV*)POPPTR(ss,ix); TOPPTR(nss,ix) = gv_dup_inc(gv, param); - c = (char*)POPPTR(ss,ix); - TOPPTR(nss,ix) = pv_dup(c); - iv = POPIV(ss,ix); - TOPIV(nss,ix) = iv; - iv = POPIV(ss,ix); - TOPIV(nss,ix) = iv; break; - case SAVEt_FREESV: - case SAVEt_MORTALIZESV: - sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - break; case SAVEt_FREEOP: ptr = POPPTR(ss,ix); if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { @@ -10522,15 +10432,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup_inc(c); break; - case SAVEt_CLEARSV: - longval = POPLONG(ss,ix); - TOPLONG(nss,ix) = longval; - break; case SAVEt_DELETE: hv = (HV*)POPPTR(ss,ix); TOPPTR(nss,ix) = hv_dup_inc(hv, param); c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup_inc(c); + /* fall through */ + case SAVEt_STACK_POS: /* Position on Perl stack */ i = POPINT(ss,ix); TOPINT(nss,ix) = i; break; @@ -10556,10 +10464,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPINT(nss,ix) = i; ix -= i; break; - case SAVEt_STACK_POS: /* Position on Perl stack */ - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - break; case SAVEt_AELEM: /* array element */ sv = (SV*)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); @@ -10568,14 +10472,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) av = (AV*)POPPTR(ss,ix); TOPPTR(nss,ix) = av_dup_inc(av, param); break; - case SAVEt_HELEM: /* hash element */ - sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - hv = (HV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = hv_dup_inc(hv, param); - break; case SAVEt_OP: ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = ptr; @@ -10595,10 +10491,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPPTR(nss,ix) = hv_dup_inc(hv, param); } break; - case SAVEt_COMPPAD: - av = (AV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup(av, param); - break; case SAVEt_PADSV: longval = (long)POPLONG(ss,ix); TOPLONG(nss,ix) = longval; @@ -10688,7 +10580,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); break; default: - Perl_croak(aTHX_ "panic: ss_dup inconsistency (%"IVdf")", (IV) i); + Perl_croak(aTHX_ + "panic: ss_dup inconsistency (%"IVdf")", (IV) type); } } @@ -11073,6 +10966,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_beginav = av_dup_inc(proto_perl->Ibeginav, param); PL_beginav_save = av_dup_inc(proto_perl->Ibeginav_save, param); PL_checkav_save = av_dup_inc(proto_perl->Icheckav_save, param); + PL_unitcheckav = av_dup_inc(proto_perl->Iunitcheckav, param); + PL_unitcheckav_save = av_dup_inc(proto_perl->Iunitcheckav_save, param); PL_endav = av_dup_inc(proto_perl->Iendav, param); PL_checkav = av_dup_inc(proto_perl->Icheckav, param); PL_initav = av_dup_inc(proto_perl->Iinitav, param);