}
if (!ok) {
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Attempt to free non-arena SV: 0x%"UVxf,
PTR2UV(p));
return;
Perl_report_uninit(pTHX)
{
if (PL_op)
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
" in ", OP_DESC(PL_op));
else
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "");
}
/* grab a new IV body from the free list, allocating more if necessary */
bool
Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
{
- char* pv;
- U32 cur;
- U32 len;
- IV iv;
- NV nv;
- MAGIC* magic;
- HV* stash;
+ char* pv = NULL;
+ U32 cur = 0;
+ U32 len = 0;
+ IV iv = 0;
+ NV nv = 0.0;
+ MAGIC* magic = NULL;
+ HV* stash = Nullhv;
if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
sv_force_normal(sv);
{
register char *s;
+
+
#ifdef HAS_64K_LIMIT
if (newlen >= 0x10000) {
PerlIO_printf(Perl_debug_log,
}
else
s = SvPVX(sv);
+
if (newlen > SvLEN(sv)) { /* need more room? */
if (SvLEN(sv) && s) {
#if defined(MYMALLOC) && !defined(LEAKTEST)
}
New(703, s, newlen, char);
if (SvPVX(sv) && SvCUR(sv)) {
- Move(SvPVX(sv), s, SvCUR(sv), char);
+ Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
}
}
SvPV_set(sv, s);
}
if (PL_op)
- Perl_warner(aTHX_ WARN_NUMERIC,
+ Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
"Argument \"%s\" isn't numeric in %s", pv,
OP_DESC(PL_op));
else
- Perl_warner(aTHX_ WARN_NUMERIC,
+ Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
"Argument \"%s\" isn't numeric", pv);
}
return ptr;
}
-/* For backwards-compatibility only. sv_2pv() is normally #def'ed to
- * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>.
+/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
*/
char *
}
/*
+=for apidoc sv_copypv
+
+Copies a stringified representation of the source SV into the
+destination SV. Automatically performs any necessary mg_get and
+coercion of numeric values into strings. Guaranteed to preserve
+UTF-8 flag even from overloaded objects. Similar in nature to
+sv_2pv[_flags] but operates directly on an SV instead of just the
+string. Mostly uses sv_2pv_flags to do its work, except when that
+would lose the UTF-8'ness of the PV.
+
+=cut
+*/
+
+void
+Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
+{
+ SV *tmpsv = sv_newmortal();
+
+ if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) ) {
+ tmpsv = AMG_CALLun(ssv,string);
+ if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv))) {
+ SvSetSV(dsv,tmpsv);
+ return;
+ }
+ }
+ {
+ STRLEN len;
+ char *s;
+ s = SvPV(ssv,len);
+ sv_setpvn(tmpsv,s,len);
+ if (SvUTF8(ssv))
+ SvUTF8_on(tmpsv);
+ else
+ SvUTF8_off(tmpsv);
+ SvSetSV(dsv,tmpsv);
+ }
+}
+
+/*
=for apidoc sv_2pvbyte_nolen
Return a pointer to the byte-encoded representation of the SV.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear.
+This is not as a general purpose byte encoding to Unicode interface:
+use the Encode extension for that.
+
=cut
*/
+/* 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)
{
will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
+This is not as a general purpose byte encoding to Unicode interface:
+use the Encode extension for that.
+
=cut
*/
}
if (PL_encoding)
- Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
+ sv_recode_to_utf8(sv, PL_encoding);
else { /* Assume Latin-1/EBCDIC */
/* This function could be much more efficient if we
* had a FLAG in SVs to signal if there are any hibit
if this is the case, either returns false or, if C<fail_ok> is not
true, croaks.
+This is not as a general purpose Unicode to byte encoding interface:
+use the Encode extension for that.
+
=cut
*/
=cut
*/
-/* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
- for binary compatibility only
-*/
+/* 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_cmp(cv_const_sv(cv),
cv_const_sv((CV*)sref)))))
{
- Perl_warner(aTHX_ WARN_REDEFINE,
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
CvCONST(cv)
? "Constant subroutine %s redefined"
: "Subroutine %s redefined",
}
else { /* have to copy actual string */
STRLEN len = SvCUR(sstr);
-
SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
Move(SvPVX(sstr),SvPVX(dstr),len,char);
SvCUR_set(dstr, len);
else {
if (dtype == SVt_PVGV) {
if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
}
else
(void)SvOK_off(dstr);
=cut
*/
-/* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
- for binary compatibility only
-*/
+/* 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)
{
=cut */
-/* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
- for binary compatibility only
-*/
+/* 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)
{
Perl_croak(aTHX_ "Can't weaken a nonreference");
else if (SvWEAKREF(sv)) {
if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
return sv;
}
tsv = SvRV(sv);
SV **svp;
I32 i;
SV *tsv = SvRV(sv);
- MAGIC *mg;
+ MAGIC *mg = NULL;
if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST(sv);
if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
if (SvMAGICAL(sv)) {
if (SvMAGICAL(nsv))
mg_free(nsv);
return;
}
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
return;
}
ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
#ifdef DEBUGGING
if (SvTEMP(sv)) {
if (ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ WARN_DEBUGGING,
+ Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
"Attempt to free temp prematurely: SV 0x%"UVxf,
PTR2UV(sv));
return;
STRLEN cur2;
I32 eq = 0;
char *tpv = Nullch;
+ SV* svrecode = Nullsv;
if (!sv1) {
pv1 = "";
else
pv2 = SvPV(sv2, cur2);
- /* do not utf8ize the comparands as a side-effect */
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
- bool is_utf8 = TRUE;
- /* UTF-8ness differs */
-
- if (SvUTF8(sv1)) {
- /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
- char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
- if (pv != pv1)
- pv1 = tpv = pv;
- }
- else {
- /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
- char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
- if (pv != pv2)
- pv2 = tpv = pv;
- }
- if (is_utf8) {
- /* Downgrade not possible - cannot be eq */
- return FALSE;
- }
+ /* Differing utf8ness.
+ * Do not UTF8size the comparands as a side-effect. */
+ if (PL_encoding) {
+ if (SvUTF8(sv1)) {
+ svrecode = newSVpvn(pv2, cur2);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv2 = SvPV(svrecode, cur2);
+ }
+ else {
+ svrecode = newSVpvn(pv1, cur1);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv1 = SvPV(svrecode, cur1);
+ }
+ /* Now both are in UTF-8. */
+ if (cur1 != cur2)
+ return FALSE;
+ }
+ else {
+ bool is_utf8 = TRUE;
+
+ if (SvUTF8(sv1)) {
+ /* sv1 is the UTF-8 one,
+ * if is equal it must be downgrade-able */
+ char *pv = (char*)bytes_from_utf8((U8*)pv1,
+ &cur1, &is_utf8);
+ if (pv != pv1)
+ pv1 = tpv = pv;
+ }
+ else {
+ /* sv2 is the UTF-8 one,
+ * if is equal it must be downgrade-able */
+ char *pv = (char *)bytes_from_utf8((U8*)pv2,
+ &cur2, &is_utf8);
+ if (pv != pv2)
+ pv2 = tpv = pv;
+ }
+ if (is_utf8) {
+ /* Downgrade not possible - cannot be eq */
+ return FALSE;
+ }
+ }
}
if (cur1 == cur2)
eq = memEQ(pv1, pv2, cur1);
- if (tpv != Nullch)
+ if (svrecode)
+ SvREFCNT_dec(svrecode);
+
+ if (tpv)
Safefree(tpv);
return eq;
Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
{
STRLEN cur1, cur2;
- char *pv1, *pv2;
+ char *pv1, *pv2, *tpv = Nullch;
I32 cmp;
- bool pv1tmp = FALSE;
- bool pv2tmp = FALSE;
+ SV *svrecode = Nullsv;
if (!sv1) {
pv1 = "";
else
pv1 = SvPV(sv1, cur1);
- if (!sv2){
+ if (!sv2) {
pv2 = "";
cur2 = 0;
}
else
pv2 = SvPV(sv2, cur2);
- /* do not utf8ize the comparands as a side-effect */
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
+ /* Differing utf8ness.
+ * Do not UTF8size the comparands as a side-effect. */
if (SvUTF8(sv1)) {
- pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
- pv2tmp = TRUE;
+ if (PL_encoding) {
+ svrecode = newSVpvn(pv2, cur2);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv2 = SvPV(svrecode, cur2);
+ }
+ else {
+ pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2);
+ }
}
else {
- pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
- pv1tmp = TRUE;
+ if (PL_encoding) {
+ svrecode = newSVpvn(pv1, cur1);
+ sv_recode_to_utf8(svrecode, PL_encoding);
+ pv1 = SvPV(svrecode, cur1);
+ }
+ else {
+ pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1);
+ }
}
}
}
}
- if (pv1tmp)
- Safefree(pv1);
- if (pv2tmp)
- Safefree(pv2);
+ if (svrecode)
+ SvREFCNT_dec(svrecode);
+
+ if (tpv)
+ Safefree(tpv);
return cmp;
}
return Nullsv;
if (SvTYPE(old) == SVTYPEMASK) {
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
return Nullsv;
}
new_SV(sv);
CV *
Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
{
- GV *gv;
- CV *cv;
+ GV *gv = Nullgv;
+ CV *cv = Nullcv;
STRLEN n_a;
if (!sv)
/*
=for apidoc sv_pv
-A private implementation of the C<SvPV_nolen> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
+Use the C<SvPV_nolen> macro instead
=cut
*/
+/* sv_pv() is now a macro using SvPV_nolen();
+ * this function provided for binary compatibility only
+ */
+
+
char *
Perl_sv_pv(pTHX_ SV *sv)
{
return sv_2pv(sv, lp);
}
-/* For -DCRIPPLED_CC only. See also C<sv_2pv_flags()>.
- */
char *
Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
=cut
*/
+/* 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)
{
char *
Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
{
- char *s;
+ char *s = NULL;
if (SvTHINKFIRST(sv) && !SvROK(sv))
sv_force_normal(sv);
/*
=for apidoc sv_pvbyte
-A private implementation of the C<SvPVbyte_nolen> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
+Use C<SvPVbyte_nolen> instead.
=cut
*/
+/* 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)
{
/*
=for apidoc sv_pvutf8
-A private implementation of the C<SvPVutf8_nolen> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
+Use the C<SvPVutf8_nolen> macro instead
=cut
*/
+/* 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 *vecsv;
U8 *vecstr = Null(U8*);
STRLEN veclen = 0;
- char c;
+ char c = 0;
int i;
unsigned base = 0;
IV iv = 0;
if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
&& (n == 2 || !isDIGIT(s[n-3])))
{
- Perl_warner(aTHX_ WARN_Y2K,
+ Perl_warner(aTHX_ packWARN(WARN_Y2K),
"Possible Y2K bug: %%%c %s",
c, "format string following '19'");
}
(UV)c & 0xFF);
} else
sv_catpv(msg, "end of string");
- Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
+ Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
}
/* output mangled stuff ... */
s->min_offset = r->substrs->data[i].min_offset;
s->max_offset = r->substrs->data[i].max_offset;
s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
+ s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
}
ret->regstclass = NULL;
PL_debug = proto_perl->Idebug;
#ifdef USE_REENTRANT_API
- New(31337, PL_reentrant_buffer,1, REBUF);
- New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
+ Perl_reentrant_init(aTHX);
#endif
/* create SV map for pointer relocation */
#endif
PL_encoding = sv_dup(proto_perl->Iencoding, param);
+ sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
+ sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
+ sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
+
/* Clone the regex array */
PL_regex_padav = newAV();
{
https://perl5.git.perl.org / perl5.git / blobdiff