X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=21de7ed654e6ecca725fb87963c096bc98fff12e;hb=8f8f6e09d34f5d0588c3287bc99d33cf16f7fc13;hp=f893fa6bd82bf7edd4a1846bbbec50e9e17417bf;hpb=0d3b7757875e39a336d967574233c80ebdc2f8b6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index f893fa6..21de7ed 100644 --- a/sv.c +++ b/sv.c @@ -199,7 +199,7 @@ S_del_sv(pTHX_ SV *p) } 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; @@ -546,10 +546,10 @@ void 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 */ @@ -1226,13 +1226,13 @@ You generally want to use the C macro wrapper. See also C. 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); @@ -1540,6 +1540,8 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) { register char *s; + + #ifdef HAS_64K_LIMIT if (newlen >= 0x10000) { PerlIO_printf(Perl_debug_log, @@ -1565,6 +1567,7 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) } else s = SvPVX(sv); + if (newlen > SvLEN(sv)) { /* need more room? */ if (SvLEN(sv) && s) { #if defined(MYMALLOC) && !defined(LEAKTEST) @@ -1585,7 +1588,7 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) } 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); @@ -1824,11 +1827,11 @@ S_not_a_number(pTHX_ SV *sv) } 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); } @@ -3152,10 +3155,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) 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 +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 +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 @@ -3313,6 +3316,9 @@ Forces the SV to string form if it is not already. 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 */ @@ -3332,6 +3338,9 @@ if all the bytes have hibit clear. If C has C bit set, will C on C if appropriate, else not. C and C 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 */ @@ -3359,7 +3368,7 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) } 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 @@ -3397,6 +3406,9 @@ This may not be possible if the PV contains non-byte encoding characters; if this is the case, either returns false or, if C is not true, croaks. +This is not as a general purpose Unicode to byte encoding interface: +use the Encode extension for that. + =cut */ @@ -3784,7 +3796,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) || 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", @@ -3908,7 +3920,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } 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); @@ -3964,7 +3975,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) 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); @@ -4731,7 +4742,7 @@ Perl_sv_rvweaken(pTHX_ SV *sv) 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); @@ -4771,7 +4782,7 @@ S_sv_del_backref(pTHX_ SV *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; @@ -4898,7 +4909,7 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) 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); @@ -5173,7 +5184,7 @@ Perl_sv_free(pTHX_ SV *sv) 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)); @@ -5182,7 +5193,7 @@ Perl_sv_free(pTHX_ SV *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; @@ -5349,6 +5360,8 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) char *pv2; STRLEN cur2; I32 eq = 0; + char *tpv = Nullch; + SV* svrecode = Nullsv; if (!sv1) { pv1 = ""; @@ -5364,13 +5377,59 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) else pv2 = SvPV(sv2, cur2); - if (SvUTF8(sv1) == SvUTF8(sv2) || IN_BYTES) - eq = (cur1 == cur2) && memEQ(pv1, pv2, cur1); - else if (SvUTF8(sv1)) /* do not utf8ize the comparands as a side-effect */ - eq = !memcmp_byte_utf8(pv2, cur2, pv1, cur1); - else - eq = !memcmp_byte_utf8(pv1, cur1, pv2, cur2); + if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { + /* 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 (svrecode) + SvREFCNT_dec(svrecode); + + if (tpv) + Safefree(tpv); + return eq; } @@ -5389,8 +5448,9 @@ I32 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) { STRLEN cur1, cur2; - char *pv1, *pv2; - I32 retval; + char *pv1, *pv2, *tpv = Nullch; + I32 cmp; + SV *svrecode = Nullsv; if (!sv1) { pv1 = ""; @@ -5399,35 +5459,61 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) else pv1 = SvPV(sv1, cur1); - if (!sv2){ + if (!sv2) { pv2 = ""; cur2 = 0; } else pv2 = SvPV(sv2, cur2); + if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { + /* Differing utf8ness. + * Do not UTF8size the comparands as a side-effect. */ + if (SvUTF8(sv1)) { + 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 { + 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 (!cur1) { - return cur2 ? -1 : 0; + cmp = cur2 ? -1 : 0; } else if (!cur2) { - return 1; - } else if (SvUTF8(sv1) == SvUTF8(sv2) || IN_BYTES) { - retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); + cmp = 1; + } else { + I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2); if (retval) { - return retval < 0 ? -1 : 1; + cmp = retval < 0 ? -1 : 1; } else if (cur1 == cur2) { - return 0; - } else { - return cur1 < cur2 ? -1 : 1; + cmp = 0; + } else { + cmp = cur1 < cur2 ? -1 : 1; } - } else if (SvUTF8(sv1)) /* do not utf8ize the comparands as a side-effect */ - retval = -memcmp_byte_utf8(pv2, cur2, pv1, cur1); - else - retval = memcmp_byte_utf8(pv1, cur1, pv2, cur2); + } - if (retval) /* CURs taken into account already */ - return retval < 0 ? -1 : 1; - return 0; + if (svrecode) + SvREFCNT_dec(svrecode); + + if (tpv) + Safefree(tpv); + + return cmp; } /* @@ -6445,7 +6531,7 @@ Perl_newSVsv(pTHX_ register SV *old) 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); @@ -6596,8 +6682,8 @@ possible to set C<*st> and C<*gvp> to the stash and GV associated with it. 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) @@ -6842,7 +6928,7 @@ C and C 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); @@ -8208,7 +8294,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV 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'"); } @@ -8345,7 +8431,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV (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 ... */ @@ -8506,6 +8592,7 @@ Perl_re_dup(pTHX_ REGEXP *r, CLONE_PARAMS *param) 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; @@ -9792,8 +9879,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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 */ @@ -9903,6 +9989,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif PL_encoding = sv_dup(proto_perl->Iencoding, param); +#ifdef DEBUGGING + sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */ + sv_setpvn(PERL_DEBUG_PAD(1), "", 0); + sv_setpvn(PERL_DEBUG_PAD(2), "", 0); +#endif + /* Clone the regex array */ PL_regex_padav = newAV(); {