X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8aacddc1ea3837f8f1a911d90c644451fc7cfc86..2cf2cfc6ec6384231f5e996b330e88a28ca597d7:/sv.c diff --git a/sv.c b/sv.c index e9ac9e1..d5dffef 100644 --- a/sv.c +++ b/sv.c @@ -216,6 +216,8 @@ S_del_sv(pTHX_ SV *p) /* +=head1 SV Manipulation Functions + =for apidoc sv_add_arena Given a chunk of memory, link it to the head of the list of arenas, @@ -1941,7 +1943,7 @@ Perl_looks_like_number(pTHX_ SV *sv) STATIC int S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) { - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { (void)SvIOKp_on(sv); (void)SvNOK_on(sv); @@ -2195,7 +2197,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n", PTR2UV(sv), SvNVX(sv))); #endif @@ -2251,7 +2253,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) 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)=%g 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(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 @@ -2483,7 +2485,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n", PTR2UV(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n", PTR2UV(sv), SvNVX(sv))); #endif @@ -2538,7 +2540,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) 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)=%g 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(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); @@ -2634,7 +2636,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #else DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n", + PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); @@ -2763,7 +2765,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #else DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n", + PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n", PTR2UV(sv), SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); @@ -3235,7 +3237,7 @@ Perl_sv_2bool(pTHX_ register SV *sv) if (SvROK(sv)) { SV* tmpsv; if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && - (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv)))) + (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) return SvTRUE(tmpsv); return SvRV(sv) != 0; } @@ -5666,7 +5668,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", + "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); for (;;) { @@ -5701,18 +5703,22 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n", PTR2UV(ptr),(long)cnt)); PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ +#if 0 DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); +#endif /* This used to call 'filbuf' in stdio form, but as that behaves like getc when cnt <= 0 we use PerlIO_getc here to avoid introducing another abstraction. */ i = PerlIO_getc(fp); /* get more characters */ +#if 0 DEBUG_P(PerlIO_printf(Perl_debug_log, "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n", PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp), PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); +#endif cnt = PerlIO_get_cnt(fp); ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ DEBUG_P(PerlIO_printf(Perl_debug_log, @@ -5936,7 +5942,7 @@ Perl_sv_inc(pTHX_ register SV *sv) DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n", + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv))); #endif } @@ -6084,7 +6090,7 @@ Perl_sv_dec(pTHX_ register SV *sv) DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv))); #else - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n", + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv))); #endif } @@ -7649,6 +7655,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV I32 svix = 0; static char nullstr[] = "(null)"; SV *argsv = Nullsv; + bool has_utf8 = FALSE; /* has the result utf8? */ /* no matter what, this is a string now */ (void)SvPV_force(sv, origlen); @@ -7682,13 +7689,16 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } + if (!args && svix < svmax && DO_UTF8(*svargs)) + has_utf8 = TRUE; + patend = (char*)pat + patlen; for (p = (char*)pat; p < patend; p = q) { bool alt = FALSE; bool left = FALSE; bool vectorize = FALSE; bool vectorarg = FALSE; - bool vec_utf = FALSE; + bool vec_utf8 = FALSE; char fill = ' '; char plus = 0; char intsize = 0; @@ -7696,7 +7706,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN zeros = 0; bool has_precis = FALSE; STRLEN precis = 0; - bool is_utf = FALSE; + bool is_utf8 = FALSE; /* is this item utf8? */ char esignbuf[4]; U8 utf8buf[UTF8_MAXLEN+1]; @@ -7821,17 +7831,17 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef; dotstr = SvPVx(vecsv, dotstrlen); if (DO_UTF8(vecsv)) - is_utf = TRUE; + is_utf8 = TRUE; } if (args) { vecsv = va_arg(*args, SV*); vecstr = (U8*)SvPVx(vecsv,veclen); - vec_utf = DO_UTF8(vecsv); + vec_utf8 = DO_UTF8(vecsv); } else if (efix ? efix <= svmax : svix < svmax) { vecsv = svargs[efix ? efix-1 : svix++]; vecstr = (U8*)SvPVx(vecsv,veclen); - vec_utf = DO_UTF8(vecsv); + vec_utf8 = DO_UTF8(vecsv); } else { vecstr = (U8*)""; @@ -7925,7 +7935,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV && !IN_BYTES) { eptr = (char*)utf8buf; elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf; - is_utf = TRUE; + is_utf8 = TRUE; } else { c = (char)uv; @@ -7961,7 +7971,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (width) { /* fudge width (can't fudge elen) */ width += elen - sv_len_utf8(argsv); } - is_utf = TRUE; + is_utf8 = TRUE; } } goto string; @@ -7977,7 +7987,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV argsv = va_arg(*args, SV*); eptr = SvPVx(argsv, elen); if (DO_UTF8(argsv)) - is_utf = TRUE; + is_utf8 = TRUE; string: vectorize = FALSE; @@ -8007,8 +8017,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN ulen; if (!veclen) continue; - if (vec_utf) - uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV); + if (vec_utf8) + uv = utf8n_to_uvchr(vecstr, veclen, &ulen, + UTF8_ALLOW_ANYUV); else { uv = *vecstr; ulen = 1; @@ -8092,8 +8103,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV vector: if (!veclen) continue; - if (vec_utf) - uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV); + if (vec_utf8) + uv = utf8n_to_uvchr(vecstr, veclen, &ulen, + UTF8_ALLOW_ANYUV); else { uv = *vecstr; ulen = 1; @@ -8348,6 +8360,20 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *p++ = '0'; } if (elen) { + if (is_utf8 != has_utf8) { + if (is_utf8) { + if (SvCUR(sv)) { + sv_utf8_upgrade(sv); + p = SvEND(sv); + } + } + else { + SV *nsv = sv_2mortal(newSVpvn(eptr, elen)); + sv_utf8_upgrade(nsv); + eptr = SvPVX(nsv); + elen = SvCUR(nsv); + } + } Copy(eptr, p, elen, char); p += elen; } @@ -8363,7 +8389,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV else vectorize = FALSE; /* done iterating over vecstr */ } - if (is_utf) + if (is_utf8) + has_utf8 = TRUE; + if (has_utf8) SvUTF8_on(sv); *p = '\0'; SvCUR(sv) = p - SvPVX(sv); @@ -9664,7 +9692,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * their pointers copied. */ IV i; - CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS)); + CLONE_PARAMS clone_params; + CLONE_PARAMS* param = &clone_params; PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); PERL_SET_THX(my_perl); @@ -9676,6 +9705,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_savestack = 0; PL_retstack = 0; PL_sig_pending = 0; + Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); # endif /* DEBUGGING */ @@ -9692,7 +9722,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_Proc = ipP; #else /* !PERL_IMPLICIT_SYS */ IV i; - CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS)); + CLONE_PARAMS clone_params; + CLONE_PARAMS* param = &clone_params; PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); PERL_SET_THX(my_perl); @@ -9705,6 +9736,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_savestack = 0; PL_retstack = 0; PL_sig_pending = 0; + Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); # endif /* DEBUGGING */ @@ -10373,7 +10405,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } SvREFCNT_dec(param->stashes); - Safefree(param); return my_perl; } @@ -10381,6 +10412,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif /* USE_ITHREADS */ /* +=head1 Unicode Support + =for apidoc sv_recode_to_utf8 The encoding is assumed to be an Encode object, on entry the PV