#endif
#ifdef PERL_UTF8_CACHE_ASSERT
-/* The cache element 0 is the Unicode offset;
- * the cache element 1 is the byte offset of the element 0;
- * the cache element 2 is the Unicode length of the substring;
- * the cache element 3 is the byte length of the substring;
- * The checking of the substring side would be good
- * but substr() has enough code paths to make my head spin;
- * if adding more checks watch out for the following tests:
+/* if adding more checks watch out for the following tests:
* t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
* lib/utf8.t lib/Unicode/Collate/t/index.t
* --jhi
*/
#define ASSERT_UTF8_CACHE(cache) \
- STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
+ STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \
+ assert((cache)[2] <= (cache)[3]); \
+ assert((cache)[3] <= (cache)[1]);} \
+ } STMT_END
#else
#define ASSERT_UTF8_CACHE(cache) NOOP
#endif
# define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv)
/* Whilst I'd love to do this, it seems that things like to check on
unreferenced scalars
-# define POSION_SV_HEAD(sv) Poison(sv, 1, struct STRUCT_SV)
+# define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV)
*/
-# define POSION_SV_HEAD(sv) Poison(&SvANY(sv), 1, void *), \
- Poison(&SvREFCNT(sv), 1, U32)
+# define POSION_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \
+ PoisonNew(&SvREFCNT(sv), 1, U32)
#else
# define SvARENA_CHAIN(sv) SvANY(sv)
# define POSION_SV_HEAD(sv)
void ** const r3wt = &PL_body_roots[sv_type]; \
LOCK_SV_MUTEX; \
xpv = *((void **)(r3wt)) \
- ? *((void **)(r3wt)) : S_more_bodies(aTHX_ sv_type); \
+ ? *((void **)(r3wt)) : more_bodies(sv_type); \
*(r3wt) = *(void**)(xpv); \
UNLOCK_SV_MUTEX; \
} STMT_END
int length = old_type_details->copy;
if (new_type_details->offset > old_type_details->offset) {
- int difference
+ const int difference
= new_type_details->offset - old_type_details->offset;
offset += difference;
length -= difference;
can tail call us and return true. */
return (char *) 1;
} else {
- return SvPV(buffer, *len);
+ assert(SvPOK(buffer));
+ if (len) {
+ *len = SvCUR(buffer);
+ }
+ return SvPVX(buffer);
}
}
if (Perl_isnan(SvNVX(sv))) {
SvUV_set(sv, 0);
SvIsUV_on(sv);
+ return FALSE;
}
- else
#endif
if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
SvIV_set(sv, I_V(SvNVX(sv)));
case SVt_PVGV:
if (dtype <= SVt_PVGV) {
- S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
+ glob_assign_glob(dstr, sstr, dtype);
return;
}
/*FALLTHROUGH*/
if ((int)SvTYPE(sstr) != stype) {
stype = SvTYPE(sstr);
if (stype == SVt_PVGV && dtype <= SVt_PVGV) {
- S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
+ glob_assign_glob(dstr, sstr, dtype);
return;
}
}
GvMULTI_on(dstr);
return;
}
- S_glob_assign_glob(aTHX_ dstr, sstr, dtype);
+ glob_assign_glob(dstr, sstr, dtype);
return;
}
if (dtype >= SVt_PV) {
if (dtype == SVt_PVGV) {
- S_glob_assign_ref(aTHX_ dstr, sstr);
+ glob_assign_ref(dstr, sstr);
return;
}
if (SvPVX_const(dstr)) {
/*
=for apidoc sv_usepvn
-Tells an SV to use C<ptr> to find its string value. Normally the string is
-stored inside the SV but sv_usepvn allows the SV to use an outside string.
-The C<ptr> should point to memory that was allocated by C<malloc>. The
-string length, C<len>, must be supplied. This function will realloc the
-memory pointed to by C<ptr>, so that pointer should not be freed or used by
-the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
+Tells an SV to use C<ptr> to find its string value. Normally the
+string is stored inside the SV but sv_usepvn allows the SV to use an
+outside string. The C<ptr> should point to memory that was allocated
+by C<malloc>. The string length, C<len>, must be supplied. This
+function will realloc (i.e. move) the memory pointed to by C<ptr>,
+so that pointer should not be freed or used by the programmer after
+giving it to sv_usepvn, and neither should any pointers from "behind"
+that pointer (e.g. ptr + 1) be used. Does not handle 'set' magic.
See C<sv_usepvn_mg>.
=cut
case PERL_MAGIC_qr:
vtable = &PL_vtbl_regexp;
break;
+ case PERL_MAGIC_hints:
+ /* As this vtable is all NULL, we can reuse it. */
case PERL_MAGIC_sig:
vtable = &PL_vtbl_sig;
break;
case PERL_MAGIC_backref:
vtable = &PL_vtbl_backref;
break;
+ case PERL_MAGIC_hintselem:
+ vtable = &PL_vtbl_hintselem;
+ break;
case PERL_MAGIC_ext:
/* Reserved for use by extensions not perl internals. */
/* Useful for attaching extension internal data to perl vars. */
/*
* The length is cached in PERL_UTF8_magic, in the mg_len field. Also the
- * mg_ptr is used, by sv_pos_u2b(), see the comments of S_utf8_mg_pos_init().
- * (Note that the mg_len is not the length of the mg_ptr field.)
+ * mg_ptr is used, by sv_pos_u2b() and sv_pos_b2u() - see the comments below.
+ * (Note that the mg_len is not the length of the mg_ptr field.
+ * This allows the cache to store the character length of the string without
+ * needing to malloc() extra storage to attach to the mg_ptr.)
*
*/
}
}
-/* S_utf8_mg_pos_init() is used to initialize the mg_ptr field of
- * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
- * between UTF-8 and byte offsets. There are two (substr offset and substr
- * length, the i offset, PERL_MAGIC_UTF8_CACHESIZE) times two (UTF-8 offset
- * and byte offset) cache positions.
- *
- * The mg_len field is used by sv_len_utf8(), see its comments.
- * Note that the mg_len is not the length of the mg_ptr field.
- *
- */
-STATIC bool
-S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i,
- I32 offsetp, const U8 *s, const U8 *start)
-{
- bool found = FALSE;
-
- if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
- if (!*mgp) {
- *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, 0);
- (*mgp)->mg_len = -1;
- }
- assert(*mgp);
-
- if ((*mgp)->mg_ptr)
- *cachep = (STRLEN *) (*mgp)->mg_ptr;
- else {
- Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
- (*mgp)->mg_ptr = (char *) *cachep;
- }
- assert(*cachep);
-
- (*cachep)[i] = offsetp;
- (*cachep)[i+1] = s - start;
- found = TRUE;
- }
-
- return found;
-}
-
-/*
- * S_utf8_mg_pos() is used to query and update mg_ptr field of
- * a PERL_UTF8_magic. The mg_ptr is used to store the mapping
- * between UTF-8 and byte offsets. See also the comments of
- * S_utf8_mg_pos_init().
- *
- */
-STATIC bool
-S_utf8_mg_pos(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, I32 *offsetp, I32 uoff, const U8 **sp, const U8 *start, const U8 *send)
-{
- bool found = FALSE;
-
- if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
- if (!*mgp)
- *mgp = mg_find(sv, PERL_MAGIC_utf8);
- if (*mgp && (*mgp)->mg_ptr) {
- *cachep = (STRLEN *) (*mgp)->mg_ptr;
- ASSERT_UTF8_CACHE(*cachep);
- if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
- found = TRUE;
- else { /* We will skip to the right spot. */
- STRLEN forw = 0;
- STRLEN backw = 0;
- const U8* p = NULL;
-
- /* The assumption is that going backward is half
- * the speed of going forward (that's where the
- * 2 * backw in the below comes from). (The real
- * figure of course depends on the UTF-8 data.) */
-
- if ((*cachep)[i] > (STRLEN)uoff) {
- forw = uoff;
- backw = (*cachep)[i] - (STRLEN)uoff;
-
- if (forw < 2 * backw)
- p = start;
- else
- p = start + (*cachep)[i+1];
- }
- /* Try this only for the substr offset (i == 0),
- * not for the substr length (i == 2). */
- else if (i == 0) { /* (*cachep)[i] < uoff */
- const STRLEN ulen = sv_len_utf8(sv);
-
- if ((STRLEN)uoff < ulen) {
- forw = (STRLEN)uoff - (*cachep)[i];
- backw = ulen - (STRLEN)uoff;
-
- if (forw < 2 * backw)
- p = start + (*cachep)[i+1];
- else
- p = send;
- }
-
- /* If the string is not long enough for uoff,
- * we could extend it, but not at this low a level. */
- }
-
- if (p) {
- if (forw < 2 * backw) {
- while (forw--)
- p += UTF8SKIP(p);
- }
- else {
- while (backw--) {
- p--;
- while (UTF8_IS_CONTINUATION(*p))
- p--;
- }
- }
-
- /* Update the cache. */
- (*cachep)[i] = (STRLEN)uoff;
- (*cachep)[i+1] = p - start;
-
- /* Drop the stale "length" cache */
- if (i == 0) {
- (*cachep)[2] = 0;
- (*cachep)[3] = 0;
- }
-
- found = TRUE;
- }
- }
- if (found) { /* Setup the return values. */
- *offsetp = (*cachep)[i+1];
- *sp = start + *offsetp;
- if (*sp >= send) {
- *sp = send;
- *offsetp = send - start;
- }
- else if (*sp < start) {
- *sp = start;
- *offsetp = 0;
- }
- }
- }
-#ifdef PERL_UTF8_CACHE_ASSERT
- if (found) {
- const U8 *s = start;
- I32 n = uoff;
-
- while (n-- && s < send)
- s += UTF8SKIP(s);
-
- if (i == 0) {
- assert(*offsetp == s - start);
- assert((*cachep)[0] == (STRLEN)uoff);
- assert((*cachep)[1] == *offsetp);
- }
- ASSERT_UTF8_CACHE(*cachep);
- }
-#endif
- }
-
- return found;
-}
-
-/*
-=for apidoc sv_pos_u2b
-
-Converts the value pointed to by offsetp from a count of UTF-8 chars from
-the start of the string, to a count of the equivalent number of bytes; if
-lenp is non-zero, it does the same to lenp, but this time starting from
-the offset, rather than from the start of the string. Handles magic and
-type coercion.
-
-=cut
-*/
-
-/*
- * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
- * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
- * byte offsets. See also the comments of S_utf8_mg_pos().
- *
- */
-
-static void
-S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8);
-
+/* Walk forwards to find the byte corresponding to the passed in UTF-8
+ offset. */
static STRLEN
S_sv_pos_u2b_forwards(pTHX_ const U8 *const start, const U8 *const send,
STRLEN uoffset)
{
const U8 *s = start;
+ PERL_UNUSED_CONTEXT;
+
while (s < send && uoffset--)
s += UTF8SKIP(s);
if (s > send) {
return s - start;
}
-
+/* Given the length of the string in both bytes and UTF-8 characters, decide
+ whether to walk forwards or backwards to find the byte corresponding to
+ the passed in UTF-8 offset. */
static STRLEN
S_sv_pos_u2b_midway(pTHX_ const U8 *const start, const U8 *send,
STRLEN uoffset, STRLEN uend)
{
STRLEN backw = uend - uoffset;
if (uoffset < 2 * backw) {
- /* The assumption is that going fowards is twice the speed of going
+ /* The assumption is that going forwards is twice the speed of going
forward (that's where the 2 * backw comes from).
(The real figure of course depends on the UTF-8 data.) */
return S_sv_pos_u2b_forwards(aTHX_ start, send, uoffset);
return send - start;
}
+/* For the string representation of the given scalar, find the byte
+ corresponding to the passed in UTF-8 offset. uoffset0 and boffset0
+ give another position in the string, *before* the sought offset, which
+ (which is always true, as 0, 0 is a valid pair of positions), which should
+ help reduce the amount of linear searching.
+ If *mgp is non-NULL, it should point to the UTF-8 cache magic, which
+ will be used to reduce the amount of linear searching. The cache will be
+ created if necessary, and the found value offered to it for update. */
static STRLEN
S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start,
const U8 *const send, STRLEN uoffset,
STRLEN uoffset0, STRLEN boffset0) {
- STRLEN boffset;
+ STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */
bool found = FALSE;
assert (uoffset >= uoffset0);
if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
&& (*mgp || (*mgp = mg_find(sv, PERL_MAGIC_utf8)))) {
- if ((*mgp)->mg_len != -1) {
+ if ((*mgp)->mg_ptr) {
+ STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr;
+ if (cache[0] == uoffset) {
+ /* An exact match. */
+ return cache[1];
+ }
+ if (cache[2] == uoffset) {
+ /* An exact match. */
+ return cache[3];
+ }
+
+ if (cache[0] < uoffset) {
+ /* The cache already knows part of the way. */
+ if (cache[0] > uoffset0) {
+ /* The cache knows more than the passed in pair */
+ uoffset0 = cache[0];
+ boffset0 = cache[1];
+ }
+ if ((*mgp)->mg_len != -1) {
+ /* And we know the end too. */
+ boffset = boffset0
+ + S_sv_pos_u2b_midway(aTHX_ start + boffset0, send,
+ uoffset - uoffset0,
+ (*mgp)->mg_len - uoffset0);
+ } else {
+ boffset = boffset0
+ + S_sv_pos_u2b_forwards(aTHX_ start + boffset0,
+ send, uoffset - uoffset0);
+ }
+ }
+ else if (cache[2] < uoffset) {
+ /* We're between the two cache entries. */
+ if (cache[2] > uoffset0) {
+ /* and the cache knows more than the passed in pair */
+ uoffset0 = cache[2];
+ boffset0 = cache[3];
+ }
+
+ boffset = boffset0
+ + S_sv_pos_u2b_midway(aTHX_ start + boffset0,
+ start + cache[1],
+ uoffset - uoffset0,
+ cache[0] - uoffset0);
+ } else {
+ boffset = boffset0
+ + S_sv_pos_u2b_midway(aTHX_ start + boffset0,
+ start + cache[3],
+ uoffset - uoffset0,
+ cache[2] - uoffset0);
+ }
+ found = TRUE;
+ }
+ else if ((*mgp)->mg_len != -1) {
/* If we can take advantage of a passed in offset, do so. */
/* In fact, offset0 is either 0, or less than offset, so don't
need to worry about the other possibility. */
boffset = real_boffset;
}
- S_utf8_mg_pos_cache_update(aTHX_ sv, mgp, boffset, uoffset);
+ S_utf8_mg_pos_cache_update(aTHX_ sv, mgp, boffset, uoffset, send - start);
return boffset;
}
+
+/*
+=for apidoc sv_pos_u2b
+
+Converts the value pointed to by offsetp from a count of UTF-8 chars from
+the start of the string, to a count of the equivalent number of bytes; if
+lenp is non-zero, it does the same to lenp, but this time starting from
+the offset, rather than from the start of the string. Handles magic and
+type coercion.
+
+=cut
+*/
+
+/*
+ * sv_pos_u2b() uses, like sv_pos_b2u(), the mg_ptr of the potential
+ * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
+ * byte offsets. See also the comments of S_utf8_mg_pos_cache_update().
+ *
+ */
+
void
Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
{
return;
}
-/*
-=for apidoc sv_pos_b2u
-
-Converts the value pointed to by offsetp from a count of bytes from the
-start of the string, to a count of the equivalent number of UTF-8 chars.
-Handles magic and type coercion.
-
-=cut
+/* Create and update the UTF8 magic offset cache, with the proffered utf8/
+ byte length pairing. The (byte) length of the total SV is passed in too,
+ as blen, because for some (more esoteric) SVs, the call to SvPV_const()
+ may not have updated SvCUR, so we can't rely on reading it directly.
+
+ The proffered utf8/byte length pairing isn't used if the cache already has
+ two pairs, and swapping either for the proffered pair would increase the
+ RMS of the intervals between known byte offsets.
+
+ The cache itself consists of 4 STRLEN values
+ 0: larger UTF-8 offset
+ 1: corresponding byte offset
+ 2: smaller UTF-8 offset
+ 3: corresponding byte offset
+
+ Unused cache pairs have the value 0, 0.
+ Keeping the cache "backwards" means that the invariant of
+ cache[0] >= cache[2] is maintained even with empty slots, which means that
+ the code that uses it doesn't need to worry if only 1 entry has actually
+ been set to non-zero. It also makes the "position beyond the end of the
+ cache" logic much simpler, as the first slot is always the one to start
+ from.
*/
-
-/*
- * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
- * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
- * byte offsets. See also the comments of S_utf8_mg_pos().
- *
- */
-
-
-static STRLEN
-S_sv_pos_b2u_forwards(pTHX_ const U8 *s, const U8 *const target);
-
static void
-S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8)
+S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8,
+ STRLEN blen)
{
STRLEN *cache;
if (SvREADONLY(sv))
" real %"UVf" for %"SVf, (UV) utf8, (UV) realutf8, sv);
}
}
- cache[0] = utf8;
- cache[1] = byte;
+
+ /* Cache is held with the later position first, to simplify the code
+ that deals with unbounded ends. */
+
+ ASSERT_UTF8_CACHE(cache);
+ if (cache[1] == 0) {
+ /* Cache is totally empty */
+ cache[0] = utf8;
+ cache[1] = byte;
+ } else if (cache[3] == 0) {
+ if (byte > cache[1]) {
+ /* New one is larger, so goes first. */
+ cache[2] = cache[0];
+ cache[3] = cache[1];
+ cache[0] = utf8;
+ cache[1] = byte;
+ } else {
+ cache[2] = utf8;
+ cache[3] = byte;
+ }
+ } else {
+#define THREEWAY_SQUARE(a,b,c,d) \
+ ((float)((d) - (c))) * ((float)((d) - (c))) \
+ + ((float)((c) - (b))) * ((float)((c) - (b))) \
+ + ((float)((b) - (a))) * ((float)((b) - (a)))
+
+ /* Cache has 2 slots in use, and we know three potential pairs.
+ Keep the two that give the lowest RMS distance. Do the
+ calcualation in bytes simply because we always know the byte
+ length. squareroot has the same ordering as the positive value,
+ so don't bother with the actual square root. */
+ const float existing = THREEWAY_SQUARE(0, cache[3], cache[1], blen);
+ if (byte > cache[1]) {
+ /* New position is after the existing pair of pairs. */
+ const float keep_earlier
+ = THREEWAY_SQUARE(0, cache[3], byte, blen);
+ const float keep_later
+ = THREEWAY_SQUARE(0, cache[1], byte, blen);
+
+ if (keep_later < keep_earlier) {
+ if (keep_later < existing) {
+ cache[2] = cache[0];
+ cache[3] = cache[1];
+ cache[0] = utf8;
+ cache[1] = byte;
+ }
+ }
+ else {
+ if (keep_earlier < existing) {
+ cache[0] = utf8;
+ cache[1] = byte;
+ }
+ }
+ }
+ else if (byte > cache[3]) {
+ /* New position is between the existing pair of pairs. */
+ const float keep_earlier
+ = THREEWAY_SQUARE(0, cache[3], byte, blen);
+ const float keep_later
+ = THREEWAY_SQUARE(0, byte, cache[1], blen);
+
+ if (keep_later < keep_earlier) {
+ if (keep_later < existing) {
+ cache[2] = utf8;
+ cache[3] = byte;
+ }
+ }
+ else {
+ if (keep_earlier < existing) {
+ cache[0] = utf8;
+ cache[1] = byte;
+ }
+ }
+ }
+ else {
+ /* New position is before the existing pair of pairs. */
+ const float keep_earlier
+ = THREEWAY_SQUARE(0, byte, cache[3], blen);
+ const float keep_later
+ = THREEWAY_SQUARE(0, byte, cache[1], blen);
+
+ if (keep_later < keep_earlier) {
+ if (keep_later < existing) {
+ cache[2] = utf8;
+ cache[3] = byte;
+ }
+ }
+ else {
+ if (keep_earlier < existing) {
+ cache[0] = cache[2];
+ cache[1] = cache[3];
+ cache[2] = utf8;
+ cache[3] = byte;
+ }
+ }
+ }
+ }
ASSERT_UTF8_CACHE(cache);
- /* Drop the stale "length" cache */
- cache[2] = 0;
- cache[3] = 0;
}
/* If we don't know the character offset of the end of a region, our only
}
/* We already know all of the way, now we may be able to walk back. The same
- assumption is made as in S_utf8_mg_pos(), namely that walking backward is
- twice slower than walking forward. */
+ assumption is made as in S_sv_pos_u2b_midway(), namely that walking
+ backward is half the speed of walking forward. */
static STRLEN
S_sv_pos_b2u_midway(pTHX_ const U8 *s, const U8 *const target, const U8 *end,
STRLEN endu)
return endu;
}
+/*
+=for apidoc sv_pos_b2u
+
+Converts the value pointed to by offsetp from a count of bytes from the
+start of the string, to a count of the equivalent number of UTF-8 chars.
+Handles magic and type coercion.
+
+=cut
+*/
+
+/*
+ * sv_pos_b2u() uses, like sv_pos_u2b(), the mg_ptr of the potential
+ * PERL_UTF8_magic of the sv to store the mapping between UTF-8 and
+ * byte offsets.
+ *
+ */
void
Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
{
const U8* s;
const STRLEN byte = *offsetp;
- STRLEN len;
+ STRLEN len = 0; /* Actually always set, but let's keep gcc happy. */
+ STRLEN blen;
MAGIC* mg = NULL;
const U8* send;
+ bool found = FALSE;
if (!sv)
return;
- s = (const U8*)SvPV_const(sv, len);
+ s = (const U8*)SvPV_const(sv, blen);
- if (len < byte)
+ if (blen < byte)
Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
send = s + byte;
if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache
&& (mg = mg_find(sv, PERL_MAGIC_utf8))) {
if (mg->mg_ptr) {
- STRLEN *cache = (STRLEN *) mg->mg_ptr;
+ STRLEN * const cache = (STRLEN *) mg->mg_ptr;
if (cache[1] == byte) {
/* An exact match. */
*offsetp = cache[0];
-
return;
}
- else if (cache[1] < byte) {
+ if (cache[3] == byte) {
+ /* An exact match. */
+ *offsetp = cache[2];
+ return;
+ }
+
+ if (cache[1] < byte) {
/* We already know part of the way. */
if (mg->mg_len != -1) {
/* Actually, we know the end too. */
len = cache[0]
+ S_sv_pos_b2u_midway(aTHX_ s + cache[1], send,
- s + len, mg->mg_len - cache[0]);
+ s + blen, mg->mg_len - cache[0]);
} else {
len = cache[0]
+ S_sv_pos_b2u_forwards(aTHX_ s + cache[1], send);
}
}
- else { /* cache[1] > byte */
- len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[1],
- cache[0]);
+ else if (cache[3] < byte) {
+ /* We're between the two cached pairs, so we do the calculation
+ offset by the byte/utf-8 positions for the earlier pair,
+ then add the utf-8 characters from the string start to
+ there. */
+ len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send,
+ s + cache[1], cache[0] - cache[2])
+ + cache[2];
}
- ASSERT_UTF8_CACHE(cache);
- if (PL_utf8cache < 0) {
- const STRLEN reallen = S_sv_pos_b2u_forwards(aTHX_ s, send);
-
- if (len != reallen) {
- /* Need to turn the assertions off otherwise we may recurse
- infinitely while printing error messages. */
- SAVEI8(PL_utf8cache);
- PL_utf8cache = 0;
- Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVf
- " real %"UVf" for %"SVf,
- (UV) len, (UV) reallen, sv);
- }
+ else { /* cache[3] > byte */
+ len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3],
+ cache[2]);
+
}
+ ASSERT_UTF8_CACHE(cache);
+ found = TRUE;
} else if (mg->mg_len != -1) {
- len = S_sv_pos_b2u_midway(aTHX_ s, send, s + len, mg->mg_len);
- } else {
- len = S_sv_pos_b2u_forwards(aTHX_ s, send);
+ len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len);
+ found = TRUE;
}
}
- else {
- len = S_sv_pos_b2u_forwards(aTHX_ s, send);
+ if (!found || PL_utf8cache < 0) {
+ const STRLEN real_len = S_sv_pos_b2u_forwards(aTHX_ s, send);
+
+ if (found && PL_utf8cache < 0) {
+ if (len != real_len) {
+ /* Need to turn the assertions off otherwise we may recurse
+ infinitely while printing error messages. */
+ SAVEI8(PL_utf8cache);
+ PL_utf8cache = 0;
+ Perl_croak(aTHX_ "panic: sv_pos_b2u cache %"UVf
+ " real %"UVf" for %"SVf,
+ (UV) len, (UV) real_len, sv);
+ }
+ }
+ len = real_len;
}
*offsetp = len;
- S_utf8_mg_pos_cache_update(aTHX_ sv, &mg, byte, len);
+ S_utf8_mg_pos_cache_update(aTHX_ sv, &mg, byte, len, blen);
}
/*
register I32 cnt;
I32 i = 0;
I32 rspara = 0;
- I32 recsize;
if (SvTHINKFIRST(sv))
sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
}
else if (RsSNARF(PL_rs)) {
/* If it is a regular disk file use size from stat() as estimate
- of amount we are going to read - may result in malloc-ing
- more memory than we realy need if layers bellow reduce
- size we read (e.g. CRLF or a gzip layer)
+ of amount we are going to read -- may result in mallocing
+ more memory than we really need if the layers below reduce
+ the size we read (e.g. CRLF or a gzip layer).
*/
Stat_t st;
if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
else if (RsRECORD(PL_rs)) {
I32 bytesread;
char *buffer;
+ U32 recsize;
/* Grab the size of the record we're getting */
- recsize = SvIV(SvRV(PL_rs));
+ recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */
buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
/* Go yank in */
#ifdef VMS
return sv;
}
/* This will be overwhelminly the most common case. */
- return newSVpvn_share(HEK_KEY(hek),
- (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
- HEK_HASH(hek));
+ {
+ /* Inline most of newSVpvn_share(), because share_hek_hek() is far
+ more efficient than sharepvn(). */
+ SV *sv;
+
+ new_SV(sv);
+ sv_upgrade(sv, SVt_PV);
+ SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek)));
+ SvCUR_set(sv, HEK_LEN(hek));
+ SvLEN_set(sv, 0);
+ SvREADONLY_on(sv);
+ SvFAKE_on(sv);
+ SvPOK_on(sv);
+ if (HEK_UTF8(hek))
+ SvUTF8_on(sv);
+ return sv;
+ }
}
}
dVAR;
register SV *sv;
bool is_utf8 = FALSE;
+ const char *const orig_src = src;
+
if (len < 0) {
STRLEN tmplen = -len;
is_utf8 = TRUE;
SvPOK_on(sv);
if (is_utf8)
SvUTF8_on(sv);
+ if (src != orig_src)
+ Safefree(src);
return sv;
}
sv_clear(rv);
SvFLAGS(rv) = 0;
SvREFCNT(rv) = refcnt;
- }
- if (SvTYPE(rv) < SVt_RV)
+ sv_upgrade(rv, SVt_RV);
+ } else if (SvROK(rv)) {
+ SvREFCNT_dec(SvRV(rv));
+ } else if (SvTYPE(rv) < SVt_RV)
sv_upgrade(rv, SVt_RV);
else if (SvTYPE(rv) > SVt_RV) {
SvPV_free(rv);
#if defined(USE_ITHREADS)
+/* XXX Remove this so it doesn't have to go thru the macro and return for nothing */
#ifndef GpREFCNT_inc
# define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
#endif
+/* 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. */
#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)
if (tblent->oldval == sv)
return tblent;
}
- return 0;
+ return NULL;
}
void *
{
PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv);
PERL_UNUSED_CONTEXT;
- return tblent ? tblent->newval : (void *) 0;
+ return tblent ? tblent->newval : NULL;
}
/* add a new entry to a pointer-mapping table */
TOPINT(nss,ix) = i;
switch (i) {
case SAVEt_ITEM: /* normal string */
+ case SAVEt_SV: /* scalar reference */
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);
break;
- case SAVEt_SV: /* scalar reference */
- sv = (SV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = sv_dup_inc(sv, param);
- gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup_inc(gv, param);
- break;
- case SAVEt_GENERIC_PVREF: /* generic char* */
- c = (char*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = pv_dup(c);
- ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- break;
case SAVEt_SHARED_PVREF: /* char* in shared space */
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = savesharedpv(c);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
break;
- case SAVEt_AV: /* array reference */
- av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup_inc(av, param);
- gv = (GV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = gv_dup(gv, param);
- break;
case SAVEt_HV: /* hash reference */
- hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup_inc(hv, param);
+ case SAVEt_AV: /* array reference */
+ sv = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup_inc(sv, param);
gv = (GV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gv_dup(gv, param);
break;
case SAVEt_I32: /* I32 reference */
case SAVEt_I16: /* I16 reference */
case SAVEt_I8: /* I8 reference */
+ case SAVEt_COP_ARYBASE: /* call CopARYBASE_set */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
i = POPINT(ss,ix);
iv = POPIV(ss,ix);
TOPIV(nss,ix) = iv;
break;
+ case SAVEt_HPTR: /* HV* reference */
+ case SAVEt_APTR: /* AV* reference */
case SAVEt_SPTR: /* SV* reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
break;
+ case SAVEt_GENERIC_PVREF: /* generic char* */
case SAVEt_PPTR: /* char* reference */
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
c = (char*)POPPTR(ss,ix);
TOPPTR(nss,ix) = pv_dup(c);
break;
- case SAVEt_HPTR: /* HV* reference */
- ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- hv = (HV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = hv_dup(hv, param);
- break;
- case SAVEt_APTR: /* AV* reference */
- ptr = POPPTR(ss,ix);
- TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
- av = (AV*)POPPTR(ss,ix);
- TOPPTR(nss,ix) = av_dup(av, param);
- break;
case SAVEt_NSTAB:
gv = (GV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = gv_dup(gv, param);
case SAVEt_HINTS:
i = POPINT(ss,ix);
TOPINT(nss,ix) = i;
+ ptr = POPPTR(ss,ix);
+ if (ptr) {
+ HINTS_REFCNT_LOCK;
+ ((struct refcounted_he *)ptr)->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
+ }
+ TOPPTR(nss,ix) = ptr;
+ if (i & HINT_LOCALIZE_HH) {
+ hv = (HV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = hv_dup_inc(hv, param);
+ }
break;
case SAVEt_COMPPAD:
av = (AV*)POPPTR(ss,ix);
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
+ case SAVEt_RE_STATE:
+ {
+ const struct re_save_state *const old_state
+ = (struct re_save_state *)
+ (ss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
+ struct re_save_state *const new_state
+ = (struct re_save_state *)
+ (nss + ix - SAVESTACK_ALLOC_FOR_RE_SAVE_STATE);
+
+ Copy(old_state, new_state, 1, struct re_save_state);
+ ix -= SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
+
+ new_state->re_state_bostr
+ = pv_dup(old_state->re_state_bostr);
+ new_state->re_state_reginput
+ = pv_dup(old_state->re_state_reginput);
+ new_state->re_state_regeol
+ = pv_dup(old_state->re_state_regeol);
+ new_state->re_state_regstartp
+ = any_dup(old_state->re_state_regstartp, proto_perl);
+ new_state->re_state_regendp
+ = any_dup(old_state->re_state_regendp, proto_perl);
+ new_state->re_state_reglastparen
+ = any_dup(old_state->re_state_reglastparen, proto_perl);
+ new_state->re_state_reglastcloseparen
+ = any_dup(old_state->re_state_reglastcloseparen,
+ proto_perl);
+ /* XXX This just has to be broken. The old save_re_context
+ code did SAVEGENERICPV(PL_reg_start_tmp);
+ PL_reg_start_tmp is char **.
+ Look above to what the dup code does for
+ SAVEt_GENERIC_PVREF
+ It can never have worked.
+ So this is merely a faithful copy of the exiting bug: */
+ new_state->re_state_reg_start_tmp
+ = (char **) pv_dup((char *)
+ old_state->re_state_reg_start_tmp);
+ /* I assume that it only ever "worked" because no-one called
+ (pseudo)fork while the regexp engine had re-entered itself.
+ */
+#ifdef PERL_OLD_COPY_ON_WRITE
+ new_state->re_state_nrs
+ = sv_dup(old_state->re_state_nrs, param);
+#endif
+ new_state->re_state_reg_magic
+ = any_dup(old_state->re_state_reg_magic, proto_perl);
+ new_state->re_state_reg_oldcurpm
+ = any_dup(old_state->re_state_reg_oldcurpm, proto_perl);
+ new_state->re_state_reg_curpm
+ = any_dup(old_state->re_state_reg_curpm, proto_perl);
+ new_state->re_state_reg_oldsaved
+ = pv_dup(old_state->re_state_reg_oldsaved);
+ new_state->re_state_reg_poscache
+ = pv_dup(old_state->re_state_reg_poscache);
+#ifdef DEBUGGING
+ new_state->re_state_reg_starttry
+ = pv_dup(old_state->re_state_reg_starttry);
+#endif
+ break;
+ }
+ case SAVEt_COP_WARNINGS:
+ {
+ void *optr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = ptr = any_dup(optr, proto_perl);
+ if (ptr != optr) {
+ /* We duped something in the interpreter structure. */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr);
+ } else {
+ /* I don't think that this happens, but it would mean that
+ we (didn't) dup something shared. */
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = ptr;
+ }
+ }
+ break;
default:
- Perl_croak(aTHX_ "panic: ss_dup inconsistency");
+ Perl_croak(aTHX_ "panic: ss_dup inconsistency (%"IVdf")", (IV) i);
}
}
PERL_SET_THX(my_perl);
# ifdef DEBUGGING
- Poison(my_perl, 1, PerlInterpreter);
+ PoisonNew(my_perl, 1, PerlInterpreter);
PL_op = NULL;
PL_curcop = NULL;
PL_markstack = 0;
PERL_SET_THX(my_perl);
# ifdef DEBUGGING
- Poison(my_perl, 1, PerlInterpreter);
+ PoisonNew(my_perl, 1, PerlInterpreter);
PL_op = NULL;
PL_curcop = NULL;
PL_markstack = 0;
ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
- if (!specialWARN(PL_compiling.cop_warnings))
- PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
+ PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
if (!specialCopIO(PL_compiling.cop_io))
PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io, param);
+ if (PL_compiling.cop_hints) {
+ HINTS_REFCNT_LOCK;
+ PL_compiling.cop_hints->refcounted_he_refcnt++;
+ HINTS_REFCNT_UNLOCK;
+ }
PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
/* pseudo environmental stuff */
PL_formfeed = sv_dup(proto_perl->Iformfeed, param);
PL_maxsysfd = proto_perl->Imaxsysfd;
- PL_multiline = proto_perl->Imultiline;
PL_statusvalue = proto_perl->Istatusvalue;
#ifdef VMS
PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
PL_watchok = NULL;
PL_regdummy = proto_perl->Tregdummy;
- PL_regprecomp = NULL;
- PL_regnpar = 0;
- PL_regsize = 0;
PL_colorset = 0; /* reinits PL_colors[] */
/*PL_colors[6] = {0,0,0,0,0,0};*/
- PL_reginput = NULL;
- PL_regbol = NULL;
- PL_regeol = NULL;
- PL_regstartp = (I32*)NULL;
- PL_regendp = (I32*)NULL;
- PL_reglastparen = (U32*)NULL;
- PL_reglastcloseparen = (U32*)NULL;
- PL_regtill = NULL;
- PL_reg_start_tmp = (char**)NULL;
- PL_reg_start_tmpl = 0;
- PL_regdata = (struct reg_data*)NULL;
- PL_bostr = NULL;
- PL_reg_flags = 0;
- PL_reg_eval_set = 0;
- PL_regnarrate = 0;
- PL_regprogram = (regnode*)NULL;
- PL_regindent = 0;
- PL_regcc = (CURCUR*)NULL;
- PL_reg_call_cc = (struct re_cc_state*)NULL;
- PL_reg_re = (regexp*)NULL;
- PL_reg_ganch = NULL;
- PL_reg_sv = NULL;
- PL_reg_match_utf8 = FALSE;
- PL_reg_magic = (MAGIC*)NULL;
- PL_reg_oldpos = 0;
- PL_reg_oldcurpm = (PMOP*)NULL;
- PL_reg_curpm = (PMOP*)NULL;
- PL_reg_oldsaved = NULL;
- PL_reg_oldsavedlen = 0;
-#ifdef PERL_OLD_COPY_ON_WRITE
- PL_nrs = NULL;
-#endif
- PL_reg_maxiter = 0;
- PL_reg_leftiter = 0;
- PL_reg_poscache = NULL;
- PL_reg_poscache_size= 0;
/* RE engine - function pointers */
PL_regcompp = proto_perl->Tregcompp;
PL_regint_start = proto_perl->Tregint_start;
PL_regint_string = proto_perl->Tregint_string;
PL_regfree = proto_perl->Tregfree;
-
+ Zero(&PL_reg_state, 1, struct re_save_state);
PL_reginterp_cnt = 0;
- PL_reg_starttry = 0;
+ PL_regmatch_slab = NULL;
/* Pluggable optimizer */
PL_peepp = proto_perl->Tpeepp;
/* attempt to find a match within the aggregate */
if (hash) {
- keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
+ keysv = find_hash_subscript((HV*)sv, uninit_sv);
if (keysv)
subscript_type = FUV_SUBSCRIPT_HASH;
}
/* index is an expression;
* attempt to find a match within the aggregate */
if (obase->op_type == OP_HELEM) {
- SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv);
+ SV * const keysv = find_hash_subscript((HV*)sv, uninit_sv);
if (keysv)
return varname(gv, '%', o->op_targ,
keysv, 0, FUV_SUBSCRIPT_HASH);
}
else {
- const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv);
+ const I32 index = find_array_subscript((AV*)sv, uninit_sv);
if (index >= 0)
return varname(gv, '@', o->op_targ,
NULL, index, FUV_SUBSCRIPT_ARRAY);
projects / p5sagit/p5-mst-13.2.git / blobdiff