X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=add445bfef3fbbd9e98fa60689b799a22cd66328;hb=be26652545762cccb4c0118f022cf9d0ec20cf93;hp=0b838a1a16eaace3dcce55a851e9833897c6a3cb;hpb=146174a91a192983720a158796dc066226ad0e55;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 0b838a1..add445b 100644 --- a/sv.c +++ b/sv.c @@ -1,6 +1,6 @@ /* sv.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -25,105 +25,6 @@ static void do_clean_named_objs(pTHXo_ SV *sv); #endif static void do_clean_all(pTHXo_ SV *sv); - -#ifdef PURIFY - -#define new_SV(p) \ - STMT_START { \ - LOCK_SV_MUTEX; \ - (p) = (SV*)safemalloc(sizeof(SV)); \ - reg_add(p); \ - UNLOCK_SV_MUTEX; \ - SvANY(p) = 0; \ - SvREFCNT(p) = 1; \ - SvFLAGS(p) = 0; \ - } STMT_END - -#define del_SV(p) \ - STMT_START { \ - LOCK_SV_MUTEX; \ - reg_remove(p); \ - Safefree((char*)(p)); \ - UNLOCK_SV_MUTEX; \ - } STMT_END - -static SV **registry; -static I32 registry_size; - -#define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size)) - -#define REG_REPLACE(sv,a,b) \ - STMT_START { \ - void* p = sv->sv_any; \ - I32 h = REGHASH(sv, registry_size); \ - I32 i = h; \ - while (registry[i] != (a)) { \ - if (++i >= registry_size) \ - i = 0; \ - if (i == h) \ - Perl_die(aTHX_ "SV registry bug"); \ - } \ - registry[i] = (b); \ - } STMT_END - -#define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv) -#define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv) - -STATIC void -S_reg_add(pTHX_ SV *sv) -{ - if (PL_sv_count >= (registry_size >> 1)) - { - SV **oldreg = registry; - I32 oldsize = registry_size; - - registry_size = registry_size ? ((registry_size << 2) + 1) : 2037; - Newz(707, registry, registry_size, SV*); - - if (oldreg) { - I32 i; - - for (i = 0; i < oldsize; ++i) { - SV* oldsv = oldreg[i]; - if (oldsv) - REG_ADD(oldsv); - } - Safefree(oldreg); - } - } - - REG_ADD(sv); - ++PL_sv_count; -} - -STATIC void -S_reg_remove(pTHX_ SV *sv) -{ - REG_REMOVE(sv); - --PL_sv_count; -} - -STATIC void -S_visit(pTHX_ SVFUNC_t f) -{ - I32 i; - - for (i = 0; i < registry_size; ++i) { - SV* sv = registry[i]; - if (sv && SvTYPE(sv) != SVTYPEMASK) - (*f)(sv); - } -} - -void -Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) -{ - if (!(flags & SVf_FAKE)) - Safefree(ptr); -} - -#else /* ! PURIFY */ - /* * "A time to plant, and a time to uproot what was planted..." */ @@ -206,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 */ @@ -262,8 +163,6 @@ S_visit(pTHX_ SVFUNC_t f) } } -#endif /* PURIFY */ - void Perl_sv_report_used(pTHX) { @@ -801,125 +700,109 @@ S_more_xpvbm(pTHX) xpvbm->xpv_pv = 0; } -#ifdef PURIFY -#define new_XIV() (void*)safemalloc(sizeof(XPVIV)) -#define del_XIV(p) Safefree((char*)p) +#ifdef LEAKTEST +# define my_safemalloc(s) (void*)safexmalloc(717,s) +# define my_safefree(p) safexfree((char*)p) #else -#define new_XIV() (void*)new_xiv() -#define del_XIV(p) del_xiv((XPVIV*) p) +# define my_safemalloc(s) (void*)safemalloc(s) +# define my_safefree(p) safefree((char*)p) #endif #ifdef PURIFY -#define new_XNV() (void*)safemalloc(sizeof(XPVNV)) -#define del_XNV(p) Safefree((char*)p) -#else -#define new_XNV() (void*)new_xnv() -#define del_XNV(p) del_xnv((XPVNV*) p) -#endif -#ifdef PURIFY -#define new_XRV() (void*)safemalloc(sizeof(XRV)) -#define del_XRV(p) Safefree((char*)p) -#else -#define new_XRV() (void*)new_xrv() -#define del_XRV(p) del_xrv((XRV*) p) -#endif +#define new_XIV() my_safemalloc(sizeof(XPVIV)) +#define del_XIV(p) my_safefree(p) -#ifdef PURIFY -#define new_XPV() (void*)safemalloc(sizeof(XPV)) -#define del_XPV(p) Safefree((char*)p) -#else -#define new_XPV() (void*)new_xpv() -#define del_XPV(p) del_xpv((XPV *)p) -#endif +#define new_XNV() my_safemalloc(sizeof(XPVNV)) +#define del_XNV(p) my_safefree(p) -#ifdef PURIFY -# define my_safemalloc(s) safemalloc(s) -# define my_safefree(s) safefree(s) -#else -STATIC void* -S_my_safemalloc(MEM_SIZE size) -{ - char *p; - New(717, p, size, char); - return (void*)p; -} -# define my_safefree(s) Safefree(s) -#endif +#define new_XRV() my_safemalloc(sizeof(XRV)) +#define del_XRV(p) my_safefree(p) -#ifdef PURIFY -#define new_XPVIV() (void*)safemalloc(sizeof(XPVIV)) -#define del_XPVIV(p) Safefree((char*)p) -#else -#define new_XPVIV() (void*)new_xpviv() -#define del_XPVIV(p) del_xpviv((XPVIV *)p) -#endif - -#ifdef PURIFY -#define new_XPVNV() (void*)safemalloc(sizeof(XPVNV)) -#define del_XPVNV(p) Safefree((char*)p) -#else -#define new_XPVNV() (void*)new_xpvnv() -#define del_XPVNV(p) del_xpvnv((XPVNV *)p) -#endif +#define new_XPV() my_safemalloc(sizeof(XPV)) +#define del_XPV(p) my_safefree(p) +#define new_XPVIV() my_safemalloc(sizeof(XPVIV)) +#define del_XPVIV(p) my_safefree(p) -#ifdef PURIFY -#define new_XPVCV() (void*)safemalloc(sizeof(XPVCV)) -#define del_XPVCV(p) Safefree((char*)p) -#else -#define new_XPVCV() (void*)new_xpvcv() -#define del_XPVCV(p) del_xpvcv((XPVCV *)p) -#endif +#define new_XPVNV() my_safemalloc(sizeof(XPVNV)) +#define del_XPVNV(p) my_safefree(p) -#ifdef PURIFY -#define new_XPVAV() (void*)safemalloc(sizeof(XPVAV)) -#define del_XPVAV(p) Safefree((char*)p) -#else -#define new_XPVAV() (void*)new_xpvav() -#define del_XPVAV(p) del_xpvav((XPVAV *)p) -#endif +#define new_XPVCV() my_safemalloc(sizeof(XPVCV)) +#define del_XPVCV(p) my_safefree(p) -#ifdef PURIFY -#define new_XPVHV() (void*)safemalloc(sizeof(XPVHV)) -#define del_XPVHV(p) Safefree((char*)p) -#else -#define new_XPVHV() (void*)new_xpvhv() -#define del_XPVHV(p) del_xpvhv((XPVHV *)p) -#endif - -#ifdef PURIFY -#define new_XPVMG() (void*)safemalloc(sizeof(XPVMG)) -#define del_XPVMG(p) Safefree((char*)p) -#else -#define new_XPVMG() (void*)new_xpvmg() -#define del_XPVMG(p) del_xpvmg((XPVMG *)p) -#endif - -#ifdef PURIFY -#define new_XPVLV() (void*)safemalloc(sizeof(XPVLV)) -#define del_XPVLV(p) Safefree((char*)p) -#else -#define new_XPVLV() (void*)new_xpvlv() -#define del_XPVLV(p) del_xpvlv((XPVLV *)p) -#endif - -#define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV)) -#define del_XPVGV(p) my_safefree((char*)p) +#define new_XPVAV() my_safemalloc(sizeof(XPVAV)) +#define del_XPVAV(p) my_safefree(p) + +#define new_XPVHV() my_safemalloc(sizeof(XPVHV)) +#define del_XPVHV(p) my_safefree(p) -#ifdef PURIFY -#define new_XPVBM() (void*)safemalloc(sizeof(XPVBM)) -#define del_XPVBM(p) Safefree((char*)p) -#else -#define new_XPVBM() (void*)new_xpvbm() -#define del_XPVBM(p) del_xpvbm((XPVBM *)p) -#endif +#define new_XPVMG() my_safemalloc(sizeof(XPVMG)) +#define del_XPVMG(p) my_safefree(p) + +#define new_XPVLV() my_safemalloc(sizeof(XPVLV)) +#define del_XPVLV(p) my_safefree(p) + +#define new_XPVBM() my_safemalloc(sizeof(XPVBM)) +#define del_XPVBM(p) my_safefree(p) + +#else /* !PURIFY */ + +#define new_XIV() (void*)new_xiv() +#define del_XIV(p) del_xiv((XPVIV*) p) + +#define new_XNV() (void*)new_xnv() +#define del_XNV(p) del_xnv((XPVNV*) p) + +#define new_XRV() (void*)new_xrv() +#define del_XRV(p) del_xrv((XRV*) p) + +#define new_XPV() (void*)new_xpv() +#define del_XPV(p) del_xpv((XPV *)p) + +#define new_XPVIV() (void*)new_xpviv() +#define del_XPVIV(p) del_xpviv((XPVIV *)p) + +#define new_XPVNV() (void*)new_xpvnv() +#define del_XPVNV(p) del_xpvnv((XPVNV *)p) + +#define new_XPVCV() (void*)new_xpvcv() +#define del_XPVCV(p) del_xpvcv((XPVCV *)p) + +#define new_XPVAV() (void*)new_xpvav() +#define del_XPVAV(p) del_xpvav((XPVAV *)p) + +#define new_XPVHV() (void*)new_xpvhv() +#define del_XPVHV(p) del_xpvhv((XPVHV *)p) -#define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM)) -#define del_XPVFM(p) my_safefree((char*)p) +#define new_XPVMG() (void*)new_xpvmg() +#define del_XPVMG(p) del_xpvmg((XPVMG *)p) + +#define new_XPVLV() (void*)new_xpvlv() +#define del_XPVLV(p) del_xpvlv((XPVLV *)p) + +#define new_XPVBM() (void*)new_xpvbm() +#define del_XPVBM(p) del_xpvbm((XPVBM *)p) + +#endif /* PURIFY */ + +#define new_XPVGV() my_safemalloc(sizeof(XPVGV)) +#define del_XPVGV(p) my_safefree(p) + +#define new_XPVFM() my_safemalloc(sizeof(XPVFM)) +#define del_XPVFM(p) my_safefree(p) -#define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO)) -#define del_XPVIO(p) my_safefree((char*)p) +#define new_XPVIO() my_safemalloc(sizeof(XPVIO)) +#define del_XPVIO(p) my_safefree(p) + +/* +=for apidoc sv_upgrade + +Upgrade an SV to a more complex form. Use C. See +C. + +=cut +*/ bool Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) @@ -1210,6 +1093,16 @@ Perl_sv_backoff(pTHX_ register SV *sv) return 0; } +/* +=for apidoc sv_grow + +Expands the character buffer in the SV. This will use C and will +upgrade the SV to C. Returns a pointer to the character buffer. +Use C. + +=cut +*/ + char * Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) { @@ -1242,7 +1135,7 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) s = SvPVX(sv); if (newlen > SvLEN(sv)) { /* need more room? */ if (SvLEN(sv) && s) { -#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST) +#if defined(MYMALLOC) && !defined(LEAKTEST) STRLEN l = malloced_size((void*)SvPVX(sv)); if (newlen <= l) { SvLEN_set(sv, l); @@ -1259,6 +1152,15 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) return s; } +/* +=for apidoc sv_setiv + +Copies an integer into the given SV. Does not handle 'set' magic. See +C. + +=cut +*/ + void Perl_sv_setiv(pTHX_ register SV *sv, IV i) { @@ -1292,6 +1194,14 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i) SvTAINT(sv); } +/* +=for apidoc sv_setiv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) { @@ -1299,6 +1209,15 @@ Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) SvSETMAGIC(sv); } +/* +=for apidoc sv_setuv + +Copies an unsigned integer into the given SV. Does not handle 'set' magic. +See C. + +=cut +*/ + void Perl_sv_setuv(pTHX_ register SV *sv, UV u) { @@ -1307,6 +1226,14 @@ Perl_sv_setuv(pTHX_ register SV *sv, UV u) SvUVX(sv) = u; } +/* +=for apidoc sv_setuv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) { @@ -1314,6 +1241,15 @@ Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) SvSETMAGIC(sv); } +/* +=for apidoc sv_setnv + +Copies a double into the given SV. Does not handle 'set' magic. See +C. + +=cut +*/ + void Perl_sv_setnv(pTHX_ register SV *sv, NV num) { @@ -1346,6 +1282,14 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num) SvTAINT(sv); } +/* +=for apidoc sv_setnv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) { @@ -1415,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... */ @@ -1539,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); } @@ -1693,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); } @@ -1869,9 +1814,19 @@ 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. */ +/* +=for apidoc looks_like_number + +Test if an the content of an SV looks like a number (or is a +number). + +=cut +*/ + I32 Perl_looks_like_number(pTHX_ SV *sv) { @@ -1880,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)) { @@ -1909,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++; @@ -1947,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++; @@ -1985,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; @@ -2080,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; } @@ -2261,7 +2230,8 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) char * Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) { - return sv_2pv_nolen(sv); + STRLEN n_a; + return sv_2pvbyte(sv, &n_a); } char * @@ -2273,12 +2243,14 @@ Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) char * Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv) { - return sv_2pv_nolen(sv); + STRLEN n_a; + return sv_2pvutf8(sv, &n_a); } char * Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) { + sv_utf8_upgrade(sv); return sv_2pv(sv,lp); } @@ -2320,11 +2292,155 @@ Perl_sv_2bool(pTHX_ register SV *sv) } } +void +Perl_sv_utf8_upgrade(pTHX_ register SV *sv) +{ + int hicount; + char *c; + + if (!sv || !SvPOK(sv) || SvUTF8(sv)) + return; + + /* This function could be much more efficient if we had a FLAG + * to signal if there are any hibit chars in the string + */ + hicount = 0; + for (c = SvPVX(sv); c < SvEND(sv); c++) { + if (*c & 0x80) + hicount++; + } + + if (hicount) { + char *src, *dst; + SvGROW(sv, SvCUR(sv) + hicount + 1); + + src = SvEND(sv) - 1; + SvCUR_set(sv, SvCUR(sv) + hicount); + dst = SvEND(sv) - 1; + + while (src < dst) { + if (*src & 0x80) { + dst--; + uv_to_utf8((U8*)dst, (U8)*src--); + dst--; + } + else { + *dst-- = *src--; + } + } + + SvUTF8_on(sv); + } +} + +bool +Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) +{ + if (SvPOK(sv) && SvUTF8(sv)) { + char *c = SvPVX(sv); + char *first_hi = 0; + /* need to figure out if this is possible at all first */ + while (c < SvEND(sv)) { + if (*c & 0x80) { + I32 len; + UV uv = utf8_to_uv((U8*)c, &len); + if (uv >= 256) { + if (fail_ok) + return FALSE; + else { + /* XXX might want to make a callback here instead */ + Perl_croak(aTHX_ "Big byte"); + } + } + if (!first_hi) + first_hi = c; + c += len; + } + else { + c++; + } + } + + if (first_hi) { + char *src = first_hi; + char *dst = first_hi; + while (src < SvEND(sv)) { + if (*src & 0x80) { + I32 len; + U8 u = (U8)utf8_to_uv((U8*)src, &len); + *dst++ = u; + src += len; + } + else { + *dst++ = *src++; + } + } + SvCUR_set(sv, dst - SvPVX(sv)); + } + SvUTF8_off(sv); + } + return TRUE; +} + +void +Perl_sv_utf8_encode(pTHX_ register SV *sv) +{ + sv_utf8_upgrade(sv); + SvUTF8_off(sv); +} + +bool +Perl_sv_utf8_decode(pTHX_ register SV *sv) +{ + if (SvPOK(sv)) { + char *c; + bool has_utf = FALSE; + if (!sv_utf8_downgrade(sv, TRUE)) + return FALSE; + + /* 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); + while (c < SvEND(sv)) { + if (*c & 0x80) { + I32 len; + (void)utf8_to_uv((U8*)c, &len); + if (len == 1) { + /* bad utf8 */ + return FALSE; + } + c += len; + has_utf = TRUE; + } + else { + c++; + } + } + + if (has_utf) + SvUTF8_on(sv); + } + return TRUE; +} + + /* Note: sv_setsv() should not be called with a source string that needs * to be reused, since it may destroy the source string if it is marked * as temporary. */ +/* +=for apidoc sv_setsv + +Copies the contents of the source SV C into the destination SV C. +The source SV may be destroyed if it is mortal. Does not handle 'set' +magic. See the macro forms C, C and +C. + +=cut +*/ + void Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) { @@ -2513,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); @@ -2525,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); @@ -2562,16 +2678,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); @@ -2581,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); @@ -2600,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); @@ -2631,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)) { @@ -2663,8 +2774,13 @@ 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); + (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */ SvPV_set(sstr, Nullch); SvLEN_set(sstr, 0); SvCUR_set(sstr, 0); @@ -2679,7 +2795,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) *SvEND(dstr) = '\0'; (void)SvPOK_only(dstr); } - if (SvUTF8(sstr)) + if (DO_UTF8(sstr)) SvUTF8_on(dstr); /*SUPPRESS 560*/ if (sflags & SVp_NOK) { @@ -2689,31 +2805,31 @@ 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 { 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); @@ -2721,6 +2837,14 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) SvTAINT(dstr); } +/* +=for apidoc sv_setsv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr) { @@ -2728,6 +2852,15 @@ Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr) SvSETMAGIC(dstr); } +/* +=for apidoc sv_setpvn + +Copies a string into an SV. The C parameter indicates the number of +bytes to be copied. Does not handle 'set' magic. See C. + +=cut +*/ + void Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { @@ -2750,6 +2883,14 @@ Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN SvTAINT(sv); } +/* +=for apidoc sv_setpvn_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { @@ -2757,6 +2898,15 @@ Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRL SvSETMAGIC(sv); } +/* +=for apidoc sv_setpv + +Copies a string into an SV. The string must be null-terminated. Does not +handle 'set' magic. See C. + +=cut +*/ + void Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) { @@ -2777,6 +2927,14 @@ Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) SvTAINT(sv); } +/* +=for apidoc sv_setpv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr) { @@ -2784,6 +2942,20 @@ Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr) SvSETMAGIC(sv); } +/* +=for apidoc sv_usepvn + +Tells an SV to use C to find its string value. Normally the string is +stored inside the SV but sv_usepvn allows the SV to use an outside string. +The C should point to memory that was allocated by C. The +string length, C, must be supplied. This function will realloc the +memory pointed to by C, so that pointer should not be freed or used by +the programmer after giving it to sv_usepvn. Does not handle 'set' magic. +See C. + +=cut +*/ + void Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) { @@ -2805,6 +2977,14 @@ Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len) SvTAINT(sv); } +/* +=for apidoc sv_usepvn_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len) { @@ -2826,6 +3006,17 @@ Perl_sv_force_normal(pTHX_ register SV *sv) sv_unglob(sv); } +/* +=for apidoc sv_chop + +Efficient removal of characters from the beginning of the string buffer. +SvPOK(sv) must be true and the C must be a pointer to somewhere inside +the string buffer. The C becomes the first character of the adjusted +string. + +=cut +*/ + void Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */ @@ -2858,6 +3049,16 @@ Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming SvIVX(sv) += delta; } +/* +=for apidoc sv_catpvn + +Concatenates the string onto the end of the string which is in the SV. The +C indicates number of bytes to copy. Handles 'get' magic, but not +'set' magic. See C. + +=cut +*/ + void Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { @@ -2871,10 +3072,18 @@ Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN Move(ptr,SvPVX(sv)+tlen,len,char); SvCUR(sv) += len; *SvEND(sv) = '\0'; - (void)SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); } +/* +=for apidoc sv_catpvn_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) { @@ -2882,6 +3091,15 @@ Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRL SvSETMAGIC(sv); } +/* +=for apidoc sv_catsv + +Concatenates the string from SV C onto the end of the string in SV +C. Handles 'get' magic, but not 'set' magic. See C. + +=cut +*/ + void Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) { @@ -2889,10 +3107,23 @@ 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); + if (SvUTF8(sstr)) + SvUTF8_on(dstr); + } } +/* +=for apidoc sv_catsv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr) { @@ -2900,6 +3131,15 @@ Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr) SvSETMAGIC(dstr); } +/* +=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. + +=cut +*/ + void Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) { @@ -2916,10 +3156,18 @@ Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) ptr = SvPVX(sv); Move(ptr,SvPVX(sv)+tlen,len+1,char); SvCUR(sv) += len; - (void)SvPOK_only(sv); /* validate pointer */ + (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); } +/* +=for apidoc sv_catpv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr) { @@ -2942,6 +3190,14 @@ Perl_newSV(pTHX_ STRLEN len) /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */ +/* +=for apidoc sv_magic + +Adds magic to an SV. + +=cut +*/ + void Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) { @@ -3190,6 +3446,15 @@ S_sv_del_backref(pTHX_ SV *sv) } } +/* +=for apidoc sv_insert + +Inserts a string at the specified offset/length within the SV. Similar to +the Perl substr() function. + +=cut +*/ + void Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) { @@ -3253,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); @@ -3540,6 +3805,14 @@ Perl_sv_free(pTHX_ SV *sv) del_SV(sv); } +/* +=for apidoc sv_len + +Returns the length of the string in the SV. See also C. + +=cut +*/ + STRLEN Perl_sv_len(pTHX_ register SV *sv) { @@ -3641,6 +3914,15 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) return; } +/* +=for apidoc sv_eq + +Returns a boolean indicating whether the strings in the two SVs are +identical. + +=cut +*/ + I32 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2) { @@ -3656,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; @@ -3667,15 +3958,55 @@ Perl_sv_eq(pTHX_ register SV *str1, register SV *str2) return memEQ(pv1, pv2, cur1); } +/* +=for apidoc sv_cmp + +Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the +string in C is less than, equal to, or greater than the string in +C. + +=cut +*/ + I32 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2) { - STRLEN cur1 = 0; - char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL; - STRLEN cur2 = 0; - char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL; + STRLEN cur1, cur2; + char *pv1, *pv2; I32 retval; + if (str1) { + pv1 = SvPV(str1, cur1); + } + else { + cur1 = 0; + } + + if (str2) { + if (SvPOK(str2)) { + if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) { + /* must upgrade other to UTF8 first */ + if (SvUTF8(str1)) { + sv_utf8_upgrade(str2); + } + else { + sv_utf8_upgrade(str1); + /* refresh pointer and length */ + pv1 = SvPVX(str1); + cur1 = SvCUR(str1); + } + } + pv2 = SvPVX(str2); + cur2 = SvCUR(str2); + } + else { + pv2 = sv_2pv(str2, &cur2); + } + } + else { + cur2 = 0; + } + if (!cur1) return cur2 ? -1 : 0; @@ -4063,6 +4394,14 @@ screamer2: } +/* +=for apidoc sv_inc + +Auto-increment of the value in the SV. + +=cut +*/ + void Perl_sv_inc(pTHX_ register SV *sv) { @@ -4164,6 +4503,14 @@ Perl_sv_inc(pTHX_ register SV *sv) *d = d[1]; } +/* +=for apidoc sv_dec + +Auto-decrement of the value in the SV. + +=cut +*/ + void Perl_sv_dec(pTHX_ register SV *sv) { @@ -4224,6 +4571,15 @@ Perl_sv_dec(pTHX_ register SV *sv) sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */ } +/* +=for apidoc sv_mortalcopy + +Creates a new SV which is a copy of the original SV. The new SV is marked +as mortal. + +=cut +*/ + /* Make a string that will exist for the duration of the expression * evaluation. Actually, it may have to last longer than that, but * hopefully we won't free it until it has been assigned to a @@ -4243,6 +4599,14 @@ Perl_sv_mortalcopy(pTHX_ SV *oldstr) return sv; } +/* +=for apidoc sv_newmortal + +Creates a new SV which is mortal. The reference count of the SV is set to 1. + +=cut +*/ + SV * Perl_sv_newmortal(pTHX) { @@ -4256,6 +4620,15 @@ Perl_sv_newmortal(pTHX) return sv; } +/* +=for apidoc sv_2mortal + +Marks an SV as mortal. The SV will be destroyed when the current context +ends. + +=cut +*/ + /* same thing without the copying */ SV * @@ -4272,6 +4645,16 @@ Perl_sv_2mortal(pTHX_ register SV *sv) return sv; } +/* +=for apidoc newSVpv + +Creates a new SV and copies a string into it. The reference count for the +SV is set to 1. If C is zero, Perl will compute the length using +strlen(). For efficiency, consider using C instead. + +=cut +*/ + SV * Perl_newSVpv(pTHX_ const char *s, STRLEN len) { @@ -4284,6 +4667,17 @@ Perl_newSVpv(pTHX_ const char *s, STRLEN len) return sv; } +/* +=for apidoc newSVpvn + +Creates a new SV and copies a string into it. The reference count for the +SV is set to 1. Note that if C is zero, Perl will create a zero length +string. You are responsible for ensuring that the source string is at least +C bytes long. + +=cut +*/ + SV * Perl_newSVpvn(pTHX_ const char *s, STRLEN len) { @@ -4308,6 +4702,15 @@ Perl_newSVpvf_nocontext(const char* pat, ...) } #endif +/* +=for apidoc newSVpvf + +Creates a new SV an initialize it with the string formatted like +C. + +=cut +*/ + SV * Perl_newSVpvf(pTHX_ const char* pat, ...) { @@ -4328,6 +4731,15 @@ Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args) return sv; } +/* +=for apidoc newSVnv + +Creates a new SV and copies a floating point value into it. +The reference count for the SV is set to 1. + +=cut +*/ + SV * Perl_newSVnv(pTHX_ NV n) { @@ -4338,6 +4750,15 @@ Perl_newSVnv(pTHX_ NV n) return sv; } +/* +=for apidoc newSViv + +Creates a new SV and copies an integer into it. The reference count for the +SV is set to 1. + +=cut +*/ + SV * Perl_newSViv(pTHX_ IV i) { @@ -4348,6 +4769,34 @@ Perl_newSViv(pTHX_ IV i) return sv; } +/* +=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 +SV is B incremented. + +=cut +*/ + SV * Perl_newRV_noinc(pTHX_ SV *tmpRef) { @@ -4362,12 +4811,21 @@ Perl_newRV_noinc(pTHX_ SV *tmpRef) return sv; } +/* newRV_inc is #defined to newRV in sv.h */ SV * Perl_newRV(pTHX_ SV *tmpRef) { return newRV_noinc(SvREFCNT_inc(tmpRef)); } +/* +=for apidoc newSVsv + +Creates a new SV which is an exact duplicate of the original SV. + +=cut +*/ + /* make an exact duplicate of old */ SV * @@ -4582,8 +5040,7 @@ Perl_sv_true(pTHX_ register SV *sv) if (SvPOK(sv)) { register XPV* tXpv; if ((tXpv = (XPV*)SvANY(sv)) && - (*tXpv->xpv_pv > '0' || - tXpv->xpv_cur > 1 || + (tXpv->xpv_cur > 1 || (tXpv->xpv_cur && *tXpv->xpv_pv != '0'))) return 1; else @@ -4713,18 +5170,21 @@ Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) char * Perl_sv_pvutf8(pTHX_ SV *sv) { + sv_utf8_upgrade(sv); return sv_pv(sv); } char * Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) { + sv_utf8_upgrade(sv); return sv_pvn(sv,lp); } char * Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) { + sv_utf8_upgrade(sv); return sv_pvn_force(sv,lp); } @@ -4754,11 +5214,22 @@ 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"; } } } +/* +=for apidoc sv_isobject + +Returns a boolean indicating whether the SV is an RV pointing to a blessed +object. If the SV is not an RV, or if the object is not blessed, then this +will return false. + +=cut +*/ + int Perl_sv_isobject(pTHX_ SV *sv) { @@ -4774,6 +5245,16 @@ Perl_sv_isobject(pTHX_ SV *sv) return 1; } +/* +=for apidoc sv_isa + +Returns a boolean indicating whether the SV is blessed into the specified +class. This does not check for subtypes; use C to verify +an inheritance relationship. + +=cut +*/ + int Perl_sv_isa(pTHX_ SV *sv, const char *name) { @@ -4790,6 +5271,17 @@ Perl_sv_isa(pTHX_ SV *sv, const char *name) return strEQ(HvNAME(SvSTASH(sv)), name); } +/* +=for apidoc newSVrv + +Creates a new SV for the RV, C, to point to. If C is not an RV then +it will be upgraded to one. If C is non-null then the new SV will +be blessed in the specified package. The new SV is returned and its +reference count is 1. + +=cut +*/ + SV* Perl_newSVrv(pTHX_ SV *rv, const char *classname) { @@ -4815,6 +5307,24 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) return sv; } +/* +=for apidoc sv_setref_pv + +Copies a pointer into a new SV, optionally blessing the SV. The C +argument will be upgraded to an RV. That RV will be modified to point to +the new SV. If the C argument is NULL then C will be placed +into the SV. The C argument indicates the package for the +blessing. Set C to C to avoid the blessing. The new SV +will be returned and will have a reference count of 1. + +Do not use with other Perl types such as HV, AV, SV, CV, because those +objects will become corrupted by the pointer copy process. + +Note that C copies the string while this copies the pointer. + +=cut +*/ + SV* Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv) { @@ -4827,6 +5337,18 @@ Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv) return rv; } +/* +=for apidoc sv_setref_iv + +Copies an integer into a new SV, optionally blessing the SV. The C +argument will be upgraded to an RV. That RV will be modified to point to +the new SV. The C argument indicates the package for the +blessing. Set C to C to avoid the blessing. The new SV +will be returned and will have a reference count of 1. + +=cut +*/ + SV* Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv) { @@ -4834,6 +5356,18 @@ Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv) return rv; } +/* +=for apidoc sv_setref_nv + +Copies a double into a new SV, optionally blessing the SV. The C +argument will be upgraded to an RV. That RV will be modified to point to +the new SV. The C argument indicates the package for the +blessing. Set C to C to avoid the blessing. The new SV +will be returned and will have a reference count of 1. + +=cut +*/ + SV* Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv) { @@ -4841,6 +5375,21 @@ Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv) return rv; } +/* +=for apidoc sv_setref_pvn + +Copies a string into a new SV, optionally blessing the SV. The length of the +string must be specified with C. The C argument will be upgraded to +an RV. That RV will be modified to point to the new SV. The C +argument indicates the package for the blessing. Set C to +C to avoid the blessing. The new SV will be returned and will have +a reference count of 1. + +Note that C copies the pointer while this copies the string. + +=cut +*/ + SV* Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n) { @@ -4848,6 +5397,16 @@ Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n) return rv; } +/* +=for apidoc sv_bless + +Blesses an SV into a specified package. The SV must be an RV. The package +must be designated by its stash (see C). The reference count +of the SV is unaffected. + +=cut +*/ + SV* Perl_sv_bless(pTHX_ SV *sv, HV *stash) { @@ -4882,6 +5441,8 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) STATIC void S_sv_unglob(pTHX_ SV *sv) { + void *xpvmg; + assert(SvTYPE(sv) == SVt_PVGV); SvFAKE_off(sv); if (GvGP(sv)) @@ -4893,10 +5454,27 @@ S_sv_unglob(pTHX_ SV *sv) sv_unmagic(sv, '*'); Safefree(GvNAME(sv)); GvMULTI_off(sv); + + /* need to keep SvANY(sv) in the right arena */ + xpvmg = new_XPVMG(); + StructCopy(SvANY(sv), xpvmg, XPVMG); + del_XPVGV(SvANY(sv)); + SvANY(sv) = xpvmg; + SvFLAGS(sv) &= ~SVTYPEMASK; SvFLAGS(sv) |= SVt_PVMG; } +/* +=for apidoc sv_unref + +Unsets the RV status of the SV, and decrements the reference count of +whatever was being referenced by the RV. This can almost be thought of +as a reversal of C. See C. + +=cut +*/ + void Perl_sv_unref(pTHX_ SV *sv) { @@ -4937,12 +5515,21 @@ 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; } +/* +=for apidoc sv_setpviv + +Copies an integer into the given SV, also updating its string value. +Does not handle 'set' magic. See C. + +=cut +*/ + void Perl_sv_setpviv(pTHX_ SV *sv, IV iv) { @@ -4954,6 +5541,14 @@ Perl_sv_setpviv(pTHX_ SV *sv, IV iv) } +/* +=for apidoc sv_setpviv_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) { @@ -4988,6 +5583,15 @@ Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...) } #endif +/* +=for apidoc sv_setpvf + +Processes its arguments like C and sets an SV to the formatted +output. Does not handle 'set' magic. See C. + +=cut +*/ + void Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...) { @@ -5003,6 +5607,14 @@ Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); } +/* +=for apidoc sv_setpvf_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...) { @@ -5041,6 +5653,16 @@ Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) } #endif +/* +=for apidoc sv_catpvf + +Processes its arguments like C and appends the formatted output +to an SV. Handles 'get' magic, but not 'set' magic. C must +typically be called after calling this function to handle 'set' magic. + +=cut +*/ + void Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...) { @@ -5056,6 +5678,14 @@ Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); } +/* +=for apidoc sv_catpvf_mg + +Like C, but also handles 'set' magic. + +=cut +*/ + void Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) { @@ -5072,6 +5702,15 @@ Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) SvSETMAGIC(sv); } +/* +=for apidoc sv_vsetpvfn + +Works like C but copies the text into the SV instead of +appending it. + +=cut +*/ + void Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) { @@ -5079,6 +5718,18 @@ Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); } +/* +=for apidoc sv_vcatpvfn + +Processes its arguments like C and appends the formatted output +to an SV. Uses an array of SVs if the C style variable argument list is +missing (NULL). When running with taint checks enabled, indicates via +C if results are untrustworthy (often due to the use of +locales). + +=cut +*/ + void Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) { @@ -5089,6 +5740,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN origlen; I32 svix = 0; static char nullstr[] = "(null)"; + SV *argsv; /* no matter what, this is a string now */ (void)SvPV_force(sv, origlen); @@ -5103,12 +5755,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV char *s = va_arg(*args, char*); sv_catpv(sv, s ? s : nullstr); } - else if (svix < svmax) + else if (svix < svmax) { sv_catsv(sv, *svargs); + if (DO_UTF8(*svargs)) + SvUTF8_on(sv); + } return; case '_': if (args) { - sv_catsv(sv, va_arg(*args, SV*)); + argsv = va_arg(*args, SV*); + sv_catsv(sv, argsv); + if (DO_UTF8(argsv)) + SvUTF8_on(sv); return; } /* See comment on '_' below */ @@ -5120,6 +5778,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; @@ -5127,9 +5787,10 @@ 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; char esignbuf[4]; - U8 utf8buf[10]; + U8 utf8buf[UTF8_MAXLEN]; STRLEN esignlen = 0; char *eptr = Nullch; @@ -5140,6 +5801,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; @@ -5149,6 +5814,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) { @@ -5181,6 +5848,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; } @@ -5267,22 +5965,20 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto string; case 'c': - if (IN_UTF8) { - if (args) - uv = va_arg(*args, int); - else - uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; - + if (args) + uv = va_arg(*args, int); + else + uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) { eptr = (char*)utf8buf; elen = uv_to_utf8((U8*)eptr, uv) - utf8buf; - goto string; + is_utf = TRUE; + } + else { + c = (char)uv; + eptr = &c; + elen = 1; } - if (args) - c = va_arg(*args, int); - else - c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; - eptr = &c; - elen = 1; goto string; case 's': @@ -5302,16 +5998,18 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } } else if (svix < svmax) { - eptr = SvPVx(svargs[svix++], elen); - if (IN_UTF8) { + argsv = svargs[svix++]; + eptr = SvPVx(argsv, elen); + if (DO_UTF8(argsv)) { if (has_precis && precis < elen) { I32 p = precis; - sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */ + sv_pos_u2b(argsv, &p, 0); /* sticks at end */ precis = p; } if (width) { /* fudge width (can't fudge elen) */ - width += elen - sv_len_utf8(svargs[svix - 1]); + width += elen - sv_len_utf8(argsv); } + is_utf = TRUE; } } goto string; @@ -5324,9 +6022,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV */ if (!args) goto unknown; - eptr = SvPVx(va_arg(*args, SV*), elen); + argsv = va_arg(*args,SV*); + eptr = SvPVx(argsv, elen); + if (DO_UTF8(argsv)) + is_utf = TRUE; string: + vectorize = FALSE; if (has_precis && elen > precis) elen = precis; break; @@ -5350,7 +6052,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; @@ -5365,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 @@ -5416,7 +6133,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; @@ -5431,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 @@ -5478,13 +6211,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'"); } @@ -5516,6 +6249,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 @@ -5524,7 +6258,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) @@ -5547,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) { @@ -5583,6 +6318,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) { @@ -5603,6 +6339,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(); @@ -5618,7 +6355,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV (UV)c & 0xFF); } else sv_catpv(msg, "end of string"); - Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ + Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ @@ -5641,7 +6378,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++) @@ -5667,8 +6404,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; + } } } @@ -5678,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 @@ -5834,7 +6581,7 @@ void * Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv) { PTR_TBL_ENT_t *tblent; - UV hash = (UV)sv; + UV hash = PTR2UV(sv); assert(tbl); tblent = tbl->tbl_ary[hash & tbl->tbl_max]; for (; tblent; tblent = tblent->next) { @@ -5851,7 +6598,7 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv) /* XXX this may be pessimal on platforms where pointers aren't good * hash values e.g. if they grow faster in the most significant * bits */ - UV hash = (UV)oldv; + UV hash = PTR2UV(oldv); bool i = 1; assert(tbl); @@ -5891,7 +6638,7 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) continue; curentp = ary + oldsize; for (entp = ary, ent = *ary; ent; ent = *entp) { - if ((newsize & (UV)ent->oldval) != i) { + if ((newsize & PTR2UV(ent->oldval)) != i) { *entp = ent->next; ent->next = *curentp; *curentp = ent; @@ -5910,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) @@ -6147,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); @@ -6263,7 +7006,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) case CXt_EVAL: ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type; - ncx->blk_eval.old_name = SAVEPV(cx->blk_eval.old_name); + ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv); ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root; ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text); break; @@ -6276,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); @@ -6387,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); @@ -6513,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; @@ -6543,13 +7292,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: @@ -6585,6 +7334,10 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) i = POPINT(ss,ix); TOPINT(nss,ix) = i; break; + case SAVEt_COMPPAD: + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup(av); + break; default: Perl_croak(aTHX_ "panic: ss_dup inconsistency"); } @@ -6630,15 +7383,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)); @@ -6663,10 +7414,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)); @@ -6833,7 +7582,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_beginav = av_dup_inc(proto_perl->Ibeginav); PL_endav = av_dup_inc(proto_perl->Iendav); - PL_stopav = av_dup_inc(proto_perl->Istopav); + PL_checkav = av_dup_inc(proto_perl->Icheckav); PL_initav = av_dup_inc(proto_perl->Iinitav); PL_sub_generation = proto_perl->Isub_generation; @@ -6856,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 */ @@ -7134,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 */ @@ -7172,7 +7922,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; @@ -7305,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);