/* 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.
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);
return ptr;
}
+/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
+{
+ return sv_2pv_flags(sv, lp, SV_GMAGIC);
+}
+
/*
=for apidoc sv_2pv_flags
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_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
+ * this function provided for binary compatibility only
+ */
+
+
+STRLEN
+Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
+{
+ return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
+}
+
/*
=for apidoc sv_utf8_upgrade
return TRUE;
}
+/* sv_setsv() is now a macro using Perl_sv_setsv_flags();
+ * this function provided for binary compatibility only
+ */
+
+void
+Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
+{
+ sv_setsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
/*
=for apidoc sv_setsv
SvIVX(sv) += delta;
}
+/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
+ * this function provided for binary compatibility only
+ */
+
+void
+Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
+{
+ sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
+}
+
/*
=for apidoc sv_catpvn
SvSETMAGIC(sv);
}
+/* sv_catsv() is now a macro using Perl_sv_catsv_flags();
+ * this function provided for binary compatibility only
+ */
+
+void
+Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
+{
+ sv_catsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
/*
=for apidoc sv_catsv
(void)SvUPGRADE(sv, SVt_PV);
SvSCREAM_off(sv);
- SvPOK_only(sv); /* Validate pointer */
+
+ if (append) {
+ if (PerlIO_isutf8(fp)) {
+ if (!SvUTF8(sv)) {
+ sv_utf8_upgrade_nomg(sv);
+ sv_pos_u2b(sv,&append,0);
+ }
+ } else if (SvUTF8(sv)) {
+ SV *tsv = NEWSV(0,0);
+ sv_gets(tsv, fp, 0);
+ sv_utf8_upgrade_nomg(tsv);
+ SvCUR_set(sv,append);
+ sv_catsv(sv,tsv);
+ sv_free(tsv);
+ goto return_string_or_null;
+ }
+ }
+
+ SvPOK_only(sv);
+ if (PerlIO_isutf8(fp))
+ SvUTF8_on(sv);
if (PL_curcop == &PL_compiling) {
/* we always read code in line mode */
#endif
SvCUR_set(sv, bytesread += append);
buffer[bytesread] = '\0';
- goto check_utf8_and_return;
+ goto return_string_or_null;
}
else if (RsPARA(PL_rs)) {
rsptr = "\n\n";
}
}
-check_utf8_and_return:
- if (PerlIO_isutf8(fp))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
-
+return_string_or_null:
return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
}
return sv_2nv(sv);
}
+/* sv_pv() is now a macro using SvPV_nolen();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pv(pTHX_ SV *sv)
+{
+ STRLEN n_a;
+
+ if (SvPOK(sv))
+ return SvPVX(sv);
+
+ return sv_2pv(sv, &n_a);
+}
+
/*
=for apidoc sv_pv
return sv_2pv_flags(sv, lp, 0);
}
+/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
+{
+ return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
+}
+
/*
=for apidoc sv_pvn_force
return SvPVX(sv);
}
+/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pvbyte(pTHX_ SV *sv)
+{
+ sv_utf8_downgrade(sv,0);
+ return sv_pv(sv);
+}
+
/*
=for apidoc sv_pvbyte
return sv_pvn_force(sv,lp);
}
+/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pvutf8(pTHX_ SV *sv)
+{
+ sv_utf8_upgrade(sv);
+ return sv_pv(sv);
+}
+
/*
=for apidoc sv_pvutf8
return FALSE;
}
+/*
+=for apidoc sv_setpviv
+
+Copies an integer into the given SV, also updating its string value.
+Does not handle 'set' magic. See C<sv_setpviv_mg>.
+
+=cut
+*/
+
+void
+Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
+{
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf;
+ char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+
+ sv_setpvn(sv, ptr, ebuf - ptr);
+}
+
+/*
+=for apidoc sv_setpviv_mg
+
+Like C<sv_setpviv>, but also handles 'set' magic.
+
+=cut
+*/
+
+void
+Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
+{
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf;
+ char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+
+ sv_setpvn(sv, ptr, ebuf - ptr);
+ SvSETMAGIC(sv);
+}
+
#if defined(PERL_IMPLICIT_CONTEXT)
/* pTHX_ magic can't cope with varargs, so this is a no-context
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);
STRLEN zeros = 0;
bool has_precis = FALSE;
STRLEN precis = 0;
+ I32 osvix = svix;
bool is_utf8 = FALSE; /* is this item utf8? */
#ifdef HAS_LDBL_SPRINTF_BUG
/* This is to try to fix a bug with irix/nonstop-ux/powerux and
/* 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)
default:
unknown:
- vectorize = FALSE;
if (!args && ckWARN(WARN_PRINTF) &&
(PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
SV *msg = sv_newmortal();
p += elen;
*p = '\0';
SvCUR(sv) = p - SvPVX(sv);
+ svix = osvix;
continue; /* not "break" */
}
/* internal state */
PL_tainting = proto_perl->Itainting;
+ PL_taint_warn = proto_perl->Itaint_warn;
PL_maxo = proto_perl->Imaxo;
if (proto_perl->Iop_mask)
PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
+ /* Did the locale setup indicate UTF-8? */
+ PL_utf8locale = proto_perl->Iutf8locale;
+ /* Unicode features (see perlrun/-C) */
+ PL_unicode = proto_perl->Iunicode;
+
+ /* Pre-5.8 signals control */
+ PL_signals = proto_perl->Isignals;
+
+ /* times() ticks per second */
+ PL_clocktick = proto_perl->Iclocktick;
+
+ /* Recursion stopper for PerlIO_find_layer */
+ PL_in_load_module = proto_perl->Iin_load_module;
+
+ /* sort() routine */
+ PL_sort_RealCmp = proto_perl->Isort_RealCmp;
+
/* swatch cache */
PL_last_swash_hv = Nullhv; /* reinits on demand */
PL_last_swash_klen = 0;
Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
SV *ssv, int *offset, char *tstr, int tlen)
{
+ bool ret = FALSE;
if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
- bool ret = FALSE;
SV *offsv;
dSP;
ENTER;
PUTBACK;
FREETMPS;
LEAVE;
- return ret;
}
- Perl_croak(aTHX_ "Invalid argument to sv_cat_decode.");
+ else
+ Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
+ return ret;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff