X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=add445bfef3fbbd9e98fa60689b799a22cd66328;hb=be26652545762cccb4c0118f022cf9d0ec20cf93;hp=7bb1fdd23f1291082138c43391ca6c46ca6afd07;hpb=73b309ea0370472c1b800c9275b2e0d497af6cb3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 7bb1fdd..add445b 100644 --- a/sv.c +++ b/sv.c @@ -1359,6 +1359,7 @@ S_not_a_number(pTHX_ SV *sv) #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */ #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */ #define IS_NUMBER_NEG 0x08 /* not good to cache UV */ +#define IS_NUMBER_INFINITY 0x10 /* this is big */ /* Actually, ISO C leaves conversion of UV to IV undefined, but until proven guilty, assume that things are not that bad... */ @@ -1483,8 +1484,8 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); - SvIVX(sv) = 0; (void)SvIOK_on(sv); + SvIVX(sv) = 0; if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } @@ -1637,10 +1638,10 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); - SvUVX(sv) = 0; /* We assume that 0s have the - same bitmap in IV and UV. */ (void)SvIOK_on(sv); (void)SvIsUV_on(sv); + SvUVX(sv) = 0; /* We assume that 0s have the + same bitmap in IV and UV. */ if (ckWARN(WARN_NUMERIC)) not_a_number(sv); } @@ -1813,6 +1814,7 @@ S_asUV(pTHX_ SV *sv) * IS_NUMBER_TO_INT_BY_ATOL 123 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0 + * IS_NUMBER_INFINITY * with a possible addition of IS_NUMBER_NEG. */ @@ -1833,6 +1835,7 @@ Perl_looks_like_number(pTHX_ SV *sv) register char *sbegin; register char *nbegin; I32 numtype = 0; + I32 sawinf = 0; STRLEN len; if (SvPOK(sv)) { @@ -1862,7 +1865,7 @@ Perl_looks_like_number(pTHX_ SV *sv) * (int)atof(). */ - /* next must be digit or the radix separator */ + /* next must be digit or the radix separator or beginning of infinity */ if (isDIGIT(*s)) { do { s++; @@ -1900,23 +1903,38 @@ Perl_looks_like_number(pTHX_ SV *sv) else return 0; } + else if (*s == 'I' || *s == 'i') { + s++; if (*s != 'N' && *s != 'n') return 0; + s++; if (*s != 'F' && *s != 'f') return 0; + s++; if (*s == 'I' || *s == 'i') { + s++; if (*s != 'N' && *s != 'n') return 0; + s++; if (*s != 'I' && *s != 'i') return 0; + s++; if (*s != 'T' && *s != 't') return 0; + s++; if (*s != 'Y' && *s != 'y') return 0; + } + sawinf = 1; + } else return 0; - /* we can have an optional exponent part */ - if (*s == 'e' || *s == 'E') { - numtype &= ~IS_NUMBER_NEG; - numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; - s++; - if (*s == '+' || *s == '-') + if (sawinf) + numtype = IS_NUMBER_INFINITY; + else { + /* we can have an optional exponent part */ + if (*s == 'e' || *s == 'E') { + numtype &= ~IS_NUMBER_NEG; + numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV; s++; - if (isDIGIT(*s)) { - do { - s++; - } while (isDIGIT(*s)); - } - else - return 0; + if (*s == '+' || *s == '-') + s++; + if (isDIGIT(*s)) { + do { + s++; + } while (isDIGIT(*s)); + } + else + return 0; + } } while (isSPACE(*s)) s++; @@ -1938,11 +1956,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 +2049,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; } @@ -2613,7 +2629,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 +2641,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); @@ -2676,7 +2692,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); @@ -2695,7 +2711,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); @@ -2726,7 +2742,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) if (sflags & SVp_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) + if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } if (SvAMAGIC(sstr)) { @@ -2764,7 +2780,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) SvUTF8_off(dstr); SvTEMP_off(dstr); - (void)SvOK_off(sstr); + (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ SvPV_set(sstr, Nullch); SvLEN_set(sstr, 0); SvCUR_set(sstr, 0); @@ -2789,25 +2805,25 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) if (sflags & SVp_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) + if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } } else if (sflags & SVp_NOK) { SvNVX(dstr) = SvNVX(sstr); (void)SvNOK_only(dstr); - if (SvIOK(sstr)) { + if (sflags & SVf_IOK) { (void)SvIOK_on(dstr); SvIVX(dstr) = SvIVX(sstr); /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ - if (SvIsUV(sstr)) + if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } } else if (sflags & SVp_IOK) { (void)SvIOK_only(dstr); SvIVX(dstr) = SvIVX(sstr); - if (SvIsUV(sstr)) + if (sflags & SVf_IVisUV) SvIsUV_on(dstr); } else { @@ -3091,7 +3107,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 +3518,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); @@ -3922,10 +3938,19 @@ Perl_sv_eq(pTHX_ register SV *str1, register SV *str2) else pv1 = SvPV(str1, cur1); - if (!str2) - return !cur1; - else - pv2 = SvPV(str2, cur2); + if (cur1) { + if (!str2) + return 0; + if (SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) { + if (SvUTF8(str1)) { + sv_utf8_upgrade(str2); + } + else { + sv_utf8_upgrade(str1); + } + } + } + pv2 = SvPV(str2, cur2); if (cur1 != cur2) return 0; @@ -3949,7 +3974,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 +4770,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 +5214,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 +5515,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; @@ -5812,6 +5856,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV 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; @@ -5824,6 +5870,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV 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; @@ -6031,7 +6082,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; switch (intsize) { case 'h': iv = (short)iv; break; - default: iv = (int)iv; break; + default: break; case 'l': iv = (long)iv; break; case 'V': break; #ifdef HAS_QUAD @@ -6113,7 +6164,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0; switch (intsize) { case 'h': uv = (unsigned short)uv; break; - default: uv = (unsigned)uv; break; + default: break; case 'l': uv = (unsigned long)uv; break; case 'V': break; #ifdef HAS_QUAD @@ -6230,8 +6281,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) { @@ -6377,10 +6429,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 @@ -6609,9 +6657,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) @@ -6846,7 +6891,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); @@ -6975,6 +7019,9 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) ncx->blk_loop.iterdata = (CxPADLOOP(cx) ? cx->blk_loop.iterdata : gv_dup((GV*)cx->blk_loop.iterdata)); + ncx->blk_loop.oldcurpad + = (SV**)ptr_table_fetch(PL_ptr_table, + cx->blk_loop.oldcurpad); ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave); ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval); ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary); @@ -7086,6 +7133,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) char *c; void (*dptr) (void*); void (*dxptr) (pTHXo_ void*); + OP *o; Newz(54, nss, max, ANY); @@ -7212,7 +7260,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) case OP_LEAVE: case OP_SCOPE: case OP_LEAVEWRITE: - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + TOPPTR(nss,ix) = ptr; + o = (OP*)ptr; + OpREFCNT_inc(o); break; default: TOPPTR(nss,ix) = Nullop; @@ -7333,8 +7383,6 @@ 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); @@ -7366,8 +7414,6 @@ 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_THX(my_perl); @@ -7559,7 +7605,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_main_cv = cv_dup_inc(proto_perl->Imain_cv); PL_main_root = OpREFCNT_inc(proto_perl->Imain_root); PL_main_start = proto_perl->Imain_start; - PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root); + PL_eval_root = proto_perl->Ieval_root; PL_eval_start = proto_perl->Ieval_start; /* runtime control stuff */ @@ -7837,6 +7883,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } else { init_stacks(); + ENTER; /* perl_destruct() wants to LEAVE; */ } PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ @@ -8010,10 +8057,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);