X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=0cf3b4c7dae9267fabe426f38c886a0e3a0b01b4;hb=3818b22bb9ef820a2553aa5e3504220f3b156f21;hp=475bd2254887b837bc8168fffa0210ae99eae543;hpb=ed094fafab5cc8979a919ec8755493543b6bddf5;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 475bd22..0cf3b4c 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. @@ -316,6 +316,16 @@ Perl_sv_free_arenas(pTHX) PL_sv_root = 0; } +void +Perl_report_uninit(pTHX) +{ + if (PL_op) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, + " in ", PL_op_desc[PL_op->op_type]); + else + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", ""); +} + STATIC XPVIV* S_new_xiv(pTHX) { @@ -911,6 +921,15 @@ S_my_safemalloc(MEM_SIZE size) #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO)) #define del_XPVIO(p) my_safefree((char*)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) { @@ -1200,6 +1219,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) { @@ -1249,6 +1278,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) { @@ -1282,6 +1320,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) { @@ -1289,6 +1335,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) { @@ -1297,6 +1352,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) { @@ -1304,6 +1367,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) { @@ -1336,6 +1408,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) { @@ -1427,7 +1507,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return 0; } @@ -1442,7 +1522,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); return 0; } } @@ -1538,7 +1618,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) else { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); if (SvTYPE(sv) < SVt_IV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_IV); @@ -1566,7 +1646,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return 0; } @@ -1581,7 +1661,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); return 0; } } @@ -1695,7 +1775,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } if (SvTYPE(sv) < SVt_IV) /* Typically the caller expects that sv_any is not NULL now. */ @@ -1704,7 +1784,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n", - (UV)sv,SvUVX(sv))); + PTR2UV(sv),SvUVX(sv))); return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); } @@ -1733,7 +1813,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } return 0; } @@ -1748,7 +1828,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); return 0.0; } } @@ -1790,7 +1870,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) else { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); if (SvTYPE(sv) < SVt_NV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_NV); @@ -1862,6 +1942,15 @@ S_asUV(pTHX_ SV *sv) * 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) { @@ -2035,7 +2124,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } *lp = 0; return ""; @@ -2129,7 +2218,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); *lp = 0; return ""; } @@ -2193,7 +2282,7 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) { - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + report_uninit(); } *lp = 0; if (SvTYPE(sv) < SVt_PV) @@ -2248,6 +2337,30 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) } } +char * +Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) +{ + return sv_2pv_nolen(sv); +} + +char * +Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) +{ + return sv_2pv(sv,lp); +} + +char * +Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv) +{ + return sv_2pv_nolen(sv); +} + +char * +Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) +{ + return sv_2pv(sv,lp); +} + /* This function is only called on magical items */ bool Perl_sv_2bool(pTHX_ register SV *sv) @@ -2291,6 +2404,17 @@ Perl_sv_2bool(pTHX_ register SV *sv) * 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) { @@ -2645,6 +2769,8 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) *SvEND(dstr) = '\0'; (void)SvPOK_only(dstr); } + if (DO_UTF8(sstr)) + SvUTF8_on(dstr); /*SUPPRESS 560*/ if (sflags & SVp_NOK) { SvNOK_on(dstr); @@ -2685,6 +2811,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) { @@ -2692,6 +2826,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) { @@ -2714,6 +2857,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) { @@ -2721,6 +2872,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) { @@ -2741,6 +2901,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) { @@ -2748,6 +2916,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) { @@ -2769,6 +2951,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) { @@ -2790,6 +2980,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 */ @@ -2822,6 +3023,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) { @@ -2835,10 +3046,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) { @@ -2846,6 +3065,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) { @@ -2855,8 +3083,18 @@ Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) return; if (s = SvPV(sstr, len)) 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) { @@ -2864,6 +3102,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) { @@ -2880,10 +3127,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) { @@ -2906,6 +3161,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) { @@ -3154,6 +3417,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) { @@ -3174,6 +3446,7 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN SvCUR_set(bigstr, offset+len); } + SvTAINT(bigstr); i = littlelen - len; if (i > 0) { /* string might grow */ big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); @@ -3503,6 +3776,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) { @@ -3604,6 +3885,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) { @@ -3630,6 +3920,16 @@ 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) { @@ -4022,14 +4322,18 @@ screamer2: } } -#ifdef WIN32 - win32_strip_return(sv); -#endif - return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch; } +/* +=for apidoc sv_inc + +Auto-increment of the value in the SV. + +=cut +*/ + void Perl_sv_inc(pTHX_ register SV *sv) { @@ -4131,6 +4435,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) { @@ -4191,6 +4503,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 @@ -4210,6 +4531,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) { @@ -4223,6 +4552,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 * @@ -4239,6 +4577,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) { @@ -4251,6 +4599,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) { @@ -4275,6 +4634,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, ...) { @@ -4295,6 +4663,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) { @@ -4305,6 +4682,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) { @@ -4315,6 +4701,15 @@ Perl_newSViv(pTHX_ IV i) 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) { @@ -4329,12 +4724,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 * @@ -4549,8 +4953,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 @@ -4660,6 +5063,42 @@ Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) } char * +Perl_sv_pvbyte(pTHX_ SV *sv) +{ + return sv_pv(sv); +} + +char * +Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn(sv,lp); +} + +char * +Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn_force(sv,lp); +} + +char * +Perl_sv_pvutf8(pTHX_ SV *sv) +{ + return sv_pv(sv); +} + +char * +Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn(sv,lp); +} + +char * +Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) +{ + return sv_pvn_force(sv,lp); +} + +char * Perl_sv_reftype(pTHX_ SV *sv, int ob) { if (ob && SvOBJECT(sv)) @@ -4690,8 +5129,18 @@ Perl_sv_reftype(pTHX_ SV *sv, int ob) } } -int -Perl_sv_isobject(pTHX_ SV *sv) +/* +=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) { if (!sv) return 0; @@ -4705,6 +5154,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) { @@ -4721,6 +5180,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) { @@ -4746,6 +5216,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) { @@ -4758,6 +5246,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) { @@ -4765,6 +5265,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) { @@ -4772,6 +5284,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) { @@ -4779,6 +5306,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) { @@ -4828,6 +5365,16 @@ S_sv_unglob(pTHX_ SV *sv) 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) { @@ -4874,6 +5421,15 @@ Perl_sv_tainted(pTHX_ SV *sv) 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) { @@ -4885,6 +5441,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) { @@ -4919,6 +5483,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, ...) { @@ -4934,6 +5507,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, ...) { @@ -4972,6 +5553,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, ...) { @@ -4987,6 +5578,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, ...) { @@ -5003,6 +5602,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) { @@ -5010,6 +5618,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) { @@ -5020,6 +5640,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); @@ -5034,12 +5655,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 */ @@ -5058,6 +5685,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN zeros = 0; bool has_precis = FALSE; STRLEN precis = 0; + bool is_utf = FALSE; char esignbuf[4]; U8 utf8buf[10]; @@ -5198,22 +5826,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 >= 128 && PL_bigchar && !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': @@ -5233,20 +5859,76 @@ 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; + 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; + SV *vsv = NEWSV(73,vlen); + I32 ulen; + 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; + if (elen >= vlen-1) { + STRLEN off = vptr - (U8*)SvPVX(vsv); + vlen *= 2; + SvGROW(vsv, vlen); + vptr = SvPVX(vsv) + off; + } + do { + *--eptr = '0' + uv % 10; + } while (uv /= 10); + elen = (ebuf + sizeof ebuf) - eptr; + memcpy(vptr, eptr, elen); + vptr += elen; + *vptr++ = '.'; + 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, @@ -5255,7 +5937,10 @@ 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: if (has_precis && elen > precis) @@ -5549,7 +6234,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 ... */ @@ -5598,6 +6283,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV memset(p, ' ', gap); p += gap; } + if (is_utf) + SvUTF8_on(sv); *p = '\0'; SvCUR(sv) = p - SvPVX(sv); } @@ -5642,11 +6329,19 @@ Perl_re_dup(pTHX_ REGEXP *r) PerlIO * Perl_fp_dup(pTHX_ PerlIO *fp, char type) { + PerlIO *ret; if (!fp) return (PerlIO*)NULL; - return fp; /* XXX */ - /* return PerlIO_fdopen(PerlIO_fileno(fp), - type == '<' ? "r" : type == '>' ? "w" : "rw"); */ + + /* look for it in the table first */ + ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp); + if (ret) + return ret; + + /* create anew and remember what it is */ + ret = PerlIO_fdupopen(fp); + ptr_table_store(PL_ptr_table, fp, ret); + return ret; } DIR * @@ -5665,13 +6360,13 @@ Perl_gp_dup(pTHX_ GP *gp) if (!gp) return (GP*)NULL; /* look for it in the table first */ - ret = (GP*)sv_table_fetch(PL_sv_table, (SV*)gp); + ret = (GP*)ptr_table_fetch(PL_ptr_table, gp); if (ret) return ret; /* create anew and remember what it is */ Newz(0, ret, 1, GP); - sv_table_store(PL_sv_table, (SV*)gp, (SV*)ret); + ptr_table_store(PL_ptr_table, gp, ret); /* clone */ ret->gp_refcnt = 0; /* must be before any other dups! */ @@ -5696,7 +6391,10 @@ Perl_mg_dup(pTHX_ MAGIC *mg) MAGIC *mgprev; if (!mg) return (MAGIC*)NULL; - /* XXX need to handle aliases here? */ + /* look for it in the table first */ + mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg); + if (mgret) + return mgret; for (; mg; mg = mg->mg_moremagic) { MAGIC *nmg; @@ -5739,75 +6437,79 @@ Perl_mg_dup(pTHX_ MAGIC *mg) return mgret; } -SVTBL * -Perl_sv_table_new(pTHX) +PTR_TBL_t * +Perl_ptr_table_new(pTHX) { - SVTBL *tbl; - Newz(0, tbl, 1, SVTBL); + PTR_TBL_t *tbl; + Newz(0, tbl, 1, PTR_TBL_t); tbl->tbl_max = 511; tbl->tbl_items = 0; - Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, SVTBLENT*); + Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); return tbl; } -SV * -Perl_sv_table_fetch(pTHX_ SVTBL *tbl, SV *sv) +void * +Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv) { - SVTBLENT *tblent; - UV hash = (UV)sv; + PTR_TBL_ENT_t *tblent; + UV hash = PTR2UV(sv); assert(tbl); tblent = tbl->tbl_ary[hash & tbl->tbl_max]; for (; tblent; tblent = tblent->next) { if (tblent->oldval == sv) return tblent->newval; } - return Nullsv; + return (void*)NULL; } void -Perl_sv_table_store(pTHX_ SVTBL *tbl, SV *old, SV *new) +Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv) { - SVTBLENT *tblent, **otblent; - UV hash = (UV)old; + PTR_TBL_ENT_t *tblent, **otblent; + /* 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 = PTR2UV(oldv); bool i = 1; + assert(tbl); otblent = &tbl->tbl_ary[hash & tbl->tbl_max]; for (tblent = *otblent; tblent; i=0, tblent = tblent->next) { - if (tblent->oldval == old) { - tblent->newval = new; + if (tblent->oldval == oldv) { + tblent->newval = newv; tbl->tbl_items++; return; } } - Newz(0, tblent, 1, SVTBLENT); - tblent->oldval = old; - tblent->newval = new; + Newz(0, tblent, 1, PTR_TBL_ENT_t); + tblent->oldval = oldv; + tblent->newval = newv; tblent->next = *otblent; *otblent = tblent; tbl->tbl_items++; if (i && tbl->tbl_items > tbl->tbl_max) - sv_table_split(tbl); + ptr_table_split(tbl); } void -Perl_sv_table_split(pTHX_ SVTBL *tbl) +Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) { - SVTBLENT **ary = tbl->tbl_ary; + PTR_TBL_ENT_t **ary = tbl->tbl_ary; UV oldsize = tbl->tbl_max + 1; UV newsize = oldsize * 2; UV i; - Renew(ary, newsize, SVTBLENT*); - Zero(&ary[oldsize], newsize-oldsize, SVTBLENT*); + Renew(ary, newsize, PTR_TBL_ENT_t*); + Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*); tbl->tbl_max = --newsize; tbl->tbl_ary = ary; for (i=0; i < oldsize; i++, ary++) { - SVTBLENT **curentp, **entp, *ent; + PTR_TBL_ENT_t **curentp, **entp, *ent; if (!*ary) 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; @@ -5820,7 +6522,7 @@ Perl_sv_table_split(pTHX_ SVTBL *tbl) } #ifdef DEBUGGING -DllExport char *PL_watch_pvx; +char *PL_watch_pvx; #endif SV * @@ -5834,15 +6536,13 @@ Perl_sv_dup(pTHX_ SV *sstr) if (!sstr || SvTYPE(sstr) == SVTYPEMASK) return Nullsv; /* look for it in the table first */ - dstr = sv_table_fetch(PL_sv_table, sstr); + dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr); if (dstr) return dstr; - /* XXX TODO: sanity-check sv_dup() vs sv_dup_inc() appropriateness */ - /* create anew and remember what it is */ new_SV(dstr); - sv_table_store(PL_sv_table, sstr, dstr); + ptr_table_store(PL_ptr_table, sstr, dstr); /* clone */ SvFLAGS(dstr) = SvFLAGS(sstr); @@ -5994,11 +6694,11 @@ Perl_sv_dup(pTHX_ SV *sstr) SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); else SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */ - IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr)); + IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr)); if (IoOFP(sstr) == IoIFP(sstr)) IoOFP(dstr) = IoIFP(dstr); else - IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr)); + IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr)); /* PL_rsfp_filters entries have fake IoDIRP() */ if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP)) IoDIRP(dstr) = dirp_dup(IoDIRP(sstr)); @@ -6034,6 +6734,7 @@ Perl_sv_dup(pTHX_ SV *sstr) src_ary = AvARRAY((AV*)sstr); Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*); + ptr_table_store(PL_ptr_table, src_ary, dst_ary); SvPVX(dstr) = (char*)dst_ary; AvALLOC((AV*)dstr) = dst_ary; if (AvREAL((AV*)sstr)) { @@ -6071,26 +6772,11 @@ Perl_sv_dup(pTHX_ SV *sstr) Newz(0, dxhv->xhv_array, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char); while (i <= sxhv->xhv_max) { - HE *dentry, *oentry; - entry = ((HE**)sxhv->xhv_array)[i]; - dentry = he_dup(entry, !!HvSHAREKEYS(sstr)); - ((HE**)dxhv->xhv_array)[i] = dentry; - while (entry) { - entry = HeNEXT(entry); - oentry = dentry; - dentry = he_dup(entry, !!HvSHAREKEYS(sstr)); - HeNEXT(oentry) = dentry; - } + ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i], + !!HvSHAREKEYS(sstr)); ++i; } - if (sxhv->xhv_riter >= 0 && sxhv->xhv_eiter) { - entry = ((HE**)sxhv->xhv_array)[sxhv->xhv_riter]; - while (entry && entry != sxhv->xhv_eiter) - entry = HeNEXT(entry); - dxhv->xhv_eiter = entry; - } - else - dxhv->xhv_eiter = (HE*)NULL; + dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr)); } else { SvPVX(dstr) = Nullch; @@ -6147,43 +6833,473 @@ dup_pvcv: return dstr; } +PERL_CONTEXT * +Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max) +{ + PERL_CONTEXT *ncxs; + + if (!cxs) + return (PERL_CONTEXT*)NULL; + + /* look for it in the table first */ + ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs); + if (ncxs) + return ncxs; + + /* create anew and remember what it is */ + Newz(56, ncxs, max + 1, PERL_CONTEXT); + ptr_table_store(PL_ptr_table, cxs, ncxs); + + while (ix >= 0) { + PERL_CONTEXT *cx = &cxs[ix]; + PERL_CONTEXT *ncx = &ncxs[ix]; + ncx->cx_type = cx->cx_type; + if (CxTYPE(cx) == CXt_SUBST) { + Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); + } + else { + ncx->blk_oldsp = cx->blk_oldsp; + ncx->blk_oldcop = cx->blk_oldcop; + ncx->blk_oldretsp = cx->blk_oldretsp; + ncx->blk_oldmarksp = cx->blk_oldmarksp; + ncx->blk_oldscopesp = cx->blk_oldscopesp; + ncx->blk_oldpm = cx->blk_oldpm; + ncx->blk_gimme = cx->blk_gimme; + switch (CxTYPE(cx)) { + case CXt_SUB: + ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0 + ? cv_dup_inc(cx->blk_sub.cv) + : cv_dup(cx->blk_sub.cv)); + ncx->blk_sub.argarray = (cx->blk_sub.hasargs + ? av_dup_inc(cx->blk_sub.argarray) + : Nullav); + ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray); + ncx->blk_sub.olddepth = cx->blk_sub.olddepth; + ncx->blk_sub.hasargs = cx->blk_sub.hasargs; + ncx->blk_sub.lval = cx->blk_sub.lval; + break; + 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_eval_root = cx->blk_eval.old_eval_root; + ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text); + break; + case CXt_LOOP: + ncx->blk_loop.label = cx->blk_loop.label; + ncx->blk_loop.resetsp = cx->blk_loop.resetsp; + ncx->blk_loop.redo_op = cx->blk_loop.redo_op; + ncx->blk_loop.next_op = cx->blk_loop.next_op; + ncx->blk_loop.last_op = cx->blk_loop.last_op; + ncx->blk_loop.iterdata = (CxPADLOOP(cx) + ? cx->blk_loop.iterdata + : gv_dup((GV*)cx->blk_loop.iterdata)); + 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); + ncx->blk_loop.iterix = cx->blk_loop.iterix; + ncx->blk_loop.itermax = cx->blk_loop.itermax; + break; + case CXt_FORMAT: + ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv); + ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv); + ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv); + ncx->blk_sub.hasargs = cx->blk_sub.hasargs; + break; + case CXt_BLOCK: + case CXt_NULL: + break; + } + } + --ix; + } + return ncxs; +} + +PERL_SI * +Perl_si_dup(pTHX_ PERL_SI *si) +{ + PERL_SI *nsi; + + if (!si) + return (PERL_SI*)NULL; + + /* look for it in the table first */ + nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si); + if (nsi) + return nsi; + + /* create anew and remember what it is */ + Newz(56, nsi, 1, PERL_SI); + ptr_table_store(PL_ptr_table, si, nsi); + + nsi->si_stack = av_dup_inc(si->si_stack); + nsi->si_cxix = si->si_cxix; + nsi->si_cxmax = si->si_cxmax; + nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax); + nsi->si_type = si->si_type; + nsi->si_prev = si_dup(si->si_prev); + nsi->si_next = si_dup(si->si_next); + nsi->si_markoff = si->si_markoff; + + return nsi; +} + +#define POPINT(ss,ix) ((ss)[--(ix)].any_i32) +#define TOPINT(ss,ix) ((ss)[ix].any_i32) +#define POPLONG(ss,ix) ((ss)[--(ix)].any_long) +#define TOPLONG(ss,ix) ((ss)[ix].any_long) +#define POPIV(ss,ix) ((ss)[--(ix)].any_iv) +#define TOPIV(ss,ix) ((ss)[ix].any_iv) +#define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr) +#define TOPPTR(ss,ix) ((ss)[ix].any_ptr) +#define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr) +#define TOPDPTR(ss,ix) ((ss)[ix].any_dptr) +#define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr) +#define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr) + +/* XXXXX todo */ +#define pv_dup_inc(p) SAVEPV(p) +#define pv_dup(p) SAVEPV(p) +#define svp_dup_inc(p,pp) any_dup(p,pp) + +void * +Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl) +{ + void *ret; + + if (!v) + return (void*)NULL; + + /* look for it in the table first */ + ret = ptr_table_fetch(PL_ptr_table, v); + if (ret) + return ret; + + /* see if it is part of the interpreter structure */ + if (v >= (void*)proto_perl && v < (void*)(proto_perl+1)) + ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl)); + else + ret = v; + + return ret; +} + +ANY * +Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl) +{ + ANY *ss = proto_perl->Tsavestack; + I32 ix = proto_perl->Tsavestack_ix; + I32 max = proto_perl->Tsavestack_max; + ANY *nss; + SV *sv; + GV *gv; + AV *av; + HV *hv; + void* ptr; + int intval; + long longval; + GP *gp; + IV iv; + I32 i; + char *c; + void (*dptr) (void*); + void (*dxptr) (pTHXo_ void*); + + Newz(54, nss, max, ANY); + + while (ix > 0) { + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + switch (i) { + case SAVEt_ITEM: /* normal string */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + break; + case SAVEt_SV: /* scalar reference */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(gv); + break; + case SAVEt_GENERIC_SVREF: /* generic sv */ + case SAVEt_SVREF: /* scalar reference */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ + break; + case SAVEt_AV: /* array reference */ + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup_inc(av); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup(gv); + break; + case SAVEt_HV: /* hash reference */ + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup(gv); + break; + case SAVEt_INT: /* int reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + intval = (int)POPINT(ss,ix); + TOPINT(nss,ix) = intval; + break; + case SAVEt_LONG: /* long reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + longval = (long)POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + break; + case SAVEt_I32: /* I32 reference */ + case SAVEt_I16: /* I16 reference */ + case SAVEt_I8: /* I8 reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_IV: /* IV reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + break; + case SAVEt_SPTR: /* SV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv); + break; + case SAVEt_VPTR: /* random* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; + case SAVEt_PPTR: /* char* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + break; + case SAVEt_HPTR: /* HV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup(hv); + break; + case SAVEt_APTR: /* AV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup(av); + break; + case SAVEt_NSTAB: + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup(gv); + break; + case SAVEt_GP: /* scalar reference */ + gp = (GP*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gp = gp_dup(gp); + (void)GpREFCNT_inc(gp); + gv = (GV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(c); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + break; + case SAVEt_FREESV: + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + break; + case SAVEt_FREEOP: + ptr = POPPTR(ss,ix); + if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { + /* these are assumed to be refcounted properly */ + switch (((OP*)ptr)->op_type) { + case OP_LEAVESUB: + case OP_LEAVESUBLV: + case OP_LEAVEEVAL: + case OP_LEAVE: + case OP_SCOPE: + case OP_LEAVEWRITE: + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; + default: + TOPPTR(nss,ix) = Nullop; + break; + } + } + else + TOPPTR(nss,ix) = Nullop; + break; + case SAVEt_FREEPV: + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup_inc(c); + break; + case SAVEt_CLEARSV: + longval = POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + break; + case SAVEt_DELETE: + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup_inc(c); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_DESTRUCTOR: + 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); + 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); + break; + case SAVEt_REGCONTEXT: + case SAVEt_ALLOC: + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + ix -= i; + break; + case SAVEt_STACK_POS: /* Position on Perl stack */ + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_AELEM: /* array element */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + av = (AV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup_inc(av); + break; + case SAVEt_HELEM: /* hash element */ + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + sv = (SV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv); + hv = (HV*)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv); + break; + case SAVEt_OP: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = ptr; + break; + case SAVEt_HINTS: + 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"); + } + } + + return nss; +} + +#ifdef PERL_OBJECT +#include "XSUB.h" +#endif + +PerlInterpreter * +perl_clone(PerlInterpreter *proto_perl, UV flags) +{ +#ifdef PERL_OBJECT + CPerlObj *pPerl = (CPerlObj*)proto_perl; +#endif + +#ifdef PERL_IMPLICIT_SYS + return perl_clone_using(proto_perl, flags, + proto_perl->IMem, + proto_perl->IMemShared, + proto_perl->IMemParse, + proto_perl->IEnv, + proto_perl->IStdIO, + proto_perl->ILIO, + proto_perl->IDir, + proto_perl->ISock, + proto_perl->IProc); +} + PerlInterpreter * -perl_clone_using(PerlInterpreter *proto_perl, IV flags, - struct IPerlMem* ipM, struct IPerlEnv* ipE, +perl_clone_using(PerlInterpreter *proto_perl, UV flags, + struct IPerlMem* ipM, struct IPerlMem* ipMS, + struct IPerlMem* ipMP, struct IPerlEnv* ipE, struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, struct IPerlDir* ipD, struct IPerlSock* ipS, struct IPerlProc* ipP) { + /* XXX many of the string copies here can be optimized if they're + * constants; they need to be allocated as common memory and just + * 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); +# else /* !PERL_OBJECT */ PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); PERL_SET_INTERP(my_perl); -#ifdef DEBUGGING - memset(my_perl, 0x0, sizeof(PerlInterpreter)); +# ifdef DEBUGGING + memset(my_perl, 0xab, sizeof(PerlInterpreter)); PL_markstack = 0; PL_scopestack = 0; PL_savestack = 0; PL_retstack = 0; -#else -# if 0 - Copy(proto_perl, my_perl, 1, PerlInterpreter); -# endif -#endif - - /* XXX many of the string copies here can be optimized if they're - * constants; they need to be allocated as common memory and just - * their pointers copied. */ +# else /* !DEBUGGING */ + Zero(my_perl, 1, PerlInterpreter); +# endif /* DEBUGGING */ /* host pointers */ PL_Mem = ipM; + PL_MemShared = ipMS; + PL_MemParse = ipMP; PL_Env = ipE; PL_StdIO = ipStd; PL_LIO = ipLIO; PL_Dir = ipD; PL_Sock = ipS; PL_Proc = ipP; +# 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); + +# ifdef DEBUGGING + memset(my_perl, 0xab, sizeof(PerlInterpreter)); + PL_markstack = 0; + PL_scopestack = 0; + PL_savestack = 0; + PL_retstack = 0; +# else /* !DEBUGGING */ + Zero(my_perl, 1, PerlInterpreter); +# endif /* DEBUGGING */ +#endif /* PERL_IMPLICIT_SYS */ /* arena roots */ PL_xiv_arenaroot = NULL; @@ -6210,47 +7326,53 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_debug = proto_perl->Idebug; /* create SV map for pointer relocation */ - PL_sv_table = sv_table_new(); + PL_ptr_table = ptr_table_new(); /* initialize these special pointers as early as possible */ SvANY(&PL_sv_undef) = NULL; SvREFCNT(&PL_sv_undef) = (~(U32)0)/2; SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL; - sv_table_store(PL_sv_table, &proto_perl->Isv_undef, &PL_sv_undef); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef); +#ifdef PERL_OBJECT + SvUPGRADE(&PL_sv_no, SVt_PVNV); +#else SvANY(&PL_sv_no) = new_XPVNV(); +#endif SvREFCNT(&PL_sv_no) = (~(U32)0)/2; SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0); SvCUR(&PL_sv_no) = 0; SvLEN(&PL_sv_no) = 1; SvNVX(&PL_sv_no) = 0; - sv_table_store(PL_sv_table, &proto_perl->Isv_no, &PL_sv_no); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no); +#ifdef PERL_OBJECT + SvUPGRADE(&PL_sv_yes, SVt_PVNV); +#else SvANY(&PL_sv_yes) = new_XPVNV(); +#endif SvREFCNT(&PL_sv_yes) = (~(U32)0)/2; SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV; SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1); SvCUR(&PL_sv_yes) = 1; SvLEN(&PL_sv_yes) = 2; SvNVX(&PL_sv_yes) = 1; - sv_table_store(PL_sv_table, &proto_perl->Isv_yes, &PL_sv_yes); + ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); /* create shared string table */ PL_strtab = newHV(); HvSHAREKEYS_off(PL_strtab); hv_ksplit(PL_strtab, 512); - sv_table_store(PL_sv_table, (SV*)proto_perl->Istrtab, (SV*)PL_strtab); + ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab); PL_compiling = proto_perl->Icompiling; PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv); PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file); + ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling); if (!specialWARN(PL_compiling.cop_warnings)) PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings); - if (proto_perl->Tcurcop == &proto_perl->Icompiling) - PL_curcop = &PL_compiling; - else - PL_curcop = proto_perl->Tcurcop; + PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl); /* pseudo environmental stuff */ PL_origargc = proto_perl->Iorigargc; @@ -6269,7 +7391,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, /* switches */ PL_minus_c = proto_perl->Iminus_c; - Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char); + PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel); PL_localpatches = proto_perl->Ilocalpatches; PL_splitstr = proto_perl->Isplitstr; PL_preprocess = proto_perl->Ipreprocess; @@ -6289,7 +7411,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_perl_destruct_level = proto_perl->Iperl_destruct_level; /* magical thingies */ - /* XXX time(&PL_basetime) instead? */ + /* XXX time(&PL_basetime) when asked for? */ PL_basetime = proto_perl->Ibasetime; PL_formfeed = sv_dup(proto_perl->Iformfeed); @@ -6333,7 +7455,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV 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; @@ -6356,16 +7478,16 @@ perl_clone_using(PerlInterpreter *proto_perl, IV 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 = proto_perl->Ieval_root; + PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root); PL_eval_start = proto_perl->Ieval_start; /* runtime control stuff */ - PL_curcopdb = proto_perl->Icurcopdb; + PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl); PL_copline = proto_perl->Icopline; PL_filemode = proto_perl->Ifilemode; PL_lastfd = proto_perl->Ilastfd; - PL_oldname = proto_perl->Ioldname; /* XXX */ + PL_oldname = proto_perl->Ioldname; /* XXX not quite right */ PL_Argv = NULL; PL_Cmd = Nullch; PL_gensym = proto_perl->Igensym; @@ -6389,9 +7511,9 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_exitlist = (PerlExitListEntry*)NULL; PL_modglobal = hv_dup_inc(proto_perl->Imodglobal); - PL_profiledata = NULL; /* XXX */ + PL_profiledata = NULL; PL_rsfp = fp_dup(proto_perl->Irsfp, '<'); - /* XXX PL_rsfp_filters entries have fake IoDIRP() */ + /* PL_rsfp_filters entries have fake IoDIRP() */ PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters); PL_compcv = cv_dup(proto_perl->Icompcv); @@ -6399,7 +7521,8 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_comppad_name = av_dup(proto_perl->Icomppad_name); PL_comppad_name_fill = proto_perl->Icomppad_name_fill; PL_comppad_name_floor = proto_perl->Icomppad_name_floor; - PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : (SV**)NULL; + PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table, + proto_perl->Tcurpad); #ifdef HAVE_INTERP_INTERN sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern); @@ -6408,7 +7531,6 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, /* more statics moved here */ PL_generation = proto_perl->Igeneration; PL_DBcv = cv_dup(proto_perl->IDBcv); - PL_archpat_auto = SAVEPV(proto_perl->Iarchpat_auto); PL_in_clean_objs = proto_perl->Iin_clean_objs; PL_in_clean_all = proto_perl->Iin_clean_all; @@ -6422,9 +7544,9 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_cop_seqmax = proto_perl->Icop_seqmax; PL_op_seqmax = proto_perl->Iop_seqmax; PL_evalseq = proto_perl->Ievalseq; - PL_origenviron = proto_perl->Iorigenviron; /* XXX */ + PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ PL_origalen = proto_perl->Iorigalen; - PL_pidstatus = newHV(); + PL_pidstatus = newHV(); /* XXX flag for cloning? */ PL_osname = SAVEPV(proto_perl->Iosname); PL_sh_path = SAVEPV(proto_perl->Ish_path); PL_sighandlerp = proto_perl->Isighandlerp; @@ -6432,7 +7554,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_runops = proto_perl->Irunops; - Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); /* XXX */ + Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); #ifdef CSH PL_cshlen = proto_perl->Icshlen; @@ -6443,11 +7565,10 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_lex_defer = proto_perl->Ilex_defer; PL_lex_expect = proto_perl->Ilex_expect; PL_lex_formbrack = proto_perl->Ilex_formbrack; - PL_lex_fakebrack = proto_perl->Ilex_fakebrack; PL_lex_dojoin = proto_perl->Ilex_dojoin; PL_lex_starts = proto_perl->Ilex_starts; - PL_lex_stuff = Nullsv; /* XXX */ - PL_lex_repl = Nullsv; /* XXX */ + PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff); + PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl); PL_lex_op = proto_perl->Ilex_op; PL_lex_inpat = proto_perl->Ilex_inpat; PL_lex_inwhat = proto_perl->Ilex_inwhat; @@ -6473,7 +7594,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr); PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i); PL_pending_ident = proto_perl->Ipending_ident; - PL_sublex_info = proto_perl->Isublex_info; /* XXX */ + PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */ PL_expect = proto_perl->Iexpect; @@ -6542,10 +7663,10 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower); /* swatch cache */ - PL_last_swash_hv = Nullhv; /* XXX recreate swatch cache? */ + PL_last_swash_hv = Nullhv; /* reinits on demand */ PL_last_swash_klen = 0; PL_last_swash_key[0]= '\0'; - PL_last_swash_tmps = Nullch; + PL_last_swash_tmps = (U8*)NULL; PL_last_swash_slen = 0; /* perly.c globals */ @@ -6558,19 +7679,94 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_glob_index = proto_perl->Iglob_index; PL_srand_called = proto_perl->Isrand_called; - PL_uudmap['M'] = 0; /* reinit on demand */ - PL_bitcount = Nullch; /* reinit on demand */ + PL_uudmap['M'] = 0; /* reinits on demand */ + PL_bitcount = Nullch; /* reinits on demand */ + if (proto_perl->Ipsig_ptr) { + int sig_num[] = { SIG_NUM }; + Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*); + Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*); + for (i = 1; PL_sig_name[i]; i++) { + PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]); + PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]); + } + } + else { + PL_psig_ptr = (SV**)NULL; + PL_psig_name = (SV**)NULL; + } /* thrdvar.h stuff */ -/* PL_curstackinfo = clone_stackinfo(proto_perl->Tcurstackinfo); - clone_stacks(); - PL_mainstack = av_dup(proto_perl->Tmainstack); - PL_curstack = av_dup(proto_perl->Tcurstack);*/ /* XXXXXX */ - init_stacks(); + if (flags & 1) { + /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ + PL_tmps_ix = proto_perl->Ttmps_ix; + PL_tmps_max = proto_perl->Ttmps_max; + PL_tmps_floor = proto_perl->Ttmps_floor; + Newz(50, PL_tmps_stack, PL_tmps_max, SV*); + i = 0; + while (i <= PL_tmps_ix) { + PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]); + ++i; + } + + /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ + i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack; + Newz(54, PL_markstack, i, I32); + PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max + - proto_perl->Tmarkstack); + PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr + - proto_perl->Tmarkstack); + Copy(proto_perl->Tmarkstack, PL_markstack, + PL_markstack_ptr - PL_markstack + 1, I32); + + /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] + * NOTE: unlike the others! */ + PL_scopestack_ix = proto_perl->Tscopestack_ix; + PL_scopestack_max = proto_perl->Tscopestack_max; + Newz(54, PL_scopestack, PL_scopestack_max, I32); + Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32); + + /* next push_return() sets PL_retstack[PL_retstack_ix] + * NOTE: unlike the others! */ + PL_retstack_ix = proto_perl->Tretstack_ix; + PL_retstack_max = proto_perl->Tretstack_max; + Newz(54, PL_retstack, PL_retstack_max, OP*); + Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32); + + /* NOTE: si_dup() looks at PL_markstack */ + PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo); + + /* PL_curstack = PL_curstackinfo->si_stack; */ + PL_curstack = av_dup(proto_perl->Tcurstack); + PL_mainstack = av_dup(proto_perl->Tmainstack); + + /* next PUSHs() etc. set *(PL_stack_sp+1) */ + PL_stack_base = AvARRAY(PL_curstack); + PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp + - proto_perl->Tstack_base); + PL_stack_max = PL_stack_base + AvMAX(PL_curstack); + + /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] + * NOTE: unlike the others! */ + PL_savestack_ix = proto_perl->Tsavestack_ix; + PL_savestack_max = proto_perl->Tsavestack_max; + /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/ + PL_savestack = ss_dup(proto_perl); + } + else { + init_stacks(); + } + + PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ + PL_top_env = &PL_start_env; PL_op = proto_perl->Top; + + PL_Sv = Nullsv; + PL_Xpv = (XPV*)NULL; + PL_na = proto_perl->Tna; + PL_statbuf = proto_perl->Tstatbuf; PL_statcache = proto_perl->Tstatcache; PL_statgv = gv_dup(proto_perl->Tstatgv); @@ -6587,7 +7783,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_ofslen = proto_perl->Tofslen; PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen); PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv); - PL_chopset = proto_perl->Tchopset; /* XXX */ + PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */ PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget); PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget); PL_formtarget = sv_dup(proto_perl->Tformtarget); @@ -6598,8 +7794,6 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_dirty = proto_perl->Tdirty; PL_localizing = proto_perl->Tlocalizing; - PL_start_env = proto_perl->Tstart_env; /* XXXXXX */ - PL_top_env = &PL_start_env; PL_protect = proto_perl->Tprotect; PL_errors = sv_dup_inc(proto_perl->Terrors); PL_av_fetch_sv = Nullsv; @@ -6608,18 +7802,76 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_modcount = proto_perl->Tmodcount; PL_lastgotoprobe = Nullop; PL_dumpindent = proto_perl->Tdumpindent; + + PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl); PL_sortstash = hv_dup(proto_perl->Tsortstash); PL_firstgv = gv_dup(proto_perl->Tfirstgv); PL_secondgv = gv_dup(proto_perl->Tsecondgv); PL_sortcxix = proto_perl->Tsortcxix; - PL_efloatbuf = Nullch; - PL_efloatsize = 0; + PL_efloatbuf = Nullch; /* reinits on demand */ + PL_efloatsize = 0; /* reinits on demand */ + + /* regex stuff */ PL_screamfirst = NULL; PL_screamnext = NULL; - PL_maxscream = -1; + PL_maxscream = -1; /* reinits on demand */ PL_lastscream = Nullsv; + PL_watchaddr = NULL; + PL_watchok = Nullch; + + PL_regdummy = proto_perl->Tregdummy; + PL_regcomp_parse = Nullch; + PL_regxend = Nullch; + PL_regcode = (regnode*)NULL; + PL_regnaughty = 0; + PL_regsawback = 0; + PL_regprecomp = Nullch; + PL_regnpar = 0; + PL_regsize = 0; + PL_regflags = 0; + PL_regseen = 0; + PL_seen_zerolen = 0; + PL_seen_evals = 0; + PL_regcomp_rx = (regexp*)NULL; + PL_extralen = 0; + PL_colorset = 0; /* reinits PL_colors[] */ + /*PL_colors[6] = {0,0,0,0,0,0};*/ + PL_reg_whilem_seen = 0; + PL_reginput = Nullch; + PL_regbol = Nullch; + PL_regeol = Nullch; + PL_regstartp = (I32*)NULL; + PL_regendp = (I32*)NULL; + PL_reglastparen = (U32*)NULL; + PL_regtill = Nullch; + PL_regprev = '\n'; + PL_reg_start_tmp = (char**)NULL; + PL_reg_start_tmpl = 0; + PL_regdata = (struct reg_data*)NULL; + PL_bostr = Nullch; + PL_reg_flags = 0; + PL_reg_eval_set = 0; + PL_regnarrate = 0; + PL_regprogram = (regnode*)NULL; + PL_regindent = 0; + PL_regcc = (CURCUR*)NULL; + PL_reg_call_cc = (struct re_cc_state*)NULL; + PL_reg_re = (regexp*)NULL; + PL_reg_ganch = Nullch; + PL_reg_sv = Nullsv; + PL_reg_magic = (MAGIC*)NULL; + PL_reg_oldpos = 0; + PL_reg_oldcurpm = (PMOP*)NULL; + PL_reg_curpm = (PMOP*)NULL; + PL_reg_oldsaved = Nullch; + PL_reg_oldsavedlen = 0; + PL_reg_maxiter = 0; + PL_reg_leftiter = 0; + PL_reg_poscache = Nullch; + PL_reg_poscache_size= 0; + /* RE engine - function pointers */ PL_regcompp = proto_perl->Tregcompp; PL_regexecp = proto_perl->Tregexecp; @@ -6627,31 +7879,24 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags, PL_regint_string = proto_perl->Tregint_string; PL_regfree = proto_perl->Tregfree; - PL_regindent = 0; PL_reginterp_cnt = 0; - PL_reg_start_tmp = 0; - PL_reg_start_tmpl = 0; - PL_reg_poscache = Nullch; - - PL_watchaddr = NULL; - PL_watchok = Nullch; + PL_reg_starttry = 0; +#ifdef PERL_OBJECT + return (PerlInterpreter*)pPerl; +#else return my_perl; +#endif } -PerlInterpreter * -perl_clone(pTHXx_ IV flags) -{ - return perl_clone_using(aTHXx_ flags, PL_Mem, PL_Env, PL_StdIO, PL_LIO, - PL_Dir, PL_Sock, PL_Proc); -} - -#endif /* USE_ITHREADS */ +#else /* !USE_ITHREADS */ #ifdef PERL_OBJECT #include "XSUB.h" #endif +#endif /* USE_ITHREADS */ + static void do_report_used(pTHXo_ SV *sv) { @@ -6680,7 +7925,7 @@ do_clean_objs(pTHXo_ SV *sv) static void do_clean_named_objs(pTHXo_ SV *sv) { - if (SvTYPE(sv) == SVt_PVGV) { + if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { if ( SvOBJECT(GvSV(sv)) || GvAV(sv) && SvOBJECT(GvAV(sv)) || GvHV(sv) && SvOBJECT(GvHV(sv)) ||