return sv;
}
-STATIC void
+STATIC I32
S_visit(pTHX_ SVFUNC_t f)
{
SV* sva;
SV* sv;
register SV* svend;
+ I32 visited = 0;
for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
- if (SvTYPE(sv) != SVTYPEMASK)
+ if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
(FCALL)(aTHXo_ sv);
+ ++visited;
+ }
}
}
+ return visited;
}
void
PL_in_clean_objs = FALSE;
}
-void
+I32
Perl_sv_clean_all(pTHX)
{
+ I32 cleaned;
PL_in_clean_all = TRUE;
- visit(do_clean_all);
+ cleaned = visit(do_clean_all);
PL_in_clean_all = FALSE;
+ return cleaned;
}
void
STRLEN
Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
{
- char *s, *t, *e;
+ U8 *s, *t, *e;
int hibit = 0;
if (!sv)
return 0;
- if (!SvPOK(sv))
- (void) SvPV_nolen(sv);
+ if (!SvPOK(sv)) {
+ STRLEN len = 0;
+ (void) sv_2pv(sv,&len);
+ if (!SvPOK(sv))
+ return len;
+ }
if (SvUTF8(sv))
return SvCUR(sv);
+ if (SvREADONLY(sv) && SvFAKE(sv)) {
+ sv_force_normal(sv);
+ }
+
/* This function could be much more efficient if we had a FLAG in SVs
* to signal if there are any hibit chars in the PV.
* Given that there isn't make loop fast as possible
*/
- s = SvPVX(sv);
- e = SvEND(sv);
+ s = (U8 *) SvPVX(sv);
+ e = (U8 *) SvEND(sv);
t = s;
while (t < e) {
- if ((hibit = UTF8_IS_CONTINUED(*t++)))
+ U8 ch = *t++;
+ if ((hibit = !NATIVE_IS_INVARIANT(ch)))
break;
}
-
if (hibit) {
STRLEN len;
- if (SvREADONLY(sv) && SvFAKE(sv)) {
- sv_force_normal(sv);
- s = SvPVX(sv);
- }
len = SvCUR(sv) + 1; /* Plus the \0 */
SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
SvCUR(sv) = len - 1;
Perl_sv_utf8_decode(pTHX_ register SV *sv)
{
if (SvPOK(sv)) {
- char *c;
- char *e;
+ U8 *c;
+ U8 *e;
/* The octets may have got themselves encoded - get them back as bytes */
if (!sv_utf8_downgrade(sv, TRUE))
/* it is actually just a matter of turning the utf8 flag on, but
* we want to make sure everything inside is valid utf8 first.
*/
- c = SvPVX(sv);
- if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
+ c = (U8 *) SvPVX(sv);
+ if (!is_utf8_string(c, SvCUR(sv)+1))
return FALSE;
- e = SvEND(sv);
+ e = (U8 *) SvEND(sv);
while (c < e) {
- if (UTF8_IS_CONTINUED(*c++)) {
+ U8 ch = *c++;
+ if (!UTF8_IS_INVARIANT(ch)) {
SvUTF8_on(sv);
break;
}
=for apidoc sv_catpvn
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. Handles 'get' magic, but not
-'set' magic. See C<sv_catpvn_mg>.
+C<len> indicates number of bytes to copy. If the SV has the UTF8
+status set, then the bytes appended should be valid UTF8.
+Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
=cut
*/
=for apidoc sv_catpv
Concatenates the string onto the end of the string which is in the SV.
-Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
+If the SV has the UTF8 status set, then the bytes appended should be
+valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
-=cut
-*/
+=cut */
void
Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
len = 0;
while (s < send) {
STRLEN n;
- /* We can use low level directly here as we are not looking at the values */
- if (utf8n_to_uvuni(s, UTF8SKIP(s), &n, 0)) {
+ /* Call utf8n_to_uvchr() to validate the sequence */
+ utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
+ if (n > 0) {
s += n;
len++;
}
char *pv2;
STRLEN cur2;
I32 eq = 0;
- bool pv1tmp = FALSE;
- bool pv2tmp = FALSE;
+ char *tpv = Nullch;
if (!sv1) {
pv1 = "";
/* do not utf8ize the comparands as a side-effect */
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
bool is_utf8 = TRUE;
-
+ /* UTF-8ness differs */
if (PL_hints & HINT_UTF8_DISTINCT)
return FALSE;
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 ((pv1tmp = (pv != pv1)))
- pv1 = pv;
+ 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 ((pv2tmp = (pv != pv2)))
- pv2 = pv;
+ 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 (pv1tmp)
- Safefree(pv1);
- if (pv2tmp)
- Safefree(pv2);
+ if (tpv != Nullch)
+ Safefree(tpv);
return eq;
}
/*
=for apidoc sv_catpvf
-Processes its arguments like C<sprintf> and appends the formatted output
-to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
-typically be called after calling this function to handle 'set' magic.
+Processes its arguments like C<sprintf> and appends the formatted
+output to an SV. If the appended data contains "wide" characters
+(including, but not limited to, SVs with a UTF-8 PV formatted with %s,
+and characters >255 formatted with %c), the original SV might get
+upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
+C<SvSETMAGIC()> must typically be called after calling this function
+to handle 'set' magic.
-=cut
-*/
+=cut */
void
Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
case 'c':
uv = args ? va_arg(*args, int) : SvIVx(argsv);
- if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
+ if ((uv > 255 ||
+ (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
+ && !IN_BYTE) {
eptr = (char*)utf8buf;
elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
is_utf = TRUE;
CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
CvXSUB(dstr) = CvXSUB(sstr);
CvXSUBANY(dstr) = CvXSUBANY(sstr);
- CvGV(dstr) = gv_dup_inc(CvGV(sstr));
+ CvGV(dstr) = gv_dup(CvGV(sstr));
CvDEPTH(dstr) = CvDEPTH(sstr);
if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
/* XXX padlists are real, but pretend to be not */
ncx->blk_sub.argarray = (cx->blk_sub.hasargs
? av_dup_inc(cx->blk_sub.argarray)
: Nullav);
- ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
+ ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
ncx->blk_sub.lval = cx->blk_sub.lval;
PL_defgv = gv_dup(proto_perl->Idefgv);
PL_argvgv = gv_dup(proto_perl->Iargvgv);
PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
- PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
+ PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
/* shortcuts to regexp stuff */
PL_replgv = gv_dup(proto_perl->Ireplgv);
projects / p5sagit/p5-mst-13.2.git / blobdiff