X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=21de7ed654e6ecca725fb87963c096bc98fff12e;hb=8f8f6e09d34f5d0588c3287bc99d33cf16f7fc13;hp=32ea12549417fa095bbbc4cb2ec4b6e085673329;hpb=59bd0823b6625605b67ec19bd9bcc4dd06530e7e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 32ea125..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 */ @@ -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; @@ -6520,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); @@ -6671,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) @@ -6917,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); @@ -8283,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'"); } @@ -8420,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 ... */ @@ -8581,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; @@ -9977,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(); {