X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=4352fd4e792fcde1035e7568c0f1f9939089caf9;hb=b2f04286ef15827d0776b081ebcb4c3b2e0c0a52;hp=76481dcbad6d6472e34eb82959df2365995ded56;hpb=6fa402ec5b578488e91e8f7d99060bcd035f4979;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 76481dc..4352fd4 100644 --- a/sv.c +++ b/sv.c @@ -1486,195 +1486,6 @@ S_not_a_number(pTHX_ SV *sv) "Argument \"%s\" isn't numeric", tmpbuf); } -#define IS_NUMBER_IN_UV 0x01 /* number within UV range (maybe not - int). value returned in pointed- - to UV */ -#define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 /* pointed to UV undefined */ -#define IS_NUMBER_NOT_INT 0x04 /* saw . or E notation */ -#define IS_NUMBER_NEG 0x08 /* leading minus sign */ -#define IS_NUMBER_INFINITY 0x10 /* this is big */ - -static int -S_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep) -{ - const char *s = pv; - const char *send = pv + len; - const UV max_div_10 = UV_MAX / 10; - const char max_mod_10 = UV_MAX % 10 + '0'; - int numtype = 0; - int sawinf = 0; -#ifdef USE_LOCALE_NUMERIC - bool specialradix = FALSE; -#endif - - while (isSPACE(*s)) - s++; - if (*s == '-') { - s++; - numtype = IS_NUMBER_NEG; - } - else if (*s == '+') - s++; - - /* next must be digit or the radix separator or beginning of infinity */ - if (isDIGIT(*s)) { - /* UVs are at least 32 bits, so the first 9 decimal digits cannot - overflow. */ - UV value = *s - '0'; - /* This construction seems to be more optimiser friendly. - (without it gcc does the isDIGIT test and the *s - '0' separately) - With it gcc on arm is managing 6 instructions (6 cycles) per digit. - In theory the optimiser could deduce how far to unroll the loop - before checking for overflow. */ - int digit = *++s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - digit = *++s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - digit = *++s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - digit = *++s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - digit = *++s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - digit = *++s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - digit = *++s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - digit = *++s - '0'; - if (digit >= 0 && digit <= 9) { - value = value * 10 + digit; - /* Now got 9 digits, so need to check - each time for overflow. */ - digit = *++s - '0'; - while (digit >= 0 && digit <= 9 - && (value < max_div_10 - || (value == max_div_10 - && *s <= max_mod_10))) { - value = value * 10 + digit; - digit = *++s - '0'; - } - if (digit >= 0 && digit <= 9) { - /* value overflowed. - skip the remaining digits, don't - worry about setting *valuep. */ - do { - s++; - } while (isDIGIT(*s)); - numtype |= - IS_NUMBER_GREATER_THAN_UV_MAX; - goto skip_value; - } - } - } - } - } - } - } - } - } - numtype |= IS_NUMBER_IN_UV; - if (valuep) - *valuep = value; - - skip_value: - if ( -#ifdef USE_LOCALE_NUMERIC - (specialradix = IS_NUMERIC_RADIX(s, send)) || -#endif - *s == '.') { -#ifdef USE_LOCALE_NUMERIC - if (specialradix) - s += SvCUR(PL_numeric_radix_sv); - else -#endif - s++; - numtype |= IS_NUMBER_NOT_INT; - while (isDIGIT(*s)) /* optional digits after the radix */ - s++; - } - } - else if ( -#ifdef USE_LOCALE_NUMERIC - (specialradix = IS_NUMERIC_RADIX(s, send)) || -#endif - *s == '.' - ) { -#ifdef USE_LOCALE_NUMERIC - if (specialradix) - s += SvCUR(PL_numeric_radix_sv); - else -#endif - s++; - numtype |= IS_NUMBER_NOT_INT; - /* no digits before the radix means we need digits after it */ - if (isDIGIT(*s)) { - do { - s++; - } while (isDIGIT(*s)); - numtype |= IS_NUMBER_IN_UV; - if (valuep) { - /* integer approximation is valid - it's 0. */ - *valuep = 0; - } - } - 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; - s++; - } - sawinf = 1; - } - else /* Add test for NaN here. */ - return 0; - - if (sawinf) { - numtype &= IS_NUMBER_NEG; /* Keep track of sign */ - numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT; - } else { - /* we can have an optional exponent part */ - if (*s == 'e' || *s == 'E') { - /* The only flag we keep is sign. Blow away any "it's UV" */ - numtype &= IS_NUMBER_NEG; - numtype |= IS_NUMBER_NOT_INT; - s++; - if (*s == '-' || *s == '+') - s++; - if (isDIGIT(*s)) { - do { - s++; - } while (isDIGIT(*s)); - } - else - return 0; - } - } - while (isSPACE(*s)) - s++; - if (s >= send) - return numtype; - if (len == 10 && memEQ(pv, "0 but true", 10)) { - if (valuep) - *valuep = 0; - return IS_NUMBER_IN_UV; - } - return 0; -} - /* =for apidoc looks_like_number @@ -2070,6 +1881,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) /* The IV slot will have been set from value returned by grok_number above. The NV slot has just been set using Atof. */ + SvNOK_on(sv); assert (SvIOKp(sv)); } else { if (((UV)1 << NV_PRESERVES_UV_BITS) > @@ -2346,6 +2158,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) /* The UV slot will have been set from value returned by grok_number above. The NV slot has just been set using Atof. */ + SvNOK_on(sv); assert (SvIOKp(sv)); } else { if (((UV)1 << NV_PRESERVES_UV_BITS) > @@ -2435,7 +2248,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) sv_upgrade(sv, SVt_PVNV); else sv_upgrade(sv, SVt_NV); -#if defined(USE_LONG_DOUBLE) +#ifdef USE_LONG_DOUBLE DEBUG_c({ STORE_NUMERIC_LOCAL_SET_STANDARD(); PerlIO_printf(Perl_debug_log, @@ -2457,10 +2270,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) { SvNOK_on(sv); } - else if (SvIOKp(sv) && - (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || /* XXX check this logic */ - !grok_number(SvPVX(sv), SvCUR(sv),NULL))) - { + else if (SvIOKp(sv)) { SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv); #ifdef NV_PRESERVES_UV SvNOK_on(sv); @@ -3405,12 +3215,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) #endif if (intro) { - GP *gp; - gp_free((GV*)dstr); GvINTRO_off(dstr); /* one-shot flag */ - Newz(602,gp, 1, GP); - GvGP(dstr) = gp_ref(gp); - GvSV(dstr) = NEWSV(72,0); GvLINE(dstr) = CopLINE(PL_curcop); GvEGV(dstr) = (GV*)dstr; } @@ -8354,6 +8159,11 @@ Perl_sv_dup(pTHX_ SV *sstr) } HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */ HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr)); + /* If HvNAME() is set hv _may_ be a stash + - record it for possible callback + */ + if(HvNAME((HV*)dstr)) + av_push(PL_clone_callbacks, dstr); break; case SVt_PVFM: SvANY(dstr) = new_XPVFM(); @@ -8988,6 +8798,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, while (i-- > 0) { PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]); } + PL_clone_callbacks = newAV(); /* Setup array of objects to callbackon */ PL_envgv = gv_dup(proto_perl->Ienvgv); PL_incgv = gv_dup(proto_perl->Iincgv); PL_hintgv = gv_dup(proto_perl->Ihintgv); @@ -9498,6 +9309,29 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; } + + /* For the (possible) stashes identified above + - check that they are stashes + - if they are see if the ->CLONE method is defined + - if it is call it + */ + while(av_len(PL_clone_callbacks) != -1) { + HV* stash = (HV*) av_shift(PL_clone_callbacks); + if (gv_stashpv(HvNAME(stash),0)) { + GV* cloner = gv_fetchmethod_autoload(stash,"CLONE",0); + if (cloner && GvCV(cloner)) { + dSP; + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(newSVpv(HvNAME(stash),0)); + PUTBACK; + call_sv((SV*)GvCV(cloner), G_DISCARD); + FREETMPS; + LEAVE; + } + } + } #ifdef PERL_OBJECT return (PerlInterpreter*)pPerl;