X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=c2e5fa7f3b2323eed66c5bb178a980c46edc0526;hb=6cef1e77274f883a8b06f0546efeff6e6b8660d8;hp=a4d72bcf42696052d49b98333e1329f27a1df02a;hpb=611e57134ef8720264c53f5e0589f41461af4dcb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index a4d72bc..c2e5fa7 100644 --- a/sv.c +++ b/sv.c @@ -65,8 +65,6 @@ static void sv_mortalgrow _((void)); static void sv_unglob _((SV* sv)); static void sv_check_thinkfirst _((SV *sv)); -#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_check_thinkfirst(sv) - #ifndef PURIFY static void *my_safemalloc(MEM_SIZE size); #endif @@ -77,6 +75,8 @@ typedef void (*SVFUNC) _((SV*)); #endif /* PERL_OBJECT */ +#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_check_thinkfirst(sv) + #ifdef PURIFY #define new_SV(p) \ @@ -96,17 +96,17 @@ typedef void (*SVFUNC) _((SV*)); } while (0) static SV **registry; -static I32 regsize; +static I32 registry_size; #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size)) #define REG_REPLACE(sv,a,b) \ do { \ void* p = sv->sv_any; \ - I32 h = REGHASH(sv, regsize); \ + I32 h = REGHASH(sv, registry_size); \ I32 i = h; \ while (registry[i] != (a)) { \ - if (++i >= regsize) \ + if (++i >= registry_size) \ i = 0; \ if (i == h) \ die("SV registry bug"); \ @@ -121,13 +121,13 @@ static void reg_add(sv) SV* sv; { - if (sv_count >= (regsize >> 1)) + if (PL_sv_count >= (registry_size >> 1)) { SV **oldreg = registry; - I32 oldsize = regsize; + I32 oldsize = registry_size; - regsize = regsize ? ((regsize << 2) + 1) : 2037; - Newz(707, registry, regsize, SV*); + registry_size = registry_size ? ((registry_size << 2) + 1) : 2037; + Newz(707, registry, registry_size, SV*); if (oldreg) { I32 i; @@ -142,7 +142,7 @@ SV* sv; } REG_ADD(sv); - ++sv_count; + ++PL_sv_count; } static void @@ -150,7 +150,7 @@ reg_remove(sv) SV* sv; { REG_REMOVE(sv); - --sv_count; + --PL_sv_count; } static void @@ -159,9 +159,9 @@ SVFUNC f; { I32 i; - for (i = 0; i < regsize; ++i) { + for (i = 0; i < registry_size; ++i) { SV* sv = registry[i]; - if (sv) + if (sv && SvTYPE(sv) != SVTYPEMASK) (*f)(sv); } } @@ -184,23 +184,23 @@ U32 flags; #define plant_SV(p) \ do { \ - SvANY(p) = (void *)sv_root; \ + SvANY(p) = (void *)PL_sv_root; \ SvFLAGS(p) = SVTYPEMASK; \ - sv_root = (p); \ - --sv_count; \ + PL_sv_root = (p); \ + --PL_sv_count; \ } while (0) /* sv_mutex must be held while calling uproot_SV() */ #define uproot_SV(p) \ do { \ - (p) = sv_root; \ - sv_root = (SV*)SvANY(p); \ - ++sv_count; \ + (p) = PL_sv_root; \ + PL_sv_root = (SV*)SvANY(p); \ + ++PL_sv_count; \ } while (0) #define new_SV(p) do { \ LOCK_SV_MUTEX; \ - if (sv_root) \ + if (PL_sv_root) \ uproot_SV(p); \ else \ (p) = more_sv(); \ @@ -211,7 +211,7 @@ U32 flags; #define del_SV(p) do { \ LOCK_SV_MUTEX; \ - if (debug & 32768) \ + if (PL_debug & 32768) \ del_sv(p); \ else \ plant_SV(p); \ @@ -221,12 +221,12 @@ U32 flags; STATIC void del_sv(SV *p) { - if (debug & 32768) { + if (PL_debug & 32768) { SV* sva; SV* sv; SV* svend; int ok = 0; - for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { sv = sva + 1; svend = &sva[SvREFCNT(sva)]; if (p >= sv && p < svend) @@ -255,12 +255,12 @@ sv_add_arena(char *ptr, U32 size, U32 flags) Zero(sva, size, char); /* The first SV in an arena isn't an SV. */ - SvANY(sva) = (void *) sv_arenaroot; /* ptr to next arena */ + SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ SvFLAGS(sva) = flags; /* FAKE if not to be freed */ - sv_arenaroot = sva; - sv_root = sva + 1; + PL_sv_arenaroot = sva; + PL_sv_root = sva + 1; svend = &sva[SvREFCNT(sva) - 1]; sv = sva + 1; @@ -279,9 +279,9 @@ more_sv(void) { register SV* sv; - if (nice_chunk) { - sv_add_arena(nice_chunk, nice_chunk_size, 0); - nice_chunk = Nullch; + if (PL_nice_chunk) { + sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0); + PL_nice_chunk = Nullch; } else { char *chunk; /* must use New here to match call to */ @@ -299,7 +299,7 @@ visit(SVFUNC f) SV* sv; register SV* svend; - for (sva = sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { + for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != SVTYPEMASK) @@ -323,7 +323,7 @@ do_report_used(SV *sv) void sv_report_used(void) { - visit(do_report_used); + visit(FUNC_NAME_TO_PTR(do_report_used)); } STATIC void @@ -345,26 +345,36 @@ do_clean_objs(SV *sv) STATIC void do_clean_named_objs(SV *sv) { - if (SvTYPE(sv) == SVt_PVGV && GvSV(sv)) - do_clean_objs(GvSV(sv)); + if (SvTYPE(sv) == SVt_PVGV) { + if ( SvOBJECT(GvSV(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); + } + } } #endif void sv_clean_objs(void) { - in_clean_objs = TRUE; + PL_in_clean_objs = TRUE; + visit(FUNC_NAME_TO_PTR(do_clean_objs)); #ifndef DISABLE_DESTRUCTOR_KLUDGE - visit(do_clean_named_objs); + /* some barnacles may yet remain, clinging to typeglobs */ + visit(FUNC_NAME_TO_PTR(do_clean_named_objs)); #endif - visit(do_clean_objs); - in_clean_objs = FALSE; + PL_in_clean_objs = FALSE; } STATIC void do_clean_all(SV *sv) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));) + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );) SvFLAGS(sv) |= SVf_BREAK; SvREFCNT_dec(sv); } @@ -372,9 +382,9 @@ do_clean_all(SV *sv) void sv_clean_all(void) { - in_clean_all = TRUE; - visit(do_clean_all); - in_clean_all = FALSE; + PL_in_clean_all = TRUE; + visit(FUNC_NAME_TO_PTR(do_clean_all)); + PL_in_clean_all = FALSE; } void @@ -386,7 +396,7 @@ sv_free_arenas(void) /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ - for (sva = sv_arenaroot; sva; sva = svanext) { + for (sva = PL_sv_arenaroot; sva; sva = svanext) { svanext = (SV*) SvANY(sva); while (svanext && SvFAKE(svanext)) svanext = (SV*) SvANY(svanext); @@ -395,21 +405,25 @@ sv_free_arenas(void) Safefree((void *)sva); } - sv_arenaroot = 0; - sv_root = 0; + if (PL_nice_chunk) + Safefree(PL_nice_chunk); + PL_nice_chunk = Nullch; + PL_nice_chunk_size = 0; + PL_sv_arenaroot = 0; + PL_sv_root = 0; } STATIC XPVIV* new_xiv(void) { - IV** xiv; - if (xiv_root) { - xiv = xiv_root; + IV* xiv; + if (PL_xiv_root) { + xiv = PL_xiv_root; /* * See comment in more_xiv() -- RAM. */ - xiv_root = (IV**)*xiv; - return (XPVIV*)((char*)xiv - sizeof(XPV)); + PL_xiv_root = *(IV**)xiv; + return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv)); } return more_xiv(); } @@ -417,30 +431,30 @@ new_xiv(void) STATIC void del_xiv(XPVIV *p) { - IV** xiv = (IV**)((char*)(p) + sizeof(XPV)); - *xiv = (IV *)xiv_root; - xiv_root = xiv; + IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv)); + *(IV**)xiv = PL_xiv_root; + PL_xiv_root = xiv; } STATIC XPVIV* more_xiv(void) { - register IV** xiv; - register IV** xivend; + register IV* xiv; + register IV* xivend; XPV* ptr; New(705, ptr, 1008/sizeof(XPV), XPV); - ptr->xpv_pv = (char*)xiv_arenaroot; /* linked list of xiv arenas */ - xiv_arenaroot = ptr; /* to keep Purify happy */ + ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */ + PL_xiv_arenaroot = ptr; /* to keep Purify happy */ - xiv = (IV**) ptr; - xivend = &xiv[1008 / sizeof(IV *) - 1]; - xiv += (sizeof(XPV) - 1) / sizeof(IV *) + 1; /* fudge by size of XPV */ - xiv_root = xiv; + xiv = (IV*) ptr; + xivend = &xiv[1008 / sizeof(IV) - 1]; + xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */ + PL_xiv_root = xiv; while (xiv < xivend) { - *xiv = (IV *)(xiv + 1); + *(IV**)xiv = (IV *)(xiv + 1); xiv++; } - *xiv = 0; + *(IV**)xiv = 0; return new_xiv(); } @@ -448,10 +462,10 @@ STATIC XPVNV* new_xnv(void) { double* xnv; - if (xnv_root) { - xnv = xnv_root; - xnv_root = *(double**)xnv; - return (XPVNV*)((char*)xnv - sizeof(XPVIV)); + if (PL_xnv_root) { + xnv = PL_xnv_root; + PL_xnv_root = *(double**)xnv; + return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv)); } return more_xnv(); } @@ -459,9 +473,9 @@ new_xnv(void) STATIC void del_xnv(XPVNV *p) { - double* xnv = (double*)((char*)(p) + sizeof(XPVIV)); - *(double**)xnv = xnv_root; - xnv_root = xnv; + double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv)); + *(double**)xnv = PL_xnv_root; + PL_xnv_root = xnv; } STATIC XPVNV* @@ -472,7 +486,7 @@ more_xnv(void) New(711, xnv, 1008/sizeof(double), double); xnvend = &xnv[1008 / sizeof(double) - 1]; xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */ - xnv_root = xnv; + PL_xnv_root = xnv; while (xnv < xnvend) { *(double**)xnv = (double*)(xnv + 1); xnv++; @@ -485,9 +499,9 @@ STATIC XRV* new_xrv(void) { XRV* xrv; - if (xrv_root) { - xrv = xrv_root; - xrv_root = (XRV*)xrv->xrv_rv; + if (PL_xrv_root) { + xrv = PL_xrv_root; + PL_xrv_root = (XRV*)xrv->xrv_rv; return xrv; } return more_xrv(); @@ -496,8 +510,8 @@ new_xrv(void) STATIC void del_xrv(XRV *p) { - p->xrv_rv = (SV*)xrv_root; - xrv_root = p; + p->xrv_rv = (SV*)PL_xrv_root; + PL_xrv_root = p; } STATIC XRV* @@ -505,8 +519,8 @@ more_xrv(void) { register XRV* xrv; register XRV* xrvend; - New(712, xrv_root, 1008/sizeof(XRV), XRV); - xrv = xrv_root; + New(712, PL_xrv_root, 1008/sizeof(XRV), XRV); + xrv = PL_xrv_root; xrvend = &xrv[1008 / sizeof(XRV) - 1]; while (xrv < xrvend) { xrv->xrv_rv = (SV*)(xrv + 1); @@ -520,9 +534,9 @@ STATIC XPV* new_xpv(void) { XPV* xpv; - if (xpv_root) { - xpv = xpv_root; - xpv_root = (XPV*)xpv->xpv_pv; + if (PL_xpv_root) { + xpv = PL_xpv_root; + PL_xpv_root = (XPV*)xpv->xpv_pv; return xpv; } return more_xpv(); @@ -531,8 +545,8 @@ new_xpv(void) STATIC void del_xpv(XPV *p) { - p->xpv_pv = (char*)xpv_root; - xpv_root = p; + p->xpv_pv = (char*)PL_xpv_root; + PL_xpv_root = p; } STATIC XPV* @@ -540,8 +554,8 @@ more_xpv(void) { register XPV* xpv; register XPV* xpvend; - New(713, xpv_root, 1008/sizeof(XPV), XPV); - xpv = xpv_root; + New(713, PL_xpv_root, 1008/sizeof(XPV), XPV); + xpv = PL_xpv_root; xpvend = &xpv[1008 / sizeof(XPV) - 1]; while (xpv < xpvend) { xpv->xpv_pv = (char*)(xpv + 1); @@ -904,10 +918,10 @@ sv_upgrade(register SV *sv, U32 mt) return TRUE; } -#ifdef DEBUGGING char * sv_peek(SV *sv) { +#ifdef DEBUGGING SV *t = sv_newmortal(); STRLEN prevlen; int unref = 0; @@ -922,15 +936,15 @@ sv_peek(SV *sv) sv_catpv(t, "WILD"); goto finish; } - else if (sv == &sv_undef || sv == &sv_no || sv == &sv_yes) { - if (sv == &sv_undef) { + else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes) { + if (sv == &PL_sv_undef) { sv_catpv(t, "SV_UNDEF"); if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT| SVs_GMG|SVs_SMG|SVs_RMG)) && SvREADONLY(sv)) goto finish; } - else if (sv == &sv_no) { + else if (sv == &PL_sv_no) { sv_catpv(t, "SV_NO"); if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT| SVs_GMG|SVs_SMG|SVs_RMG)) && @@ -1048,9 +1062,11 @@ sv_peek(SV *sv) while (unref--) sv_catpv(t, ")"); } - return SvPV(t, na); + return SvPV(t, PL_na); +#else /* DEBUGGING */ + return ""; +#endif /* DEBUGGING */ } -#endif int sv_backoff(register SV *sv) @@ -1101,8 +1117,16 @@ sv_grow(SV* sv, unsigned long newlen) else s = SvPVX(sv); if (newlen > SvLEN(sv)) { /* need more room? */ - if (SvLEN(sv) && s) + if (SvLEN(sv) && s) { +#if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST) + STRLEN l = malloced_size((void*)SvPVX(sv)); + if (newlen <= l) { + SvLEN_set(sv, l); + return s; + } else +#endif Renew(s,newlen,char); + } else New(703,s,newlen,char); SvPV_set(sv, s); @@ -1141,7 +1165,7 @@ sv_setiv(register SV *sv, IV i) { dTHR; croak("Can't coerce %s to integer in %s", sv_reftype(sv,0), - op_desc[op->op_type]); + op_desc[PL_op->op_type]); } } (void)SvIOK_only(sv); /* validate number */ @@ -1185,14 +1209,8 @@ sv_setnv(register SV *sv, double num) case SVt_PV: case SVt_PVIV: sv_upgrade(sv, SVt_PVNV); - /* FALL THROUGH */ - case SVt_PVNV: - case SVt_PVMG: - case SVt_PVBM: - case SVt_PVLV: - if (SvOOK(sv)) - (void)SvOOK_off(sv); break; + case SVt_PVGV: if (SvFAKE(sv)) { sv_unglob(sv); @@ -1207,7 +1225,7 @@ sv_setnv(register SV *sv, double num) { dTHR; croak("Can't coerce %s to number in %s", sv_reftype(sv,0), - op_name[op->op_type]); + op_name[PL_op->op_type]); } } SvNVX(sv) = num; @@ -1270,11 +1288,11 @@ not_a_number(SV *sv) } *d = '\0'; - if (op) - warn("Argument \"%s\" isn't numeric in %s", tmpbuf, - op_name[op->op_type]); + if (PL_op) + warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf, + op_name[PL_op->op_type]); else - warn("Argument \"%s\" isn't numeric", tmpbuf); + warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); } IV @@ -1295,10 +1313,10 @@ sv_2iv(register SV *sv) if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + warner(WARN_UNINITIALIZED, warn_uninit); } return 0; } @@ -1321,8 +1339,11 @@ sv_2iv(register SV *sv) } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); - if (dowarn) - warn(warn_uninit); + { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, warn_uninit); + } return 0; } } @@ -1350,8 +1371,8 @@ sv_2iv(register SV *sv) } else { dTHR; - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + warner(WARN_UNINITIALIZED, warn_uninit); return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", @@ -1373,10 +1394,10 @@ sv_2uv(register SV *sv) if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + warner(WARN_UNINITIALIZED, warn_uninit); } return 0; } @@ -1396,8 +1417,11 @@ sv_2uv(register SV *sv) } if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); - if (dowarn) - warn(warn_uninit); + { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, warn_uninit); + } return 0; } } @@ -1421,10 +1445,10 @@ sv_2uv(register SV *sv) SvUVX(sv) = asUV(sv); } else { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + warner(WARN_UNINITIALIZED, warn_uninit); } return 0; } @@ -1443,7 +1467,8 @@ sv_2nv(register SV *sv) if (SvNOKp(sv)) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) + dTHR; + if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); @@ -1451,10 +1476,10 @@ sv_2nv(register SV *sv) if (SvIOKp(sv)) return (double)SvIVX(sv); if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + warner(WARN_UNINITIALIZED, warn_uninit); } return 0; } @@ -1469,16 +1494,17 @@ sv_2nv(register SV *sv) return (double)(unsigned long)SvRV(sv); } if (SvREADONLY(sv)) { + dTHR; if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) + if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); } if (SvIOKp(sv)) return (double)SvIVX(sv); - if (dowarn) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, warn_uninit); return 0.0; } } @@ -1499,15 +1525,16 @@ sv_2nv(register SV *sv) SvNVX(sv) = (double)SvIVX(sv); } else if (SvPOKp(sv) && SvLEN(sv)) { - if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) + dTHR; + if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); SvNVX(sv) = atof(SvPVX(sv)); } else { dTHR; - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + warner(WARN_UNINITIALIZED, warn_uninit); return 0.0; } SvNOK_on(sv); @@ -1525,8 +1552,11 @@ asIV(SV *sv) if (numtype == 1) return atol(SvPVX(sv)); - if (!numtype && dowarn) - not_a_number(sv); + if (!numtype) { + dTHR; + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } SET_NUMERIC_STANDARD(); d = atof(SvPVX(sv)); if (d < 0.0) @@ -1544,8 +1574,11 @@ asUV(SV *sv) if (numtype == 1) return strtoul(SvPVX(sv), Null(char**), 10); #endif - if (!numtype && dowarn) - not_a_number(sv); + if (!numtype) { + dTHR; + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } SET_NUMERIC_STANDARD(); return U_V(atof(SvPVX(sv))); } @@ -1659,10 +1692,10 @@ sv_2pv(register SV *sv, STRLEN *lp) goto tokensave; } if (!SvROK(sv)) { - if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) { + if (!(SvFLAGS(sv) & SVs_PADTMP)) { dTHR; - if (!localizing) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + warner(WARN_UNINITIALIZED, warn_uninit); } *lp = 0; return ""; @@ -1679,7 +1712,54 @@ sv_2pv(register SV *sv, STRLEN *lp) if (!sv) s = "NULLREF"; else { + MAGIC *mg; + switch (SvTYPE(sv)) { + case SVt_PVMG: + if ( ((SvFLAGS(sv) & + (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) + == (SVs_OBJECT|SVs_RMG)) + && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp") + && (mg = mg_find(sv, 'r'))) { + dTHR; + regexp *re = (regexp *)mg->mg_obj; + + if (!mg->mg_ptr) { + char *fptr = "msix"; + char reflags[6]; + char ch; + int left = 0; + int right = 4; + U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12; + + while(ch = *fptr++) { + if(reganch & 1) { + reflags[left++] = ch; + } + else { + reflags[right--] = ch; + } + reganch >>= 1; + } + if(left != 4) { + reflags[left] = '-'; + left = 5; + } + + mg->mg_len = re->prelen + 4 + left; + New(616, mg->mg_ptr, mg->mg_len + 1 + left, char); + Copy("(?", mg->mg_ptr, 2, char); + Copy(reflags, mg->mg_ptr+2, left, char); + Copy(":", mg->mg_ptr+left+2, 1, char); + Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); + mg->mg_ptr[mg->mg_len - 1] = ')'; + mg->mg_ptr[mg->mg_len] = 0; + } + PL_reginterp_cnt += re->program[0].next_off; + *lp = mg->mg_len; + return mg->mg_ptr; + } + /* Fall through */ case SVt_NULL: case SVt_IV: case SVt_NV: @@ -1687,14 +1767,13 @@ sv_2pv(register SV *sv, STRLEN *lp) case SVt_PV: case SVt_PVIV: case SVt_PVNV: - case SVt_PVBM: - case SVt_PVMG: s = "SCALAR"; break; + case SVt_PVBM: s = "SCALAR"; break; case SVt_PVLV: s = "LVALUE"; break; case SVt_PVAV: s = "ARRAY"; break; case SVt_PVHV: s = "HASH"; break; case SVt_PVCV: s = "CODE"; break; case SVt_PVGV: s = "GLOB"; break; - case SVt_PVFM: s = "FORMLINE"; break; + case SVt_PVFM: s = "FORMAT"; break; case SVt_PVIO: s = "IO"; break; default: s = "UNKNOWN"; break; } @@ -1721,8 +1800,11 @@ sv_2pv(register SV *sv, STRLEN *lp) tsv = Nullsv; goto tokensave; } - if (dowarn) - warn(warn_uninit); + { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, warn_uninit); + } *lp = 0; return ""; } @@ -1769,8 +1851,8 @@ sv_2pv(register SV *sv, STRLEN *lp) } else { dTHR; - if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + warner(WARN_UNINITIALIZED, warn_uninit); *lp = 0; return ""; } @@ -1879,7 +1961,7 @@ sv_setsv(SV *dstr, register SV *sstr) return; SV_CHECK_THINKFIRST(dstr); if (!sstr) - sstr = &sv_undef; + sstr = &PL_sv_undef; stype = SvTYPE(sstr); dtype = SvTYPE(dstr); @@ -1897,26 +1979,53 @@ sv_setsv(SV *dstr, register SV *sstr) switch (stype) { case SVt_NULL: - (void)SvOK_off(dstr); - return; + undef_sstr: + if (dtype != SVt_PVGV) { + (void)SvOK_off(dstr); + return; + } + break; case SVt_IV: - if (dtype != SVt_IV && dtype < SVt_PVIV) { - if (dtype < SVt_IV) + if (SvIOK(sstr)) { + switch (dtype) { + case SVt_NULL: sv_upgrade(dstr, SVt_IV); - else if (dtype == SVt_NV) + break; + case SVt_NV: sv_upgrade(dstr, SVt_PVNV); - else + break; + case SVt_RV: + case SVt_PV: sv_upgrade(dstr, SVt_PVIV); + break; + } + (void)SvIOK_only(dstr); + SvIVX(dstr) = SvIVX(sstr); + SvTAINT(dstr); + return; } - break; + goto undef_sstr; + case SVt_NV: - if (dtype != SVt_NV && dtype < SVt_PVNV) { - if (dtype < SVt_NV) + if (SvNOK(sstr)) { + switch (dtype) { + case SVt_NULL: + case SVt_IV: sv_upgrade(dstr, SVt_NV); - else + break; + case SVt_RV: + case SVt_PV: + case SVt_PVIV: sv_upgrade(dstr, SVt_PVNV); + break; + } + SvNVX(dstr) = SvNVX(sstr); + (void)SvNOK_only(dstr); + SvTAINT(dstr); + return; } - break; + goto undef_sstr; + case SVt_RV: if (dtype < SVt_RV) sv_upgrade(dstr, SVt_RV); @@ -1924,7 +2033,7 @@ sv_setsv(SV *dstr, register SV *sstr) SvTYPE(SvRV(sstr)) == SVt_PVGV) { sstr = SvRV(sstr); if (sstr == dstr) { - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_on(dstr); GvMULTI_on(dstr); return; @@ -1945,14 +2054,13 @@ sv_setsv(SV *dstr, register SV *sstr) if (dtype < SVt_PVNV) sv_upgrade(dstr, SVt_PVNV); break; - case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: case SVt_PVIO: - if (op) + if (PL_op) croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0), - op_name[op->op_type]); + op_name[PL_op->op_type]); else croak("Bizarre copy of %s", sv_reftype(sstr, 0)); break; @@ -1971,8 +2079,8 @@ sv_setsv(SV *dstr, register SV *sstr) SvFAKE_on(dstr); /* can coerce to non-glob */ } /* ahem, death to those who redefine active sort subs */ - else if (curstack == sortstack - && GvCV(dstr) && sortcop == CvSTART(GvCV(dstr))) + else if (PL_curstackinfo->si_type == PERLSI_SORT + && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr))) croak("Can't redefine active sort subroutine %s", GvNAME(dstr)); (void)SvOK_off(dstr); @@ -1980,7 +2088,7 @@ sv_setsv(SV *dstr, register SV *sstr) gp_free((GV*)dstr); GvGP(dstr) = gp_ref(GvGP(sstr)); SvTAINT(dstr); - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_on(dstr); GvMULTI_on(dstr); return; @@ -1996,8 +2104,10 @@ sv_setsv(SV *dstr, register SV *sstr) goto glob_assign; } } - if (dtype < stype) - sv_upgrade(dstr, stype); + if (stype == SVt_PVLV) + SvUPGRADE(dstr, SVt_PVNV); + else + SvUPGRADE(dstr, stype); } sflags = SvFLAGS(sstr); @@ -2005,7 +2115,6 @@ sv_setsv(SV *dstr, register SV *sstr) if (sflags & SVf_ROK) { if (dtype >= SVt_PV) { if (dtype == SVt_PVGV) { - dTHR; SV *sref = SvREFCNT_inc(SvRV(sstr)); SV *dref = 0; int intro = GvINTRO(dstr); @@ -2017,7 +2126,7 @@ sv_setsv(SV *dstr, register SV *sstr) Newz(602,gp, 1, GP); GvGP(dstr) = gp_ref(gp); GvSV(dstr) = NEWSV(72,0); - GvLINE(dstr) = curcop->cop_line; + GvLINE(dstr) = PL_curcop->cop_line; GvEGV(dstr) = (GV*)dstr; } GvMULTI_on(dstr); @@ -2028,7 +2137,7 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_AV_on(dstr); break; case SVt_PVHV: @@ -2037,7 +2146,7 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_HV_on(dstr); break; case SVt_PVCV: @@ -2046,7 +2155,7 @@ sv_setsv(SV *dstr, register SV *sstr) SvREFCNT_dec(GvCV(dstr)); GvCV(dstr) = Nullcv; GvCVGEN(dstr) = 0; /* Switch off cacheness. */ - sub_generation++; + PL_sub_generation++; } SAVESPTR(GvCV(dstr)); } @@ -2058,19 +2167,29 @@ sv_setsv(SV *dstr, register SV *sstr) if (!GvCVGEN((GV*)dstr) && (CvROOT(cv) || CvXSUB(cv))) { + SV *const_sv = cv_const_sv(cv); + bool const_changed = TRUE; + if(const_sv) + const_changed = sv_cmp(const_sv, + op_const_sv(CvSTART((CV*)sref), + Nullcv)); /* ahem, death to those who redefine * active sort subs */ - if (curstack == sortstack && - sortcop == CvSTART(cv)) + if (PL_curstackinfo->si_type == PERLSI_SORT && + PL_sortcop == CvSTART(cv)) croak( "Can't redefine active sort subroutine %s", GvENAME((GV*)dstr)); - if (cv_const_sv(cv)) - warn("Constant subroutine %s redefined", - GvENAME((GV*)dstr)); - else if (dowarn) - warn("Subroutine %s redefined", - 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"))) + warner(WARN_REDEFINE, const_sv ? + "Constant subroutine %s redefined" + : "Subroutine %s redefined", + GvENAME((GV*)dstr)); + } } cv_ckproto(cv, (GV*)dstr, SvPOK(sref) ? SvPVX(sref) : Nullch); @@ -2078,9 +2197,9 @@ sv_setsv(SV *dstr, register SV *sstr) GvCV(dstr) = (CV*)sref; GvCVGEN(dstr) = 0; /* Switch off cacheness. */ GvASSUMECV_on(dstr); - sub_generation++; + PL_sub_generation++; } - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_CV_on(dstr); break; case SVt_PVIO: @@ -2096,7 +2215,7 @@ sv_setsv(SV *dstr, register SV *sstr) else dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; - if (curcop->cop_stash != GvSTASH(dstr)) + if (PL_curcop->cop_stash != GvSTASH(dstr)) GvIMPORTED_SV_on(dstr); break; } @@ -2194,7 +2313,12 @@ sv_setsv(SV *dstr, register SV *sstr) SvIVX(dstr) = SvIVX(sstr); } else { - (void)SvOK_off(dstr); + if (dtype == SVt_PVGV) { + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Undefined value assigned to typeglob"); + } + else + (void)SvOK_off(dstr); } SvTAINT(dstr); } @@ -2281,6 +2405,7 @@ sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) (void)SvOK_off(sv); return; } + (void)SvOOK_off(sv); if (SvPVX(sv)) Safefree(SvPVX(sv)); Renew(ptr, len+1, char); @@ -2295,7 +2420,7 @@ sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) void sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len) { - sv_usepvn_mg(sv,ptr,len); + sv_usepvn(sv,ptr,len); SvSETMAGIC(sv); } @@ -2304,7 +2429,7 @@ sv_check_thinkfirst(register SV *sv) { if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) + if (PL_curcop != &PL_compiling) croak(no_modify); } if (SvROK(sv)) @@ -2401,16 +2526,12 @@ sv_catpv(register SV *sv, register char *ptr) void sv_catpv_mg(register SV *sv, register char *ptr) { - sv_catpv_mg(sv,ptr); + sv_catpv(sv,ptr); SvSETMAGIC(sv); } SV * -#ifdef LEAKTEST -newSV(I32 x, STRLEN len) -#else newSV(STRLEN len) -#endif { register SV *sv; @@ -2434,7 +2555,7 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling && !strchr("gBf", how)) + if (PL_curcop != &PL_compiling && !strchr("gBf", how)) croak(no_modify); } if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { @@ -2484,6 +2605,12 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) case 'B': mg->mg_virtual = &vtbl_bm; break; + case 'D': + mg->mg_virtual = &vtbl_regdata; + break; + case 'd': + mg->mg_virtual = &vtbl_regdatum; + break; case 'E': mg->mg_virtual = &vtbl_env; break; @@ -2619,10 +2746,17 @@ sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen) register char *midend; register char *bigend; register I32 i; + STRLEN curlen; + if (!bigstr) croak("Can't modify non-existent substring"); - SvPV_force(bigstr, na); + SvPV_force(bigstr, curlen); + if (offset + len > curlen) { + SvGROW(bigstr, offset+len+1); + Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); + SvCUR_set(bigstr, offset+len); + } i = littlelen - len; if (i > 0) { /* string might grow */ @@ -2718,15 +2852,15 @@ sv_replace(register SV *sv, register SV *nsv) void sv_clear(register SV *sv) { + HV* stash; assert(sv); assert(SvREFCNT(sv) == 0); if (SvOBJECT(sv)) { dTHR; - if (defstash) { /* Still have a symbol table? */ + if (PL_defstash) { /* Still have a symbol table? */ djSP; GV* destructor; - HV* stash; SV tmpref; Zero(&tmpref, 1, SV); @@ -2740,6 +2874,7 @@ sv_clear(register SV *sv) destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); if (destructor) { ENTER; + PUSHSTACKi(PERLSI_DESTROY); SvRV(&tmpref) = SvREFCNT_inc(sv); EXTEND(SP, 2); PUSHMARK(SP); @@ -2748,6 +2883,7 @@ sv_clear(register SV *sv) perl_call_sv((SV*)GvCV(destructor), G_DISCARD|G_EVAL|G_KEEPERR); SvREFCNT(sv)--; + POPSTACK; LEAVE; } } while (SvOBJECT(sv) && SvSTASH(sv) != stash); @@ -2759,10 +2895,10 @@ sv_clear(register SV *sv) SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ SvOBJECT_off(sv); /* Curse the object. */ if (SvTYPE(sv) != SVt_PVIO) - --sv_objcount; /* XXX Might want something more general */ + --PL_sv_objcount; /* XXX Might want something more general */ } if (SvREFCNT(sv)) { - if (in_clean_objs) + if (PL_in_clean_objs) croak("DESTROY created new reference to dead object"); /* DESTROY gave object new lease on life */ return; @@ -2770,9 +2906,11 @@ sv_clear(register SV *sv) } if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) mg_free(sv); + stash = NULL; switch (SvTYPE(sv)) { case SVt_PVIO: - if (IoIFP(sv) != PerlIO_stdin() && + if (IoIFP(sv) && + IoIFP(sv) != PerlIO_stdin() && IoIFP(sv) != PerlIO_stdout() && IoIFP(sv) != PerlIO_stderr()) io_close((IO*)sv); @@ -2792,12 +2930,18 @@ sv_clear(register SV *sv) case SVt_PVAV: av_undef((AV*)sv); break; + case SVt_PVLV: + SvREFCNT_dec(LvTARG(sv)); + goto freescalar; case SVt_PVGV: gp_free((GV*)sv); Safefree(GvNAME(sv)); - SvREFCNT_dec(GvSTASH(sv)); + /* cannot decrease stash refcount yet, as we might recursively delete + ourselves when the refcnt drops to zero. Delay SvREFCNT_dec + of stash until current sv is completely gone. + -- JohnPC, 27 Mar 1998 */ + stash = GvSTASH(sv); /* FALL THROUGH */ - case SVt_PVLV: case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -2857,7 +3001,13 @@ sv_clear(register SV *sv) break; case SVt_PVGV: del_XPVGV(SvANY(sv)); - break; + /* code duplication for increased performance. */ + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; + /* decrease refcount of the stash that owns this GV, if any */ + if (stash) + SvREFCNT_dec(stash); + return; /* not break, SvFLAGS reset already happened */ case SVt_PVBM: del_XPVBM(SvANY(sv)); break; @@ -2876,35 +3026,44 @@ SV * sv_newref(SV *sv) { if (sv) - SvREFCNT(sv)++; + ATOMIC_INC(SvREFCNT(sv)); return sv; } void sv_free(SV *sv) { + int refcount_is_zero; + if (!sv) return; - if (SvREADONLY(sv)) { - if (sv == &sv_undef || sv == &sv_yes || sv == &sv_no) - return; - } if (SvREFCNT(sv) == 0) { if (SvFLAGS(sv) & SVf_BREAK) return; - if (in_clean_all) /* All is fair */ + if (PL_in_clean_all) /* All is fair */ return; + if (SvREADONLY(sv) && SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = (~(U32)0)/2; + return; + } warn("Attempt to free unreferenced scalar"); return; } - if (--SvREFCNT(sv) > 0) + ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv)); + if (!refcount_is_zero) return; #ifdef DEBUGGING if (SvTEMP(sv)) { - warn("Attempt to free temp prematurely: %s", SvPEEK(sv)); + warn("Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv); return; } #endif + if (SvREADONLY(sv) && SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = (~(U32)0)/2; + return; + } sv_clear(sv); if (! SvREFCNT(sv)) del_SV(sv); @@ -2926,6 +3085,85 @@ sv_len(register SV *sv) return len; } +STRLEN +sv_len_utf8(register SV *sv) +{ + U8 *s; + U8 *send; + STRLEN len; + + if (!sv) + return 0; + +#ifdef NOTYET + if (SvGMAGICAL(sv)) + len = mg_length(sv); + else +#endif + s = (U8*)SvPV(sv, len); + send = s + len; + len = 0; + while (s < send) { + s += UTF8SKIP(s); + len++; + } + return len; +} + +void +sv_pos_u2b(register SV *sv, I32* offsetp, I32* lenp) +{ + U8 *start; + U8 *s; + U8 *send; + I32 uoffset = *offsetp; + STRLEN len; + + if (!sv) + return; + + start = s = (U8*)SvPV(sv, len); + send = s + len; + while (s < send && uoffset--) + s += UTF8SKIP(s); + *offsetp = s - start; + if (lenp) { + I32 ulen = *lenp; + start = s; + while (s < send && ulen--) + s += UTF8SKIP(s); + *lenp = s - start; + } + return; +} + +void +sv_pos_b2u(register SV *sv, I32* offsetp) +{ + U8 *s; + U8 *send; + STRLEN len; + + if (!sv) + return; + + s = (U8*)SvPV(sv, len); + if (len < *offsetp) + croak("panic: bad byte offset"); + send = s + *offsetp; + len = 0; + while (s < send) { + s += UTF8SKIP(s); + ++len; + } + if (s != send) { + warn("Malformed UTF-8 character"); + --len; + } + *offsetp = len; + return; +} + I32 sv_eq(register SV *str1, register SV *str2) { @@ -2987,7 +3225,7 @@ sv_cmp_locale(register SV *sv1, register SV *sv2) STRLEN len1, len2; I32 retval; - if (collation_standard) + if (PL_collation_standard) goto raw_compare; len1 = 0; @@ -3039,7 +3277,7 @@ sv_collxfrm(SV *sv, STRLEN *nxp) MAGIC *mg; mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL; - if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) { + if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { char *s, *xf; STRLEN len, xlen; @@ -3050,7 +3288,7 @@ sv_collxfrm(SV *sv, STRLEN *nxp) if (SvREADONLY(sv)) { SAVEFREEPV(xf); *nxp = xlen; - return xf + sizeof(collation_ix); + return xf + sizeof(PL_collation_ix); } if (! mg) { sv_magic(sv, 0, 'o', 0, 0); @@ -3069,7 +3307,7 @@ sv_collxfrm(SV *sv, STRLEN *nxp) } if (mg && mg->mg_ptr) { *nxp = mg->mg_len; - return mg->mg_ptr + sizeof(collation_ix); + return mg->mg_ptr + sizeof(PL_collation_ix); } else { *nxp = 0; @@ -3094,19 +3332,40 @@ sv_gets(register SV *sv, register PerlIO *fp, I32 append) (void)SvUPGRADE(sv, SVt_PV); SvSCREAM_off(sv); - if (RsSNARF(rs)) { + if (RsSNARF(PL_rs)) { rsptr = NULL; rslen = 0; } - else if (RsPARA(rs)) { + else if (RsRECORD(PL_rs)) { + I32 recsize, bytesread; + char *buffer; + + /* Grab the size of the record we're getting */ + recsize = SvIV(SvRV(PL_rs)); + (void)SvPOK_only(sv); /* Validate pointer */ + buffer = SvGROW(sv, recsize + 1); + /* Go yank in */ +#ifdef VMS + /* VMS wants read instead of fread, because fread doesn't respect */ + /* RMS record boundaries. This is not necessarily a good thing to be */ + /* doing, but we've got no other real choice */ + bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize); +#else + bytesread = PerlIO_read(fp, buffer, recsize); +#endif + SvCUR_set(sv, bytesread); + buffer[bytesread] = '\0'; + return(SvCUR(sv) ? SvPVX(sv) : Nullch); + } + else if (RsPARA(PL_rs)) { rsptr = "\n\n"; rslen = 2; } else - rsptr = SvPV(rs, rslen); + rsptr = SvPV(PL_rs, rslen); rslast = rslen ? rsptr[rslen - 1] : '\0'; - if (RsPARA(rs)) { /* have to do this both before and after */ + if (RsPARA(PL_rs)) { /* have to do this both before and after */ do { /* to make sure file boundaries work right */ if (PerlIO_eof(fp)) return 0; @@ -3303,7 +3562,7 @@ screamer2: } } - if (RsPARA(rs)) { /* have to do this both before and after */ + if (RsPARA(PL_rs)) { /* have to do this both before and after */ while (i != EOF) { /* to make sure file boundaries work right */ i = PerlIO_getc(fp); if (i != '\n') { @@ -3332,14 +3591,17 @@ sv_inc(register SV *sv) if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) + if (PL_curcop != &PL_compiling) croak(no_modify); } if (SvROK(sv)) { + IV i; #ifdef OVERLOAD - if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return; + if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return; #endif /* OVERLOAD */ - sv_unref(sv); + i = (IV)SvRV(sv); + sv_unref(sv); + sv_setiv(sv, i); } } if (SvGMAGICAL(sv)) @@ -3382,10 +3644,24 @@ sv_inc(register SV *sv) *(d--) = '0'; } else { +#ifdef EBCDIC + /* MKS: The original code here died if letters weren't consecutive. + * at least it didn't have to worry about non-C locales. The + * new code assumes that ('z'-'a')==('Z'-'A'), letters are + * arranged in order (although not consecutively) and that only + * [A-Za-z] are accepted by isALPHA in the C locale. + */ + if (*d != 'z' && *d != 'Z') { + do { ++*d; } while (!isALPHA(*d)); + return; + } + *(d--) -= 'z' - 'a'; +#else ++*d; if (isALPHA(*d)) return; *(d--) -= 'z' - 'a' + 1; +#endif } } /* oh,oh, the number grew */ @@ -3409,14 +3685,17 @@ sv_dec(register SV *sv) if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) + if (PL_curcop != &PL_compiling) croak(no_modify); } if (SvROK(sv)) { + IV i; #ifdef OVERLOAD - if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return; + if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return; #endif /* OVERLOAD */ - sv_unref(sv); + i = (IV)SvRV(sv); + sv_unref(sv); + sv_setiv(sv, i); } } if (SvGMAGICAL(sv)) @@ -3456,8 +3735,8 @@ STATIC void sv_mortalgrow(void) { dTHR; - tmps_max += (tmps_max < 512) ? 128 : 512; - Renew(tmps_stack, tmps_max, SV*); + PL_tmps_max += (PL_tmps_max < 512) ? 128 : 512; + Renew(PL_tmps_stack, PL_tmps_max, SV*); } SV * @@ -3471,9 +3750,9 @@ sv_mortalcopy(SV *oldstr) SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv_setsv(sv,oldstr); - if (++tmps_ix >= tmps_max) + if (++PL_tmps_ix >= PL_tmps_max) sv_mortalgrow(); - tmps_stack[tmps_ix] = sv; + PL_tmps_stack[PL_tmps_ix] = sv; SvTEMP_on(sv); return sv; } @@ -3488,9 +3767,9 @@ sv_newmortal(void) SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = SVs_TEMP; - if (++tmps_ix >= tmps_max) + if (++PL_tmps_ix >= PL_tmps_max) sv_mortalgrow(); - tmps_stack[tmps_ix] = sv; + PL_tmps_stack[PL_tmps_ix] = sv; return sv; } @@ -3502,11 +3781,11 @@ sv_2mortal(register SV *sv) dTHR; if (!sv) return sv; - if (SvREADONLY(sv) && curcop != &compiling) - croak(no_modify); - if (++tmps_ix >= tmps_max) + if (SvREADONLY(sv) && SvIMMORTAL(sv)) + return sv; + if (++PL_tmps_ix >= PL_tmps_max) sv_mortalgrow(); - tmps_stack[tmps_ix] = sv; + PL_tmps_stack[PL_tmps_ix] = sv; SvTEMP_on(sv); return sv; } @@ -3539,16 +3818,8 @@ newSVpvn(char *s, STRLEN len) return sv; } -#ifdef I_STDARG SV * newSVpvf(const char* pat, ...) -#else -/*VARARGS0*/ -SV * -newSVpvf(pat, va_alist) -const char *pat; -va_dcl -#endif { register SV *sv; va_list args; @@ -3557,11 +3828,7 @@ va_dcl SvANY(sv) = 0; SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); return sv; @@ -3595,7 +3862,7 @@ newSViv(IV i) } SV * -newRV(SV *tmpRef) +newRV_noinc(SV *tmpRef) { dTHR; register SV *sv; @@ -3606,21 +3873,15 @@ newRV(SV *tmpRef) SvFLAGS(sv) = 0; sv_upgrade(sv, SVt_RV); SvTEMP_off(tmpRef); - SvRV(sv) = SvREFCNT_inc(tmpRef); + SvRV(sv) = tmpRef; SvROK_on(sv); return sv; } - - SV * -Perl_newRV_noinc(SV *tmpRef) +newRV(SV *tmpRef) { - register SV *sv; - - sv = newRV(tmpRef); - SvREFCNT_dec(tmpRef); - return sv; + return newRV_noinc(SvREFCNT_inc(tmpRef)); } /* make an exact duplicate of old */ @@ -3666,7 +3927,7 @@ sv_reset(register char *s, HV *stash) if (!*s) { /* reset ?? searches */ for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) { - pm->op_pmflags &= ~PMf_USED; + pm->op_pmdynflags &= ~PMdf_USED; } return; } @@ -3707,7 +3968,7 @@ sv_reset(register char *s, HV *stash) if (GvHV(gv) && !HvNAME(GvHV(gv))) { hv_clear(GvHV(gv)); #ifndef VMS /* VMS has no environ array */ - if (gv == envgv) + if (gv == PL_envgv) environ[0] = Nullch; #endif } @@ -3737,13 +3998,13 @@ sv_2io(SV *sv) croak(no_usym, "filehandle"); if (SvROK(sv)) return sv_2io(SvRV(sv)); - gv = gv_fetchpv(SvPV(sv,na), FALSE, SVt_PVIO); + gv = gv_fetchpv(SvPV(sv,PL_na), FALSE, SVt_PVIO); if (gv) io = GvIO(gv); else io = 0; if (!io) - croak("Bad filehandle: %s", SvPV(sv,na)); + croak("Bad filehandle: %s", SvPV(sv,PL_na)); break; } return io; @@ -3786,7 +4047,7 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) if (isGV(sv)) gv = (GV*)sv; else - gv = gv_fetchpv(SvPV(sv, na), lref, SVt_PVCV); + gv = gv_fetchpv(SvPV(sv, PL_na), lref, SVt_PVCV); *gvp = gv; if (!gv) return Nullcv; @@ -3803,7 +4064,7 @@ sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref) Nullop); LEAVE; if (!GvCVu(gv)) - croak("Unable to create sub named \"%s\"", SvPV(sv,na)); + croak("Unable to create sub named \"%s\"", SvPV(sv,PL_na)); } return GvCVu(gv); } @@ -3878,7 +4139,7 @@ sv_pvn_force(SV *sv, STRLEN *lp) if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) + if (PL_curcop != &PL_compiling) croak(no_modify); } @@ -3895,7 +4156,7 @@ sv_pvn_force(SV *sv, STRLEN *lp) else { dTHR; croak("Can't coerce %s to string in %s", sv_reftype(sv,0), - op_name[op->op_type]); + op_name[PL_op->op_type]); } } else @@ -3946,7 +4207,7 @@ sv_reftype(SV *sv, int ob) case SVt_PVHV: return "HASH"; case SVt_PVCV: return "CODE"; case SVt_PVGV: return "GLOB"; - case SVt_PVFM: return "FORMLINE"; + case SVt_PVFM: return "FORMAT"; default: return "UNKNOWN"; } } @@ -4017,7 +4278,7 @@ SV* sv_setref_pv(SV *rv, char *classname, void *pv) { if (!pv) { - sv_setsv(rv, &sv_undef); + sv_setsv(rv, &PL_sv_undef); SvSETMAGIC(rv); } else @@ -4059,13 +4320,13 @@ sv_bless(SV *sv, HV *stash) croak(no_modify); if (SvOBJECT(tmpRef)) { if (SvTYPE(tmpRef) != SVt_PVIO) - --sv_objcount; + --PL_sv_objcount; SvREFCNT_dec(SvSTASH(tmpRef)); } } SvOBJECT_on(tmpRef); if (SvTYPE(tmpRef) != SVt_PVIO) - ++sv_objcount; + ++PL_sv_objcount; (void)SvUPGRADE(tmpRef, SVt_PVMG); SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash); @@ -4086,6 +4347,10 @@ sv_unglob(SV *sv) SvFAKE_off(sv); if (GvGP(sv)) gp_free((GV*)sv); + if (GvSTASH(sv)) { + SvREFCNT_dec(GvSTASH(sv)); + GvSTASH(sv) = Nullhv; + } sv_unmagic(sv, '*'); Safefree(GvNAME(sv)); GvMULTI_off(sv); @@ -4174,92 +4439,40 @@ sv_setpviv_mg(SV *sv, IV iv) SvSETMAGIC(sv); } -#ifdef I_STDARG void sv_setpvf(SV *sv, const char* pat, ...) -#else -/*VARARGS0*/ -void -sv_setpvf(sv, pat, va_alist) - SV *sv; - const char *pat; - va_dcl -#endif { va_list args; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); } -#ifdef I_STDARG void sv_setpvf_mg(SV *sv, const char* pat, ...) -#else -/*VARARGS0*/ -void -sv_setpvf_mg(sv, pat, va_alist) - SV *sv; - const char *pat; - va_dcl -#endif { va_list args; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); SvSETMAGIC(sv); } -#ifdef I_STDARG void sv_catpvf(SV *sv, const char* pat, ...) -#else -/*VARARGS0*/ -void -sv_catpvf(sv, pat, va_alist) - SV *sv; - const char *pat; - va_dcl -#endif { va_list args; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); } -#ifdef I_STDARG void sv_catpvf_mg(SV *sv, const char* pat, ...) -#else -/*VARARGS0*/ -void -sv_catpvf_mg(sv, pat, va_alist) - SV *sv; - const char *pat; - va_dcl -#endif { va_list args; -#ifdef I_STDARG va_start(args, pat); -#else - va_start(args); -#endif sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); SvSETMAGIC(sv); @@ -4322,6 +4535,7 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, STRLEN precis = 0; char esignbuf[4]; + U8 utf8buf[10]; STRLEN esignlen = 0; char *eptr = Nullch; @@ -4450,6 +4664,16 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, goto string; case 'c': + if (IN_UTF8) { + if (args) + uv = va_arg(*args, int); + else + uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; + + eptr = (char*)utf8buf; + elen = uv_to_utf8((U8*)eptr, uv) - utf8buf; + goto string; + } if (args) c = va_arg(*args, int); else @@ -4468,8 +4692,19 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, elen = sizeof nullstr - 1; } } - else if (svix < svmax) + else if (svix < svmax) { eptr = SvPVx(svargs[svix++], elen); + if (IN_UTF8) { + if (has_precis && precis < elen) { + I32 p = precis; + sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */ + precis = p; + } + if (width) { /* fudge width (can't fudge elen) */ + width += elen - sv_len_utf8(svargs[svix - 1]); + } + } + } goto string; case '_': @@ -4573,6 +4808,8 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, switch (base) { unsigned dig; case 16: + if (!uv) + alt = FALSE; p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef"; do { dig = uv & 15; @@ -4599,8 +4836,12 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, break; } elen = (ebuf + sizeof ebuf) - eptr; - if (has_precis && precis > elen) - zeros = precis - elen; + if (has_precis) { + if (precis > elen) + zeros = precis - elen; + else if (precis == 0 && elen == 1 && *eptr == '0') + elen = 0; + } break; /* FLOATING POINT */ @@ -4698,17 +4939,17 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, default: unknown: - if (!args && dowarn && - (op->op_type == OP_PRTF || op->op_type == OP_SPRINTF)) { + if (!args && ckWARN(WARN_PRINTF) && + (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) { SV *msg = sv_newmortal(); sv_setpvf(msg, "Invalid conversion in %s: ", - (op->op_type == OP_PRTF) ? "printf" : "sprintf"); + (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); if (c) sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"", c & 0xFF); else sv_catpv(msg, "end of string"); - warn("%_", msg); /* yes, this is reentrant */ + warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ @@ -4762,10 +5003,10 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, } } -#ifdef DEBUGGING void sv_dump(SV *sv) { +#ifdef DEBUGGING SV *d = sv_newmortal(); char *s; U32 flags; @@ -4964,7 +5205,7 @@ sv_dump(SV *sv) break; case SVt_PVCV: if (SvPOK(sv)) - PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,na)); + PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,PL_na)); /* FALL THROUGH */ case SVt_PVFM: PerlIO_printf(Perl_debug_log, " STASH = 0x%lx\n", (long)CvSTASH(sv)); @@ -4994,7 +5235,8 @@ sv_dump(SV *sv) case SVt_PVGV: PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", GvNAME(sv)); PerlIO_printf(Perl_debug_log, " NAMELEN = %ld\n", (long)GvNAMELEN(sv)); - PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv))); + PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", + SvTYPE(GvSTASH(sv)) == SVt_PVHV ? HvNAME(GvSTASH(sv)) : "(deleted)"); PerlIO_printf(Perl_debug_log, " GP = 0x%lx\n", (long)GvGP(sv)); PerlIO_printf(Perl_debug_log, " SV = 0x%lx\n", (long)GvSV(sv)); PerlIO_printf(Perl_debug_log, " REFCNT = %ld\n", (long)GvREFCNT(sv)); @@ -5028,14 +5270,5 @@ sv_dump(SV *sv) PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv)); break; } +#endif /* DEBUGGING */ } -#else -void -sv_dump(SV *sv) -{ -} -#endif - - - -