X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9a54186f86fa89533f9a21879513bc2ce58df609..d57b1ce7265517b8de654c83dd85f8a9389ca311:/sv.c diff --git a/sv.c b/sv.c index 52bf820..f6f49d2 100644 --- a/sv.c +++ b/sv.c @@ -107,7 +107,7 @@ Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) SV* sva = (SV*)ptr; register SV* sv; register SV* svend; - Zero(sva, size, char); + Zero(ptr, size, char); /* The first SV in an arena isn't an SV. */ SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ @@ -1938,11 +1938,9 @@ Perl_sv_2pv_nolen(pTHX_ register SV *sv) static char * uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) { - STRLEN len; char *ptr = buf + TYPE_CHARS(UV); char *ebuf = ptr; int sign; - char *p; if (is_uv) sign = 0; @@ -2033,7 +2031,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) int right = 4; U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12; - while(ch = *fptr++) { + while((ch = *fptr++)) { if(reganch & 1) { reflags[left++] = ch; } @@ -2327,7 +2325,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) while (c < SvEND(sv)) { if (*c & 0x80) { I32 len; - UV uv = utf8_to_uv(c, &len); + UV uv = utf8_to_uv((U8*)c, &len); if (uv >= 256) { if (fail_ok) return FALSE; @@ -2351,7 +2349,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) while (src < SvEND(sv)) { if (*src & 0x80) { I32 len; - U8 u = (U8)utf8_to_uv(src, &len); + U8 u = (U8)utf8_to_uv((U8*)src, &len); *dst++ = u; src += len; } @@ -2613,7 +2611,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) else dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; - if (GvIMPORTED_AV_off(dstr) + if (!GvIMPORTED_AV(dstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_AV_on(dstr); @@ -2625,7 +2623,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) else dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; - if (GvIMPORTED_HV_off(dstr) + if (!GvIMPORTED_HV(dstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_HV_on(dstr); @@ -2662,16 +2660,11 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", GvENAME((GV*)dstr)); - if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) { - if (!(CvGV(cv) && GvSTASH(CvGV(cv)) - && HvNAME(GvSTASH(CvGV(cv))) - && strEQ(HvNAME(GvSTASH(CvGV(cv))), - "autouse"))) - Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? + if ((const_changed || const_sv) && ckWARN(WARN_REDEFINE)) + Perl_warner(aTHX_ WARN_REDEFINE, const_sv ? "Constant subroutine %s redefined" : "Subroutine %s redefined", GvENAME((GV*)dstr)); - } } cv_ckproto(cv, (GV*)dstr, SvPOK(sref) ? SvPVX(sref) : Nullch); @@ -2681,7 +2674,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) GvASSUMECV_on(dstr); PL_sub_generation++; } - if (GvIMPORTED_CV_off(dstr) + if (!GvIMPORTED_CV(dstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_CV_on(dstr); @@ -2700,7 +2693,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) else dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; - if (GvIMPORTED_SV_off(dstr) + if (!GvIMPORTED_SV(dstr) && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_SV_on(dstr); @@ -2763,6 +2756,11 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) SvPV_set(dstr, SvPVX(sstr)); SvLEN_set(dstr, SvLEN(sstr)); SvCUR_set(dstr, SvCUR(sstr)); + if (SvUTF8(sstr)) + SvUTF8_on(dstr); + else + SvUTF8_off(dstr); + SvTEMP_off(dstr); (void)SvOK_off(sstr); SvPV_set(sstr, Nullch); @@ -2812,8 +2810,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) } else { if (dtype == SVt_PVGV) { - if (ckWARN(WARN_UNSAFE)) - Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob"); + if (ckWARN(WARN_MISC)) + Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob"); } else (void)SvOK_off(dstr); @@ -3091,7 +3089,7 @@ Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) STRLEN len; if (!sstr) return; - if (s = SvPV(sstr, len)) { + if ((s = SvPV(sstr, len))) { if (SvUTF8(sstr)) sv_utf8_upgrade(dstr); sv_catpvn(dstr,s,len); @@ -3502,7 +3500,7 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN SvCUR_set(bigstr, mid - big); } /*SUPPRESS 560*/ - else if (i = mid - big) { /* faster from front */ + else if ((i = mid - big)) { /* faster from front */ midend -= littlelen; mid = midend; sv_chop(bigstr,midend-i); @@ -3949,7 +3947,6 @@ Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2) STRLEN cur1, cur2; char *pv1, *pv2; I32 retval; - bool utf1; if (str1) { pv1 = SvPV(str1, cur1); @@ -4746,6 +4743,25 @@ Perl_newSViv(pTHX_ IV i) } /* +=for apidoc newSVuv + +Creates a new SV and copies an unsigned integer into it. +The reference count for the SV is set to 1. + +=cut +*/ + +SV * +Perl_newSVuv(pTHX_ UV u) +{ + register SV *sv; + + new_SV(sv); + sv_setuv(sv,u); + return sv; +} + +/* =for apidoc newRV_noinc Creates an RV wrapper for an SV. The reference count for the original @@ -5171,6 +5187,7 @@ Perl_sv_reftype(pTHX_ SV *sv, int ob) case SVt_PVCV: return "CODE"; case SVt_PVGV: return "GLOB"; case SVt_PVFM: return "FORMAT"; + case SVt_PVIO: return "IO"; default: return "UNKNOWN"; } } @@ -5471,7 +5488,7 @@ Perl_sv_tainted(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC *mg = mg_find(sv, 't'); - if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv)) + if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv))) return TRUE; } return FALSE; @@ -5734,6 +5751,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV for (p = (char*)pat; p < patend; p = q) { bool alt = FALSE; bool left = FALSE; + bool vectorize = FALSE; + bool utf = FALSE; char fill = ' '; char plus = 0; char intsize = 0; @@ -5744,7 +5763,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV bool is_utf = FALSE; char esignbuf[4]; - U8 utf8buf[10]; + U8 utf8buf[UTF8_MAXLEN]; STRLEN esignlen = 0; char *eptr = Nullch; @@ -5755,6 +5774,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV char ebuf[IV_DIG * 4 + NV_DIG + 32]; /* large enough for "%#.#f" --chip */ /* what about long double NVs? --jhi */ + + SV *vecsv; + U8 *vecstr = Null(U8*); + STRLEN veclen = 0; char c; int i; unsigned base; @@ -5764,6 +5787,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN have; STRLEN need; STRLEN gap; + char *dotstr = "."; + STRLEN dotstrlen = 1; for (q = p; q < patend && *q != '%'; ++q) ; if (q > p) { @@ -5796,6 +5821,37 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV q++; continue; + case '*': /* printf("%*vX",":",$ipv6addr) */ + if (q[1] != 'v') + break; + q++; + if (args) + vecsv = va_arg(*args, SV*); + else if (svix < svmax) + vecsv = svargs[svix++]; + else + continue; + dotstr = SvPVx(vecsv,dotstrlen); + if (DO_UTF8(vecsv)) + is_utf = TRUE; + /* FALL THROUGH */ + + case 'v': + vectorize = TRUE; + q++; + if (args) + vecsv = va_arg(*args, SV*); + else if (svix < svmax) + vecsv = svargs[svix++]; + else { + vecstr = (U8*)""; + veclen = 0; + continue; + } + vecstr = (U8*)SvPVx(vecsv,veclen); + utf = DO_UTF8(vecsv); + continue; + default: break; } @@ -5931,63 +5987,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } goto string; - case 'v': - if (args) - argsv = va_arg(*args, SV*); - else if (svix < svmax) - argsv = svargs[svix++]; - { - STRLEN len; - U8 *str = (U8*)SvPVx(argsv,len); - I32 vlen = len*3+1; - SV *vsv = NEWSV(73,vlen); - I32 ulen; - I32 vfree = vlen; - U8 *vptr = (U8*)SvPVX(vsv); - STRLEN vcur = 0; - bool utf = DO_UTF8(argsv); - - if (utf) - is_utf = TRUE; - while (len) { - UV uv; - - if (utf) - uv = utf8_to_uv(str, &ulen); - else { - uv = *str; - ulen = 1; - } - str += ulen; - len -= ulen; - eptr = ebuf + sizeof ebuf; - do { - *--eptr = '0' + uv % 10; - } while (uv /= 10); - elen = (ebuf + sizeof ebuf) - eptr; - while (elen >= vfree-1) { - STRLEN off = vptr - (U8*)SvPVX(vsv); - vfree += vlen; - vlen *= 2; - SvGROW(vsv, vlen); - vptr = (U8*)SvPVX(vsv) + off; - } - memcpy(vptr, eptr, elen); - vptr += elen; - *vptr++ = '.'; - vfree -= elen + 1; - vcur += elen + 1; - } - if (vcur) { - vcur--; - vptr[-1] = '\0'; - } - SvCUR_set(vsv,vcur); - eptr = SvPVX(vsv); - elen = vcur; - } - goto string; - case '_': /* * The "%_" hack might have to be changed someday, @@ -6002,6 +6001,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV is_utf = TRUE; string: + vectorize = FALSE; if (has_precis && elen > precis) elen = precis; break; @@ -6025,7 +6025,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* FALL THROUGH */ case 'd': case 'i': - if (args) { + if (vectorize) { + I32 ulen; + if (!veclen) { + vectorize = FALSE; + break; + } + if (utf) + iv = (IV)utf8_to_uv(vecstr, &ulen); + else { + iv = *vecstr; + ulen = 1; + } + vecstr += ulen; + veclen -= ulen; + } + else if (args) { switch (intsize) { case 'h': iv = (short)va_arg(*args, int); break; default: iv = va_arg(*args, int); break; @@ -6091,7 +6106,23 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV base = 16; uns_integer: - if (args) { + if (vectorize) { + I32 ulen; + vector: + if (!veclen) { + vectorize = FALSE; + break; + } + if (utf) + uv = utf8_to_uv(vecstr, &ulen); + else { + uv = *vecstr; + ulen = 1; + } + vecstr += ulen; + veclen -= ulen; + } + else if (args) { switch (intsize) { case 'h': uv = (unsigned short)va_arg(*args, unsigned); break; default: uv = va_arg(*args, unsigned); break; @@ -6153,13 +6184,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV break; default: /* it had better be ten or less */ #if defined(PERL_Y2KWARN) - if (ckWARN(WARN_MISC)) { + if (ckWARN(WARN_Y2K)) { STRLEN n; char *s = SvPV(sv,n); if (n >= 2 && s[n-2] == '1' && s[n-1] == '9' && (n == 2 || !isDIGIT(s[n-3]))) { - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ WARN_Y2K, "Possible Y2K bug: %%%c %s", c, "format string following '19'"); } @@ -6191,6 +6222,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* This is evil, but floating point is even more evil */ + vectorize = FALSE; if (args) nv = va_arg(*args, NV); else @@ -6199,7 +6231,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV need = 0; if (c != 'e' && c != 'E') { i = PERL_INT_MIN; - (void)frexp(nv, &i); + (void)Perl_frexp(nv, &i); if (i == PERL_INT_MIN) Perl_die(aTHX_ "panic: frexp"); if (i > 0) @@ -6222,8 +6254,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *--eptr = c; #ifdef USE_LONG_DOUBLE { - char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3; - while (p >= PERL_PRIfldbl) { *--eptr = *p--; } + static char const my_prifldbl[] = PERL_PRIfldbl; + char const *p = my_prifldbl + sizeof my_prifldbl - 3; + while (p >= my_prifldbl) { *--eptr = *p--; } } #endif if (has_precis) { @@ -6258,6 +6291,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* SPECIAL */ case 'n': + vectorize = FALSE; i = SvCUR(sv) - origlen; if (args) { switch (intsize) { @@ -6278,6 +6312,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: unknown: + vectorize = FALSE; if (!args && ckWARN(WARN_PRINTF) && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) { SV *msg = sv_newmortal(); @@ -6316,7 +6351,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV need = (have > width ? have : width); gap = need - have; - SvGROW(sv, SvCUR(sv) + need + 1); + SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); p = SvEND(sv); if (esignlen && fill == '0') { for (i = 0; i < esignlen; i++) @@ -6342,10 +6377,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV memset(p, ' ', gap); p += gap; } + if (vectorize) { + if (veclen) { + memcpy(p, dotstr, dotstrlen); + p += dotstrlen; + } + else + vectorize = FALSE; /* done iterating over vecstr */ + } if (is_utf) SvUTF8_on(sv); *p = '\0'; SvCUR(sv) = p - SvPVX(sv); + if (vectorize) { + esignlen = 0; + goto vector; + } } } @@ -6355,10 +6402,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV # include "error: USE_THREADS and USE_ITHREADS are incompatible" #endif -#ifndef OpREFCNT_inc -# define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop) -#endif - #ifndef GpREFCNT_inc # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL) #endif @@ -6587,9 +6630,6 @@ char *PL_watch_pvx; SV * Perl_sv_dup(pTHX_ SV *sstr) { - U32 sflags; - int dtype; - int stype; SV *dstr; if (!sstr || SvTYPE(sstr) == SVTYPEMASK) @@ -6824,7 +6864,6 @@ Perl_sv_dup(pTHX_ SV *sstr) SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); HvRITER((HV*)dstr) = HvRITER((HV*)sstr); if (HvARRAY((HV*)sstr)) { - HE *entry; STRLEN i = 0; XPVHV *dxhv = (XPVHV*)SvANY(dstr); XPVHV *sxhv = (XPVHV*)SvANY(sstr); @@ -7220,13 +7259,13 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ dptr = POPDPTR(ss,ix); - TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl); + TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl); break; case SAVEt_DESTRUCTOR_X: ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ dxptr = POPDXPTR(ss,ix); - TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl); + TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl); break; case SAVEt_REGCONTEXT: case SAVEt_ALLOC: @@ -7311,15 +7350,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * their pointers copied. */ IV i; - SV *sv; - SV **svp; # ifdef PERL_OBJECT CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO, ipD, ipS, ipP); - PERL_SET_INTERP(pPerl); + PERL_SET_THX(pPerl); # else /* !PERL_OBJECT */ PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); - PERL_SET_INTERP(my_perl); + PERL_SET_THX(my_perl); # ifdef DEBUGGING memset(my_perl, 0xab, sizeof(PerlInterpreter)); @@ -7344,10 +7381,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, # endif /* PERL_OBJECT */ #else /* !PERL_IMPLICIT_SYS */ IV i; - SV *sv; - SV **svp; PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); - PERL_SET_INTERP(my_perl); + PERL_SET_THX(my_perl); # ifdef DEBUGGING memset(my_perl, 0xab, sizeof(PerlInterpreter)); @@ -7853,7 +7888,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_dirty = proto_perl->Tdirty; PL_localizing = proto_perl->Tlocalizing; +#ifdef PERL_FLEXIBLE_EXCEPTIONS PL_protect = proto_perl->Tprotect; +#endif PL_errors = sv_dup_inc(proto_perl->Terrors); PL_av_fetch_sv = Nullsv; PL_hv_fetch_sv = Nullsv; @@ -7986,10 +8023,10 @@ do_clean_named_objs(pTHXo_ SV *sv) { if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { if ( SvOBJECT(GvSV(sv)) || - GvAV(sv) && SvOBJECT(GvAV(sv)) || - GvHV(sv) && SvOBJECT(GvHV(sv)) || - GvIO(sv) && SvOBJECT(GvIO(sv)) || - GvCV(sv) && SvOBJECT(GvCV(sv)) ) + (GvAV(sv) && SvOBJECT(GvAV(sv))) || + (GvHV(sv) && SvOBJECT(GvHV(sv))) || + (GvIO(sv) && SvOBJECT(GvIO(sv))) || + (GvCV(sv) && SvOBJECT(GvCV(sv))) ) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));) SvREFCNT_dec(sv);