diff options
| -rw-r--r-- | dump.c | 14 | ||||
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | proto.h | 3 | ||||
| -rw-r--r-- | sv.c | 123 | ||||
| -rw-r--r-- | sv.h | 17 |
7 files changed, 115 insertions, 46 deletions
@@ -1539,8 +1539,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo Perl_dump_indent(aTHX_ level, file, " UV = %"UVuf, (UV)SvUVX(sv)); else Perl_dump_indent(aTHX_ level, file, " IV = %"IVdf, (IV)SvIVX(sv)); - if (SvOOK(sv)) - PerlIO_printf(file, " (OFFSET)"); #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW_shared_hash(sv)) PerlIO_printf(file, " (HASH)"); @@ -1578,9 +1576,17 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo } if (type <= SVt_PVLV && !isGV_with_GP(sv)) { if (SvPVX_const(sv)) { + UV delta = SvOOK(sv) ? sv_read_offset(sv) : 0; + if (SvOOK(sv)) { + Perl_dump_indent(aTHX_ level, file," OFFSET = %"UVuf"\n", + delta); + } Perl_dump_indent(aTHX_ level, file," PV = 0x%"UVxf" ", PTR2UV(SvPVX_const(sv))); - if (SvOOK(sv)) - PerlIO_printf(file, "( %s . ) ", pv_display(d, SvPVX_const(sv)-SvIVX(sv), SvIVX(sv), 0, pvlim)); + if (SvOOK(sv)) { + PerlIO_printf(file, "( %s . ) ", + pv_display(d, SvPVX_const(sv) - delta, delta, 0, + pvlim)); + } PerlIO_printf(file, "%s", pv_display(d, SvPVX_const(sv), SvCUR(sv), SvLEN(sv), pvlim)); if (SvUTF8(sv)) /* the 6? \x{....} */ PerlIO_printf(file, " [UTF8 \"%s\"]", sv_uni_display(d, sv, 6 * SvCUR(sv), UNI_DISPLAY_QQ)); @@ -881,6 +881,7 @@ Apd |void |sv_pos_b2u |NULLOK SV* sv|NN I32* offsetp Amdb |char* |sv_pvn_force |NN SV* sv|NULLOK STRLEN* lp Apd |char* |sv_pvutf8n_force|NN SV* sv|NULLOK STRLEN* lp Apd |char* |sv_pvbyten_force|NN SV* sv|NULLOK STRLEN* lp +Ap |UV |sv_read_offset |NN const SV *const sv Apd |char* |sv_recode_to_utf8 |NN SV* sv|NN SV *encoding Apd |bool |sv_cat_decode |NN SV* dsv|NN SV *encoding|NN SV *ssv|NN int *offset \ |NN char* tstr|int tlen @@ -899,6 +899,7 @@ #define sv_pos_b2u Perl_sv_pos_b2u #define sv_pvutf8n_force Perl_sv_pvutf8n_force #define sv_pvbyten_force Perl_sv_pvbyten_force +#define sv_read_offset Perl_sv_read_offset #define sv_recode_to_utf8 Perl_sv_recode_to_utf8 #define sv_cat_decode Perl_sv_cat_decode #define sv_reftype Perl_sv_reftype @@ -3190,6 +3191,7 @@ #define sv_pos_b2u(a,b) Perl_sv_pos_b2u(aTHX_ a,b) #define sv_pvutf8n_force(a,b) Perl_sv_pvutf8n_force(aTHX_ a,b) #define sv_pvbyten_force(a,b) Perl_sv_pvbyten_force(aTHX_ a,b) +#define sv_read_offset(a) Perl_sv_read_offset(aTHX_ a) #define sv_recode_to_utf8(a,b) Perl_sv_recode_to_utf8(aTHX_ a,b) #define sv_cat_decode(a,b,c,d,e,f) Perl_sv_cat_decode(aTHX_ a,b,c,d,e,f) #define sv_reftype(a,b) Perl_sv_reftype(aTHX_ a,b) diff --git a/global.sym b/global.sym index 021d86b1ef..e5f9d66c56 100644 --- a/global.sym +++ b/global.sym @@ -539,6 +539,7 @@ Perl_sv_pos_b2u Perl_sv_pvn_force Perl_sv_pvutf8n_force Perl_sv_pvbyten_force +Perl_sv_read_offset Perl_sv_recode_to_utf8 Perl_sv_cat_decode Perl_sv_reftype @@ -2355,6 +2355,9 @@ PERL_CALLCONV char* Perl_sv_pvutf8n_force(pTHX_ SV* sv, STRLEN* lp) PERL_CALLCONV char* Perl_sv_pvbyten_force(pTHX_ SV* sv, STRLEN* lp) __attribute__nonnull__(pTHX_1); +PERL_CALLCONV UV Perl_sv_read_offset(pTHX_ const SV *const sv) + __attribute__nonnull__(pTHX_1); + PERL_CALLCONV char* Perl_sv_recode_to_utf8(pTHX_ SV* sv, SV *encoding) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); @@ -1397,27 +1397,16 @@ wrapper instead. int Perl_sv_backoff(pTHX_ register SV *sv) { + UV delta = sv_read_offset(sv); + const char * const s = SvPVX_const(sv); PERL_UNUSED_CONTEXT; assert(SvOOK(sv)); assert(SvTYPE(sv) != SVt_PVHV); assert(SvTYPE(sv) != SVt_PVAV); - if (SvIVX(sv)) { - const char * const s = SvPVX_const(sv); -#ifdef DEBUGGING - /* Validate the preceding buffer's sentinels to verify that no-one is - using it. */ - const U8 *p = (const U8*) s; - const U8 *const real_start = p - SvIVX(sv); - while (p > real_start) { - --p; - assert (*p == (U8)PTR2UV(p)); - } -#endif - SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); - SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); - SvIV_set(sv, 0); - Move(s, SvPVX(sv), SvCUR(sv)+1, char); - } + + 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; } @@ -3779,7 +3768,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvNV_set(dstr, SvNVX(sstr)); } if (sflags & SVp_IOK) { - SvOOK_off(dstr); SvIV_set(dstr, SvIVX(sstr)); /* Must do this otherwise some other overloaded use of 0x80000000 gets confused. I guess SVpbm_VALID */ @@ -4202,6 +4190,43 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) sv_unglob(sv); } +UV +Perl_sv_read_offset(pTHX_ const SV *const sv) { + U8 *p; + UV delta = 0; + U8 c; + + if (!SvOOK(sv)) + return 0; + p = (U8*)SvPVX_const(sv); + if (!p) + return 0; + + c = *--p; + delta = c & 0x7F; + while ((c & 0x80)) { + UV const last_delta = delta; + delta <<= 7; + if (delta < last_delta) + Perl_croak(aTHX_ "panic: overflow in sv_read_offset from %"UVuf + " to %"UVuf, last_delta, delta); + c = *--p; + delta |= c & 0x7F; + } +#ifdef DEBUGGING + { + /* Validate the preceding buffer's sentinels to verify that no-one is + using it. */ + const U8 *const real_start = (U8 *) SvPVX_const(sv) - delta; + while (p > real_start) { + --p; + assert (*p == (U8)PTR2UV(p)); + } + } +#endif + return delta; +} + /* =for apidoc sv_chop @@ -4219,6 +4244,12 @@ void Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) { register STRLEN delta; + UV old_delta; + U8 *p; +#ifdef DEBUGGING + const U8 *real_start; +#endif + if (!ptr || !SvPOKp(sv)) return; delta = ptr - SvPVX_const(sv); @@ -4228,8 +4259,6 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) } assert(ptr > SvPVX_const(sv)); SV_CHECK_THINKFIRST(sv); - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv,SVt_PVIV); if (!SvOOK(sv)) { if (!SvLEN(sv)) { /* make copy of shared string */ @@ -4239,27 +4268,47 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; } - SvIV_set(sv, 0); - /* Same SvOOK_on but SvOOK_on does a SvIOK_off - and we do that anyway inside the SvNIOK_off - */ SvFLAGS(sv) |= SVf_OOK; + old_delta = 0; + } else { + old_delta = sv_read_offset(sv); } - SvNIOK_off(sv); SvLEN_set(sv, SvLEN(sv) - delta); SvCUR_set(sv, SvCUR(sv) - delta); SvPV_set(sv, SvPVX(sv) + delta); - SvIV_set(sv, SvIVX(sv) + delta); + + p = (U8 *)SvPVX_const(sv); + + delta += old_delta; + #ifdef DEBUGGING - { - /* Fill the preceding buffer with sentinals to verify that no-one is - using it. */ - U8 *p = (U8*) SvPVX(sv); - const U8 *const real_start = p - SvIVX(sv); - while (p > real_start) { - --p; - *p = (U8)PTR2UV(p); - } + real_start = p - delta; +#endif + + if (delta < 0x80) { + *--p = (U8) delta; + } else { + /* Code lovingly ripped from pp_pack.c: */ + U8 buf[(sizeof(UV)*CHAR_BIT)/7+1]; + U8 *in = buf; + STRLEN len; + do { + *in++ = (U8)((delta & 0x7f) | 0x80); + delta >>= 7; + } while (delta); + buf[0] &= 0x7f; /* clear continue bit */ + + len = in - buf; + p -= len; + Copy(buf, p, len, U8); + } + +#ifdef DEBUGGING + /* Fill the preceding buffer with sentinals to verify that no-one is + using it. */ + while (p > real_start) { + --p; + *p = (U8)PTR2UV(p); } #endif } @@ -5278,13 +5327,13 @@ Perl_sv_clear(pTHX_ register SV *sv) case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: + case SVt_PV: freescalar: /* Don't bother with SvOOK_off(sv); as we're only going to free it. */ if (SvOOK(sv)) { - SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv)); + SvPV_set(sv, SvPVX_mutable(sv) - sv_read_offset(sv)); /* Don't even bother with turning off the OOK flag. */ } - case SVt_PV: if (SvROK(sv)) { SV * const target = SvRV(sv); if (SvWEAKREF(sv)) @@ -761,7 +761,7 @@ Set the actual length of the string which is in the SV. See C<SvIV_set>. #define SvOKp(sv) (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) #define SvIOKp(sv) (SvFLAGS(sv) & SVp_IOK) -#define SvIOKp_on(sv) (assert_not_glob(sv) SvRELEASE_IVX(sv), \ +#define SvIOKp_on(sv) (assert_not_glob(sv) SvRELEASE_IVX_(sv) \ SvFLAGS(sv) |= SVp_IOK) #define SvNOKp(sv) (SvFLAGS(sv) & SVp_NOK) #define SvNOKp_on(sv) (assert_not_glob(sv) SvFLAGS(sv) |= SVp_NOK) @@ -770,7 +770,7 @@ Set the actual length of the string which is in the SV. See C<SvIV_set>. SvFLAGS(sv) |= SVp_POK) #define SvIOK(sv) (SvFLAGS(sv) & SVf_IOK) -#define SvIOK_on(sv) (assert_not_glob(sv) SvRELEASE_IVX(sv), \ +#define SvIOK_on(sv) (assert_not_glob(sv) SvRELEASE_IVX_(sv) \ SvFLAGS(sv) |= (SVf_IOK|SVp_IOK)) #define SvIOK_off(sv) (SvFLAGS(sv) &= ~(SVf_IOK|SVp_IOK|SVf_IVisUV)) #define SvIOK_only(sv) (SvOK_off(sv), \ @@ -1240,7 +1240,8 @@ the scalar's value cannot change unless written to. if (SvLEN(sv)) { \ assert(!SvROK(sv)); \ if(SvOOK(sv)) { \ - SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv)); \ + SvPV_set(sv, SvPVX_mutable(sv) \ + - sv_read_offset(sv)); \ SvFLAGS(sv) &= ~SVf_OOK; \ } \ Safefree(SvPVX(sv)); \ @@ -1714,10 +1715,16 @@ Like C<sv_catsv> but doesn't process magic. #ifdef PERL_OLD_COPY_ON_WRITE #define SvRELEASE_IVX(sv) \ - ((SvIsCOW(sv) ? sv_force_normal_flags(sv, 0) : (void) 0), SvOOK_off(sv)) + ((SvIsCOW(sv) ? sv_force_normal_flags(sv, 0) : (void) 0), 0) # define SvIsCOW_normal(sv) (SvIsCOW(sv) && SvLEN(sv)) +# define SvRELEASE_IVX_(sv) SvRELEASE_IVX(sv), #else -# define SvRELEASE_IVX(sv) SvOOK_off(sv) +# define SvRELEASE_IVX(sv) 0 +/* This little game brought to you by the need to shut this warning up: +mg.c: In function `Perl_magic_get': +mg.c:1024: warning: left-hand operand of comma expression has no effect +*/ +# define SvRELEASE_IVX_(sv) /**/ #endif /* PERL_OLD_COPY_ON_WRITE */ #define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \ |