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)");
}
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));
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
#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
#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)
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
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);
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;
}
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 */
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
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);
}
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 */
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
}
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))
#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)
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), \
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)); \
#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| \
projects / p5sagit/p5-mst-13.2.git / commitdiff