/* sv.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (c) 1991-2003, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#ifdef PERL_COPY_ON_WRITE
#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
#define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
-/* This is a pessamistic view. Scalar must be purely a read-write PV to copy-
+/* This is a pessimistic view. Scalar must be purely a read-write PV to copy-
on-write. */
-#define CAN_COW_MASK (SVs_OBJECT|SVs_GMG|SVs_SMG|SVs_RMG|SVf_IOK|SVf_NOK| \
- SVf_POK|SVf_ROK|SVp_IOK|SVp_NOK|SVp_POK|SVf_FAKE| \
- SVf_OOK|SVf_BREAK|SVf_READONLY|SVf_AMAGIC)
-#define CAN_COW_FLAGS (SVp_POK|SVf_POK)
#endif
/* ============================================================================
/* new_SV(): return a new, empty SV head */
-#define new_SV(p) \
+#ifdef DEBUG_LEAKING_SCALARS
+/* provide a real function for a debugger to play with */
+STATIC SV*
+S_new_SV(pTHX)
+{
+ SV* sv;
+
+ LOCK_SV_MUTEX;
+ if (PL_sv_root)
+ uproot_SV(sv);
+ else
+ sv = more_sv();
+ UNLOCK_SV_MUTEX;
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+ return sv;
+}
+# define new_SV(p) (p)=S_new_SV(aTHX)
+
+#else
+# define new_SV(p) \
STMT_START { \
LOCK_SV_MUTEX; \
if (PL_sv_root) \
SvREFCNT(p) = 1; \
SvFLAGS(p) = 0; \
} STMT_END
+#endif
/* del_SV(): return an empty SV head to the free list */
{
register char *s;
-
-
#ifdef HAS_64K_LIMIT
if (newlen >= 0x10000) {
PerlIO_printf(Perl_debug_log,
this NV is in the preserved range, therefore: */
if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
< (UV)IV_MAX)) {
- Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+ Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
}
} else {
/* IN_UV NOT_INT
this NV is in the preserved range, therefore: */
if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
< (UV)IV_MAX)) {
- Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+ Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
}
} else
sv_2iuv_non_preserve (sv, numtype);
case SVt_PVMG:
if ( ((SvFLAGS(sv) &
(SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
- == (SVs_OBJECT|SVs_RMG))
+ == (SVs_OBJECT|SVs_SMG))
&& (mg = mg_find(sv, PERL_MAGIC_qr))) {
regexp *re = (regexp *)mg->mg_obj;
sv_force_normal_flags(sv, 0);
}
- if (PL_encoding)
+ if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING))
sv_recode_to_utf8(sv, PL_encoding);
else { /* Assume Latin-1/EBCDIC */
/* This function could be much more efficient if we
switch (SvTYPE(sref)) {
case SVt_PVAV:
if (intro)
- SAVESPTR(GvAV(dstr));
+ SAVEGENERICSV(GvAV(dstr));
else
dref = (SV*)GvAV(dstr);
GvAV(dstr) = (AV*)sref;
break;
case SVt_PVHV:
if (intro)
- SAVESPTR(GvHV(dstr));
+ SAVEGENERICSV(GvHV(dstr));
else
dref = (SV*)GvHV(dstr);
GvHV(dstr) = (HV*)sref;
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
PL_sub_generation++;
}
- SAVESPTR(GvCV(dstr));
+ SAVEGENERICSV(GvCV(dstr));
}
else
dref = (SV*)GvCV(dstr);
break;
case SVt_PVIO:
if (intro)
- SAVESPTR(GvIOp(dstr));
+ SAVEGENERICSV(GvIOp(dstr));
else
dref = (SV*)GvIOp(dstr);
GvIOp(dstr) = (IO*)sref;
break;
case SVt_PVFM:
if (intro)
- SAVESPTR(GvFORM(dstr));
+ SAVEGENERICSV(GvFORM(dstr));
else
dref = (SV*)GvFORM(dstr);
GvFORM(dstr) = (CV*)sref;
break;
default:
if (intro)
- SAVESPTR(GvSV(dstr));
+ SAVEGENERICSV(GvSV(dstr));
else
dref = (SV*)GvSV(dstr);
GvSV(dstr) = sref;
}
if (dref)
SvREFCNT_dec(dref);
- if (intro)
- SAVEFREESV(sref);
if (SvTAINTED(sstr))
SvTAINT(dstr);
return;
/* Either it's a shared hash key, or it's suitable for
copy-on-write or we can swipe the string. */
if (DEBUG_C_TEST) {
- PerlIO_printf(Perl_debug_log,
- "Copy on write: sstr --> dstr\n");
+ PerlIO_printf(Perl_debug_log, "Copy on write: sstr --> dstr\n");
sv_dump(sstr);
sv_dump(dstr);
}
SvSETMAGIC(dstr);
}
+#ifdef PERL_COPY_ON_WRITE
+SV *
+Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr)
+{
+ STRLEN cur = SvCUR(sstr);
+ STRLEN len = SvLEN(sstr);
+ register char *new_pv;
+
+ if (DEBUG_C_TEST) {
+ PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n",
+ sstr, dstr);
+ sv_dump(sstr);
+ if (dstr)
+ sv_dump(dstr);
+ }
+
+ if (dstr) {
+ if (SvTHINKFIRST(dstr))
+ sv_force_normal_flags(dstr, SV_COW_DROP_PV);
+ else if (SvPVX(dstr))
+ Safefree(SvPVX(dstr));
+ }
+ else
+ new_SV(dstr);
+ SvUPGRADE (dstr, SVt_PVIV);
+
+ assert (SvPOK(sstr));
+ assert (SvPOKp(sstr));
+ assert (!SvIOK(sstr));
+ assert (!SvIOKp(sstr));
+ assert (!SvNOK(sstr));
+ assert (!SvNOKp(sstr));
+
+ if (SvIsCOW(sstr)) {
+
+ if (SvLEN(sstr) == 0) {
+ /* source is a COW shared hash key. */
+ UV hash = SvUVX(sstr);
+ DEBUG_C(PerlIO_printf(Perl_debug_log,
+ "Fast copy on write: Sharing hash\n"));
+ SvUVX(dstr) = hash;
+ new_pv = sharepvn(SvPVX(sstr), (SvUTF8(sstr)?-cur:cur), hash);
+ goto common_exit;
+ }
+ SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
+ } else {
+ assert ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS);
+ SvUPGRADE (sstr, SVt_PVIV);
+ SvREADONLY_on(sstr);
+ SvFAKE_on(sstr);
+ DEBUG_C(PerlIO_printf(Perl_debug_log,
+ "Fast copy on write: Converting sstr to COW\n"));
+ SV_COW_NEXT_SV_SET(dstr, sstr);
+ }
+ SV_COW_NEXT_SV_SET(sstr, dstr);
+ new_pv = SvPVX(sstr);
+
+ common_exit:
+ SvPV_set(dstr, new_pv);
+ SvFLAGS(dstr) = (SVt_PVIV|SVf_POK|SVp_POK|SVf_FAKE|SVf_READONLY);
+ if (SvUTF8(sstr))
+ SvUTF8_on(dstr);
+ SvLEN(dstr) = len;
+ SvCUR(dstr) = cur;
+ if (DEBUG_C_TEST) {
+ sv_dump(dstr);
+ }
+ return dstr;
+}
+#endif
+
/*
=for apidoc sv_setpvn
we do the copy, and is also used locally. If C<SV_COW_DROP_PV> is set
then a copy-on-write scalar drops its PV buffer (if any) and becomes
SvPOK_off rather than making a copy. (Used where this scalar is about to be
-set to some other value. In addtion, the C<flags> parameter gets passed to
+set to some other value.) In addition, the C<flags> parameter gets passed to
C<sv_unref_flags()> when unrefing. C<sv_force_normal> calls this function
with flags set to 0.
*SvEND(sv) = '\0';
}
SvIVX(sv) = 0;
- SvFLAGS(sv) |= SVf_OOK;
+ /* Same SvOOK_on but SvOOK_on does a SvIOK_off
+ and we do that anyway inside the SvNIOK_off
+ */
+ SvFLAGS(sv) |= SVf_OOK;
}
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
+ SvNIOK_off(sv);
delta = ptr - SvPVX(sv);
SvLEN(sv) -= delta;
SvCUR(sv) -= delta;
avoid incrementing the object refcount.
Note we cannot do this to avoid self-tie loops as intervening RV must
- have its REFCNT incremented to keep it in existence - instead we could
- special case them in sv_free() -- NI-S
+ have its REFCNT incremented to keep it in existence.
*/
if (!obj || obj == sv ||
mg->mg_obj = SvREFCNT_inc(obj);
mg->mg_flags |= MGf_REFCOUNTED;
}
+
+ /* Normal self-ties simply pass a null object, and instead of
+ using mg_obj directly, use the SvTIED_obj macro to produce a
+ new RV as needed. For glob "self-ties", we are tieing the PVIO
+ with an RV obj pointing to the glob containing the PVIO. In
+ this case, to avoid a reference loop, we need to weaken the
+ reference.
+ */
+
+ if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO &&
+ obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv)
+ {
+ sv_rvweaken(obj);
+ }
+
mg->mg_type = how;
mg->mg_len = namlen;
if (name) {
case PERL_MAGIC_vstring:
vtable = 0;
break;
+ case PERL_MAGIC_utf8:
+ vtable = &PL_vtbl_utf8;
+ break;
case PERL_MAGIC_substr:
vtable = &PL_vtbl_substr;
break;
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec((SV*)mg->mg_ptr);
+ else if (mg->mg_type == PERL_MAGIC_utf8 && mg->mg_ptr)
+ Safefree(mg->mg_ptr);
}
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
SvREFCNT_dec(av); /* for sv_magic */
}
- av_push(av,sv);
+ if (AvFILLp(av) >= AvMAX(av)) {
+ SV **svp = AvARRAY(av);
+ I32 i = AvFILLp(av);
+ while (i >= 0) {
+ if (svp[i] == &PL_sv_undef) {
+ svp[i] = sv; /* reuse the slot */
+ return;
+ }
+ i--;
+ }
+ av_extend(av, AvFILLp(av)+1);
+ }
+ AvARRAY(av)[++AvFILLp(av)] = sv; /* av_push() */
}
/* delete a back-reference to ourselves from the backref magic associated
PUSHMARK(SP);
PUSHs(&tmpref);
PUTBACK;
- call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
+ call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
SvREFCNT(sv)--;
POPSTACK;
SPAGAIN;
Perl_sv_newref(pTHX_ SV *sv)
{
if (sv)
- ATOMIC_INC(SvREFCNT(sv));
+ (SvREFCNT(sv))++;
return sv;
}
void
Perl_sv_free(pTHX_ SV *sv)
{
- int refcount_is_zero;
-
if (!sv)
return;
if (SvREFCNT(sv) == 0) {
Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
return;
}
- ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
- if (!refcount_is_zero)
+ if (--(SvREFCNT(sv)) > 0)
return;
+ Perl_sv_free2(aTHX_ sv);
+}
+
+void
+Perl_sv_free2(pTHX_ SV *sv)
+{
#ifdef DEBUGGING
if (SvTEMP(sv)) {
if (ckWARN_d(WARN_DEBUGGING))
=cut
*/
+/*
+ * 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.)
+ *
+ */
+
STRLEN
Perl_sv_len_utf8(pTHX_ register SV *sv)
{
return mg_length(sv);
else
{
- STRLEN len;
+ STRLEN len, ulen;
U8 *s = (U8*)SvPV(sv, len);
+ MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
- return Perl_utf8_length(aTHX_ s, s + len);
+ if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0))
+ ulen = mg->mg_len;
+ else {
+ ulen = Perl_utf8_length(aTHX_ s, s + len);
+ if (!mg && !SvREADONLY(sv)) {
+ sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
+ mg = mg_find(sv, PERL_MAGIC_utf8);
+ assert(mg);
+ }
+ if (mg)
+ mg->mg_len = ulen;
+ }
+ return ulen;
}
}
+/* 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, U8 *s, U8 *start)
+{
+ bool found = FALSE;
+
+ if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
+ if (!*mgp) {
+ sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
+ *mgp = mg_find(sv, PERL_MAGIC_utf8);
+ }
+ assert(*mgp);
+
+ if ((*mgp)->mg_ptr)
+ *cachep = (STRLEN *) (*mgp)->mg_ptr;
+ else {
+ Newz(0, *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, U8 **sp, U8 *start, 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;
+ if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
+ found = TRUE;
+ else { /* We will skip to the right spot. */
+ STRLEN forw = 0;
+ STRLEN backw = 0;
+ 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 */
+ 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;
+
+ 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;
+ }
+ }
+ }
+ }
+ return found;
+}
+
/*
=for apidoc sv_pos_u2b
=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().
+ *
+ */
+
void
Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
{
U8 *start;
U8 *s;
- U8 *send;
- I32 uoffset = *offsetp;
STRLEN len;
+ STRLEN *cache = 0;
+ STRLEN boffset = 0;
if (!sv)
return;
start = s = (U8*)SvPV(sv, len);
- send = s + len;
- while (s < send && uoffset--)
- s += UTF8SKIP(s);
- if (s >= send)
- s = send;
- *offsetp = s - start;
- if (lenp) {
- I32 ulen = *lenp;
- start = s;
- while (s < send && ulen--)
- s += UTF8SKIP(s);
- if (s >= send)
- s = send;
- *lenp = s - start;
+ if (len) {
+ I32 uoffset = *offsetp;
+ U8 *send = s + len;
+ MAGIC *mg = 0;
+ bool found = FALSE;
+
+ if (utf8_mg_pos(sv, &mg, &cache, 0, offsetp, *offsetp, &s, start, send))
+ found = TRUE;
+ if (!found && uoffset > 0) {
+ while (s < send && uoffset--)
+ s += UTF8SKIP(s);
+ if (s >= send)
+ s = send;
+ if (utf8_mg_pos_init(sv, &mg, &cache, 0, offsetp, s, start))
+ boffset = cache[1];
+ *offsetp = s - start;
+ }
+ if (lenp) {
+ found = FALSE;
+ start = s;
+ if (utf8_mg_pos(sv, &mg, &cache, 2, lenp, *lenp + *offsetp, &s, start, send)) {
+ *lenp -= boffset;
+ found = TRUE;
+ }
+ if (!found && *lenp > 0) {
+ I32 ulen = *lenp;
+ if (ulen > 0)
+ while (s < send && ulen--)
+ s += UTF8SKIP(s);
+ if (s >= send)
+ s = send;
+ if (utf8_mg_pos_init(sv, &mg, &cache, 2, lenp, s, start))
+ cache[2] += *offsetp;
+ }
+ *lenp = s - start;
+ }
+ }
+ else {
+ *offsetp = 0;
+ if (lenp)
+ *lenp = 0;
}
return;
}
=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. See also the comments of S_utf8_mg_pos().
+ *
+ */
+
void
-Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
+Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp)
{
- U8 *s;
- U8 *send;
+ U8* s;
STRLEN len;
if (!sv)
s = (U8*)SvPV(sv, len);
if ((I32)len < *offsetp)
Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
- send = s + *offsetp;
- len = 0;
- while (s < send) {
- 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 {
+ U8* send = s + *offsetp;
+ MAGIC* mg = NULL;
+ STRLEN *cache = NULL;
+
+ len = 0;
+
+ if (SvMAGICAL(sv) && !SvREADONLY(sv)) {
+ mg = mg_find(sv, PERL_MAGIC_utf8);
+ if (mg && mg->mg_ptr) {
+ cache = (STRLEN *) mg->mg_ptr;
+ if (cache[1] == *offsetp) {
+ /* An exact match. */
+ *offsetp = cache[0];
+
+ return;
+ }
+ else if (cache[1] < *offsetp) {
+ /* We already know part of the way. */
+ len = cache[0];
+ s += cache[1];
+ /* Let the below loop do the rest. */
+ }
+ else { /* cache[1] > *offsetp */
+ /* 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. */
+ STRLEN forw = *offsetp;
+ STRLEN backw = cache[1] - *offsetp;
+
+ if (!(forw < 2 * backw)) {
+ U8 *p = s + cache[1];
+ STRLEN ubackw = 0;
+
+ cache[1] -= backw;
+
+ while (backw--) {
+ p--;
+ while (UTF8_IS_CONTINUATION(*p))
+ p--;
+ ubackw++;
+ }
+
+ cache[0] -= ubackw;
+
+ return;
+ }
+ }
+ }
}
- else
- break;
+
+ while (s < send) {
+ 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;
+ }
+
+ if (!SvREADONLY(sv)) {
+ if (!mg) {
+ sv_magic(sv, 0, PERL_MAGIC_utf8, 0, 0);
+ mg = mg_find(sv, PERL_MAGIC_utf8);
+ }
+ assert(mg);
+
+ if (!mg->mg_ptr) {
+ Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN);
+ mg->mg_ptr = (char *) cache;
+ }
+ assert(cache);
+
+ cache[0] = len;
+ cache[1] = *offsetp;
+ }
+
+ *offsetp = len;
}
- *offsetp = len;
return;
}
register I32 cnt;
I32 i = 0;
I32 rspara = 0;
+ I32 recsize;
SV_CHECK_THINKFIRST_COW_DROP(sv);
/* XXX. If you make this PVIV, then copy on write can copy scalars read
(void)SvUPGRADE(sv, SVt_PV);
SvSCREAM_off(sv);
+ SvPOK_only(sv); /* Validate pointer */
if (PL_curcop == &PL_compiling) {
/* we always read code in line mode */
rslen = 1;
}
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)
+ */
+ Stat_t st;
+ if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
+ Off_t offset = PerlIO_tell(fp);
+ if (offset != (Off_t) -1) {
+ (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
+ }
+ }
rsptr = NULL;
rslen = 0;
}
else if (RsRECORD(PL_rs)) {
- I32 recsize, bytesread;
+ I32 bytesread;
char *buffer;
/* Grab the size of the record we're getting */
recsize = SvIV(SvRV(PL_rs));
- (void)SvPOK_only(sv); /* Validate pointer */
- buffer = SvGROW(sv, (STRLEN)(recsize + 1));
+ buffer = SvGROW(sv, (STRLEN)(recsize + append + 1)) + append;
/* Go yank in */
#ifdef VMS
/* VMS wants read instead of fread, because fread doesn't respect */
/* RMS record boundaries. This is not necessarily a good thing to be */
- /* doing, but we've got no other real choice */
+ /* doing, but we've got no other real choice - except avoid stdio
+ as implementation - perhaps write a :vms layer ?
+ */
bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
#else
bytesread = PerlIO_read(fp, buffer, recsize);
#endif
- SvCUR_set(sv, bytesread);
+ SvCUR_set(sv, bytesread += append);
buffer[bytesread] = '\0';
- if (PerlIO_isutf8(fp))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
- return(SvCUR(sv) ? SvPVX(sv) : Nullch);
+ goto check_utf8_and_return;
}
else if (RsPARA(PL_rs)) {
rsptr = "\n\n";
/* Here is some breathtakingly efficient cheating */
cnt = PerlIO_get_cnt(fp); /* get count into register */
- (void)SvPOK_only(sv); /* validate pointer */
- if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* make sure we have the room */
- if (cnt > 80 && (I32)SvLEN(sv) > append) {
+ /* make sure we have the room */
+ if ((I32)(SvLEN(sv) - append) <= cnt + 1) {
+ /* Not room for all of it
+ if we are looking for a separator and room for some
+ */
+ if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) {
+ /* just process what we have room for */
shortbuffered = cnt - SvLEN(sv) + append + 1;
cnt -= shortbuffered;
}
SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1))));
}
}
- else
+ else
shortbuffered = 0;
bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
ptr = (STDCHAR*)PerlIO_get_ptr(fp);
}
}
+check_utf8_and_return:
if (PerlIO_isutf8(fp))
SvUTF8_on(sv);
else
else
io = 0;
if (!io)
- Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
+ Perl_croak(aTHX_ "Bad filehandle: %"SVf, sv);
break;
}
return io;
Nullop);
LEAVE;
if (!GvCVu(gv))
- Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
+ Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
+ sv);
}
return GvCVu(gv);
}
}
SvRV(sv) = 0;
SvROK_off(sv);
- if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || (flags & SV_IMMEDIATE_UNREF))
+ /* You can't have a || SvREADONLY(rv) here, as $a = $$a, where $a was
+ assigned to as BEGIN {$a = \"Foo"} will fail. */
+ if (SvREFCNT(rv) != 1 || (flags & SV_IMMEDIATE_UNREF))
SvREFCNT_dec(rv);
else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
sv_2mortal(rv); /* Schedule for freeing later */
I32 svix = 0;
static char nullstr[] = "(null)";
SV *argsv = Nullsv;
- bool has_utf8 = FALSE; /* has the result utf8? */
+ bool has_utf8; /* has the result utf8? */
+ bool pat_utf8; /* the pattern is in utf8? */
+ SV *nsv = Nullsv;
+
+ has_utf8 = pat_utf8 = DO_UTF8(sv);
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
/* echo everything up to the next format specification */
for (q = p; q < patend && *q != '%'; ++q) ;
if (q > p) {
- sv_catpvn(sv, p, q - p);
+ if (has_utf8 && !pat_utf8)
+ sv_catpvn_utf8_upgrade(sv, p, q - p, nsv);
+ else
+ sv_catpvn(sv, p, q - p);
p = q;
}
if (q++ >= patend)
\d+\$ explicit format parameter index
[-+ 0#]+ flags
v|\*(\d+\$)?v vector with optional (optionally specified) arg
+ 0 flag (as above): repeated to allow "v02"
\d+|\*(\d+\$)? width using optional (optionally specified) arg
\.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
[hlqLV] size
}
if (!asterisk)
+ if( *q == '0' )
+ fill = *q++;
EXPECT_NUMBER(q, width);
if (vectorize) {
intsize = 'q';
#endif
break;
+/* [perl #20339] - we should accept and ignore %lf rather than die */
+ case 'l':
+ /* FALL THROUGH */
default:
#if defined(USE_LONG_DOUBLE)
intsize = args ? 0 : 'q';
/* FALL THROUGH */
#endif
case 'h':
- /* FALL THROUGH */
- case 'l':
goto unknown;
}
if (!args && ckWARN(WARN_PRINTF) &&
(PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
SV *msg = sv_newmortal();
- Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
- (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
+ Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ",
+ (PL_op->op_type == OP_PRTF) ? "" : "s");
if (c) {
if (isPRINT(c))
Perl_sv_catpvf(aTHX_ msg,
ret->subbeg = SAVEPV(r->subbeg);
else
ret->subbeg = Nullch;
+#ifdef PERL_COPY_ON_WRITE
+ ret->saved_copy = Nullsv;
+#endif
ptr_table_store(PL_ptr_table, r, ret);
return ret;
if (dstr)
return dstr;
+ if(param->flags & CLONEf_JOIN_IN) {
+ /** We are joining here so we don't want do clone
+ something that is bad **/
+
+ if(SvTYPE(sstr) == SVt_PVHV &&
+ HvNAME(sstr)) {
+ /** don't clone stashes if they already exist **/
+ HV* old_stash = gv_stashpv(HvNAME(sstr),0);
+ return (SV*) old_stash;
+ }
+ }
+
/* create anew and remember what it is */
new_SV(dstr);
ptr_table_store(PL_ptr_table, sstr, dstr);
CvDEPTH(dstr) = 0;
}
PAD_DUP(CvPADLIST(dstr), CvPADLIST(sstr), param);
- if (!CvANON(sstr) || CvCLONED(sstr))
- CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr), param);
- else
- CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr), param);
+ CvOUTSIDE_SEQ(dstr) = CvOUTSIDE_SEQ(sstr);
+ CvOUTSIDE(dstr) =
+ CvWEAKOUTSIDE(sstr)
+ ? cv_dup( CvOUTSIDE(sstr), param)
+ : cv_dup_inc(CvOUTSIDE(sstr), param);
CvFLAGS(dstr) = CvFLAGS(sstr);
CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr));
break;
#define TOPLONG(ss,ix) ((ss)[ix].any_long)
#define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
#define TOPIV(ss,ix) ((ss)[ix].any_iv)
+#define POPBOOL(ss,ix) ((ss)[--(ix)].any_bool)
+#define TOPBOOL(ss,ix) ((ss)[ix].any_bool)
#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
#define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
sv = (SV*)POPPTR(ss,ix);
TOPPTR(nss,ix) = sv_dup(sv, param);
break;
+ case SAVEt_BOOL:
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ longval = (long)POPBOOL(ss,ix);
+ TOPBOOL(nss,ix) = (bool)longval;
+ break;
default:
Perl_croak(aTHX_ "panic: ss_dup inconsistency");
}
Create and return a new interpreter by cloning the current one.
+perl_clone takes these flags as paramters:
+
+CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
+without it we only clone the data and zero the stacks,
+with it we copy the stacks and the new perl interpreter is
+ready to run at the exact same point as the previous one.
+The pseudo-fork code uses COPY_STACKS while the
+threads->new doesn't.
+
+CLONEf_KEEP_PTR_TABLE
+perl_clone keeps a ptr_table with the pointer of the old
+variable as a key and the new variable as a value,
+this allows it to check if something has been cloned and not
+clone it again but rather just use the value and increase the
+refcount. If KEEP_PTR_TABLE is not set then perl_clone will kill
+the ptr_table using the function
+C<ptr_table_free(PL_ptr_table); PL_ptr_table = NULL;>,
+reason to keep it around is if you want to dup some of your own
+variable who are outside the graph perl scans, example of this
+code is in threads.xs create
+
+CLONEf_CLONE_HOST
+This is a win32 thing, it is ignored on unix, it tells perls
+win32host code (which is c++) to clone itself, this is needed on
+win32 if you want to run two threads at the same time,
+if you just want to do some stuff in a separate perl interpreter
+and then throw it away and return to the original one,
+you don't need to do anything.
+
=cut
*/
/* pseudo environmental stuff */
PL_origargc = proto_perl->Iorigargc;
- i = PL_origargc;
- New(0, PL_origargv, i+1, char*);
- PL_origargv[i] = '\0';
- while (i-- > 0) {
- PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
- }
+ PL_origargv = proto_perl->Iorigargv;
param->stashes = newAV(); /* Setup array of objects to call clone on */
PL_DBsingle = sv_dup(proto_perl->IDBsingle, param);
PL_DBtrace = sv_dup(proto_perl->IDBtrace, param);
PL_DBsignal = sv_dup(proto_perl->IDBsignal, param);
+ PL_DBassertion = sv_dup(proto_perl->IDBassertion, param);
PL_lineary = av_dup(proto_perl->Ilineary, param);
PL_dbargs = av_dup(proto_perl->Idbargs, param);
PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
else
PL_op_mask = Nullch;
+ /* PL_asserting = proto_perl->Iasserting; */
/* current interpreter roots */
PL_main_cv = cv_dup_inc(proto_perl->Imain_cv, param);
PL_watchok = Nullch;
PL_regdummy = proto_perl->Tregdummy;
- PL_regcomp_parse = Nullch;
- PL_regxend = Nullch;
- PL_regcode = (regnode*)NULL;
- PL_regnaughty = 0;
- PL_regsawback = 0;
PL_regprecomp = Nullch;
PL_regnpar = 0;
PL_regsize = 0;
- PL_regflags = 0;
- PL_regseen = 0;
- PL_seen_zerolen = 0;
- PL_seen_evals = 0;
- PL_regcomp_rx = (regexp*)NULL;
- PL_extralen = 0;
PL_colorset = 0; /* reinits PL_colors[] */
/*PL_colors[6] = {0,0,0,0,0,0};*/
- PL_reg_whilem_seen = 0;
PL_reginput = Nullch;
PL_regbol = Nullch;
PL_regeol = Nullch;
PL_reg_curpm = (PMOP*)NULL;
PL_reg_oldsaved = Nullch;
PL_reg_oldsavedlen = 0;
+#ifdef PERL_COPY_ON_WRITE
+ PL_nrs = Nullsv;
+#endif
PL_reg_maxiter = 0;
PL_reg_leftiter = 0;
PL_reg_poscache = Nullch;
char *
Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
{
- if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) {
- int vary = FALSE;
+ if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) {
SV *uni;
STRLEN len;
char *s;
dSP;
ENTER;
SAVETMPS;
+ save_re_context();
PUSHMARK(sp);
EXTEND(SP, 3);
XPUSHs(encoding);
uni = POPs;
PUTBACK;
s = SvPV(uni, len);
- {
- U8 *t = (U8 *)s, *e = (U8 *)s + len;
- while (t < e) {
- if ((vary = !UTF8_IS_INVARIANT(*t++)))
- break;
- }
- }
if (s != SvPVX(sv)) {
SvGROW(sv, len + 1);
Move(s, SvPVX(sv), len, char);
}
FREETMPS;
LEAVE;
- if (vary)
- SvUTF8_on(sv);
SvUTF8_on(sv);
}
return SvPVX(sv);
}
+/*
+=for apidoc sv_cat_decode
+
+The encoding is assumed to be an Encode object, the PV of the ssv is
+assumed to be octets in that encoding and decoding the input starts
+from the position which (PV + *offset) pointed to. The dsv will be
+concatenated the decoded UTF-8 string from ssv. Decoding will terminate
+when the string tstr appears in decoding output or the input ends on
+the PV of the ssv. The value which the offset points will be modified
+to the last input position on the ssv.
+
+Returns TRUE if the terminator was found, else returns FALSE.
+
+=cut */
+bool
+Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
+ SV *ssv, int *offset, char *tstr, int tlen)
+{
+ if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
+ bool ret = FALSE;
+ SV *offsv;
+ dSP;
+ ENTER;
+ SAVETMPS;
+ save_re_context();
+ PUSHMARK(sp);
+ EXTEND(SP, 6);
+ XPUSHs(encoding);
+ XPUSHs(dsv);
+ XPUSHs(ssv);
+ XPUSHs(offsv = sv_2mortal(newSViv(*offset)));
+ XPUSHs(sv_2mortal(newSVpvn(tstr, tlen)));
+ PUTBACK;
+ call_method("cat_decode", G_SCALAR);
+ SPAGAIN;
+ ret = SvTRUE(TOPs);
+ *offset = SvIV(offsv);
+ PUTBACK;
+ FREETMPS;
+ LEAVE;
+ return ret;
+ }
+ Perl_croak(aTHX_ "Invalid argument to sv_cat_decode.");
+}
https://perl5.git.perl.org / perl5.git / blobdiff