/* 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.
#define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
/* 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
/* ============================================================================
{
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;
/* 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;
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
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))
*mgp = mg_find(sv, PERL_MAGIC_utf8);
if (*mgp && (*mgp)->mg_ptr) {
*cachep = (STRLEN *) (*mgp)->mg_ptr;
- if ((*cachep)[i] == uoff) /* An exact match. */
+ if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
found = TRUE;
else { /* We will skip to the right spot. */
STRLEN forw = 0;
* 2 * backw in the below comes from). (The real
* figure of course depends on the UTF-8 data.) */
- if ((*cachep)[i] > uoff) {
+ if ((*cachep)[i] > (STRLEN)uoff) {
forw = uoff;
- backw = (*cachep)[i] - uoff;
+ backw = (*cachep)[i] - (STRLEN)uoff;
if (forw < 2 * backw)
p = start;
else if (i == 0) { /* (*cachep)[i] < uoff */
STRLEN ulen = sv_len_utf8(sv);
- if (uoff < ulen) {
- forw = uoff - (*cachep)[i];
- backw = ulen - uoff;
+ if ((STRLEN)uoff < ulen) {
+ forw = (STRLEN)uoff - (*cachep)[i];
+ backw = ulen - (STRLEN)uoff;
if (forw < 2 * backw)
p = start + (*cachep)[i+1];
}
/* Update the cache. */
- (*cachep)[i] = uoff;
+ (*cachep)[i] = (STRLEN)uoff;
(*cachep)[i+1] = p - start;
found = TRUE;
U8 *p = s + cache[1];
STRLEN ubackw = 0;
+ cache[1] -= backw;
+
while (backw--) {
p--;
while (UTF8_IS_CONTINUATION(*p))
}
cache[0] -= ubackw;
- cache[1] -= backw;
return;
}
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) && st.st_size
- && (recsize = st.st_size - PerlIO_tell(fp)))
- goto read_record;
+ 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;
}
/* Grab the size of the record we're getting */
recsize = SvIV(SvRV(PL_rs));
-
- read_record:
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);
/* Here is some breathtakingly efficient cheating */
cnt = PerlIO_get_cnt(fp); /* get count into register */
- 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);
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;
}
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;
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_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