X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=90a4e0d8fd3924baa8ed1fa744127fe93a4e4eb4;hb=134ca994cfefe0f613d43505a885e4fc2100b05c;hp=df3fbe3aeb8e501a441641cce27264b1e477e6c3;hpb=00db4c452819e776e72467584ab4e9617d012f7b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index df3fbe3..90a4e0d 100644 --- a/sv.c +++ b/sv.c @@ -36,10 +36,6 @@ #endif #endif -#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__) -# define FAST_SV_GETS -#endif - #ifdef PERL_OBJECT #define FCALL this->*f #define VTBL this->*vtbl @@ -49,10 +45,10 @@ static IV asIV _((SV* sv)); static UV asUV _((SV* sv)); static SV *more_sv _((void)); -static XPVIV *more_xiv _((void)); -static XPVNV *more_xnv _((void)); -static XPV *more_xpv _((void)); -static XRV *more_xrv _((void)); +static void more_xiv _((void)); +static void more_xnv _((void)); +static void more_xpv _((void)); +static void more_xrv _((void)); static XPVIV *new_xiv _((void)); static XPVNV *new_xnv _((void)); static XPV *new_xpv _((void)); @@ -121,7 +117,7 @@ static void reg_add(sv) SV* sv; { - if (sv_count >= (registry_size >> 1)) + if (PL_sv_count >= (registry_size >> 1)) { SV **oldreg = registry; I32 oldsize = registry_size; @@ -142,7 +138,7 @@ SV* sv; } REG_ADD(sv); - ++sv_count; + ++PL_sv_count; } static void @@ -150,7 +146,7 @@ reg_remove(sv) SV* sv; { REG_REMOVE(sv); - --sv_count; + --PL_sv_count; } static void @@ -184,23 +180,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 +207,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 +217,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 +251,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 +275,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 +295,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) @@ -355,8 +351,6 @@ do_clean_named_objs(SV *sv) DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));) SvREFCNT_dec(sv); } - else if (GvSV(sv)) - do_clean_objs(GvSV(sv)); } } #endif @@ -364,18 +358,19 @@ do_clean_named_objs(SV *sv) 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 + /* some barnacles may yet remain, clinging to typeglobs */ visit(FUNC_NAME_TO_PTR(do_clean_named_objs)); #endif - visit(FUNC_NAME_TO_PTR(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); } @@ -383,9 +378,9 @@ do_clean_all(SV *sv) void sv_clean_all(void) { - in_clean_all = TRUE; + PL_in_clean_all = TRUE; visit(FUNC_NAME_TO_PTR(do_clean_all)); - in_clean_all = FALSE; + PL_in_clean_all = FALSE; } void @@ -397,7 +392,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); @@ -406,80 +401,85 @@ sv_free_arenas(void) Safefree((void *)sva); } - if (nice_chunk) - Safefree(nice_chunk); - nice_chunk = Nullch; - nice_chunk_size = 0; - 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; - /* - * See comment in more_xiv() -- RAM. - */ - xiv_root = (IV**)*xiv; - return (XPVIV*)((char*)xiv - sizeof(XPV)); - } - return more_xiv(); + IV* xiv; + LOCK_SV_MUTEX; + if (!PL_xiv_root) + more_xiv(); + xiv = PL_xiv_root; + /* + * See comment in more_xiv() -- RAM. + */ + PL_xiv_root = *(IV**)xiv; + UNLOCK_SV_MUTEX; + return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv)); } 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)); + LOCK_SV_MUTEX; + *(IV**)xiv = PL_xiv_root; + PL_xiv_root = xiv; + UNLOCK_SV_MUTEX; } -STATIC XPVIV* +STATIC void 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; - return new_xiv(); + *(IV**)xiv = 0; } STATIC XPVNV* new_xnv(void) { double* xnv; - if (xnv_root) { - xnv = xnv_root; - xnv_root = *(double**)xnv; - return (XPVNV*)((char*)xnv - sizeof(XPVIV)); - } - return more_xnv(); + LOCK_SV_MUTEX; + if (!PL_xnv_root) + more_xnv(); + xnv = PL_xnv_root; + PL_xnv_root = *(double**)xnv; + UNLOCK_SV_MUTEX; + return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv)); } 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)); + LOCK_SV_MUTEX; + *(double**)xnv = PL_xnv_root; + PL_xnv_root = xnv; + UNLOCK_SV_MUTEX; } -STATIC XPVNV* +STATIC void more_xnv(void) { register double* xnv; @@ -487,83 +487,86 @@ 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++; } *(double**)xnv = 0; - return new_xnv(); } STATIC XRV* new_xrv(void) { XRV* xrv; - if (xrv_root) { - xrv = xrv_root; - xrv_root = (XRV*)xrv->xrv_rv; - return xrv; - } - return more_xrv(); + LOCK_SV_MUTEX; + if (!PL_xrv_root) + more_xrv(); + xrv = PL_xrv_root; + PL_xrv_root = (XRV*)xrv->xrv_rv; + UNLOCK_SV_MUTEX; + return xrv; } STATIC void del_xrv(XRV *p) { - p->xrv_rv = (SV*)xrv_root; - xrv_root = p; + LOCK_SV_MUTEX; + p->xrv_rv = (SV*)PL_xrv_root; + PL_xrv_root = p; + UNLOCK_SV_MUTEX; } -STATIC XRV* +STATIC void 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); xrv++; } xrv->xrv_rv = 0; - return new_xrv(); } STATIC XPV* new_xpv(void) { XPV* xpv; - if (xpv_root) { - xpv = xpv_root; - xpv_root = (XPV*)xpv->xpv_pv; - return xpv; - } - return more_xpv(); + LOCK_SV_MUTEX; + if (!PL_xpv_root) + more_xpv(); + xpv = PL_xpv_root; + PL_xpv_root = (XPV*)xpv->xpv_pv; + UNLOCK_SV_MUTEX; + return xpv; } STATIC void del_xpv(XPV *p) { - p->xpv_pv = (char*)xpv_root; - xpv_root = p; + LOCK_SV_MUTEX; + p->xpv_pv = (char*)PL_xpv_root; + PL_xpv_root = p; + UNLOCK_SV_MUTEX; } -STATIC XPV* +STATIC void 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); xpv++; } xpv->xpv_pv = 0; - return new_xpv(); } #ifdef PURIFY @@ -691,7 +694,7 @@ sv_upgrade(register SV *sv, U32 mt) cur = 0; len = 0; nv = SvNVX(sv); - iv = I_32(nv); + iv = (IV)nv; magic = 0; stash = 0; del_XNV(SvANY(sv)); @@ -937,15 +940,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)) && @@ -1063,7 +1066,7 @@ sv_peek(SV *sv) while (unref--) sv_catpv(t, ")"); } - return SvPV(t, na); + return SvPV(t, PL_na); #else /* DEBUGGING */ return ""; #endif /* DEBUGGING */ @@ -1085,11 +1088,7 @@ sv_backoff(register SV *sv) } char * -#ifndef DOSISH -sv_grow(register SV *sv, register I32 newlen) -#else -sv_grow(SV* sv, unsigned long newlen) -#endif +sv_grow(register SV *sv, register STRLEN newlen) { register char *s; @@ -1118,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); @@ -1158,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]); + PL_op_desc[PL_op->op_type]); } } (void)SvIOK_only(sv); /* validate number */ @@ -1202,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); @@ -1224,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]); + PL_op_name[PL_op->op_type]); } } SvNVX(sv) = num; @@ -1287,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, + PL_op_name[PL_op->op_type]); else - warn("Argument \"%s\" isn't numeric", tmpbuf); + warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); } IV @@ -1312,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, PL_warn_uninit); } return 0; } @@ -1338,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, PL_warn_uninit); + } return 0; } } @@ -1367,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, PL_warn_uninit); return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", @@ -1390,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, PL_warn_uninit); } return 0; } @@ -1413,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, PL_warn_uninit); + } return 0; } } @@ -1438,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, PL_warn_uninit); } return 0; } @@ -1460,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)); @@ -1468,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, PL_warn_uninit); } return 0; } @@ -1486,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, PL_warn_uninit); return 0.0; } } @@ -1516,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, PL_warn_uninit); return 0.0; } SvNOK_on(sv); @@ -1542,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) @@ -1561,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))); } @@ -1676,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, PL_warn_uninit); } *lp = 0; return ""; @@ -1705,10 +1721,43 @@ sv_2pv(register SV *sv, STRLEN *lp) == (SVs_OBJECT|SVs_RMG)) && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp") && (mg = mg_find(sv, 'r'))) { + dTHR; regexp *re = (regexp *)mg->mg_obj; - *lp = re->prelen; - return re->precomp; + 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: @@ -1751,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, PL_warn_uninit); + } *lp = 0; return ""; } @@ -1799,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, PL_warn_uninit); *lp = 0; return ""; } @@ -1909,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); @@ -1927,29 +1979,53 @@ sv_setsv(SV *dstr, register SV *sstr) switch (stype) { case SVt_NULL: + 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); @@ -1957,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; @@ -1982,9 +2058,9 @@ sv_setsv(SV *dstr, register SV *sstr) 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]); + PL_op_name[PL_op->op_type]); else croak("Bizarre copy of %s", sv_reftype(sstr, 0)); break; @@ -2003,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 (curstackinfo->si_type == SI_SORT - && 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); @@ -2012,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; @@ -2039,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); @@ -2051,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); @@ -2062,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: @@ -2071,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: @@ -2080,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)); } @@ -2100,17 +2175,17 @@ sv_setsv(SV *dstr, register SV *sstr) Nullcv)); /* ahem, death to those who redefine * active sort subs */ - if (curstackinfo->si_type == SI_SORT && - 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 (dowarn || (const_changed && const_sv)) { + if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) { if (!(CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))) && strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) - warn(const_sv ? + warner(WARN_REDEFINE, const_sv ? "Constant subroutine %s redefined" : "Subroutine %s redefined", GvENAME((GV*)dstr)); @@ -2122,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: @@ -2140,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; } @@ -2239,8 +2314,8 @@ sv_setsv(SV *dstr, register SV *sstr) } else { if (dtype == SVt_PVGV) { - if (dowarn) - warn("Undefined value assigned to typeglob"); + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Undefined value assigned to typeglob"); } else (void)SvOK_off(dstr); @@ -2330,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); @@ -2353,8 +2429,8 @@ sv_check_thinkfirst(register SV *sv) { if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) - croak(no_modify); + if (PL_curcop != &PL_compiling) + croak(PL_no_modify); } if (SvROK(sv)) sv_unref(sv); @@ -2479,8 +2555,8 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling && !strchr("gBf", how)) - croak(no_modify); + if (PL_curcop != &PL_compiling && !strchr("gBf", how)) + croak(PL_no_modify); } if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) { if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { @@ -2513,101 +2589,106 @@ sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen) switch (how) { case 0: - mg->mg_virtual = &vtbl_sv; + mg->mg_virtual = &PL_vtbl_sv; break; #ifdef OVERLOAD case 'A': - mg->mg_virtual = &vtbl_amagic; + mg->mg_virtual = &PL_vtbl_amagic; break; case 'a': - mg->mg_virtual = &vtbl_amagicelem; + mg->mg_virtual = &PL_vtbl_amagicelem; break; case 'c': mg->mg_virtual = 0; break; #endif /* OVERLOAD */ case 'B': - mg->mg_virtual = &vtbl_bm; + mg->mg_virtual = &PL_vtbl_bm; + break; + case 'D': + mg->mg_virtual = &PL_vtbl_regdata; + break; + case 'd': + mg->mg_virtual = &PL_vtbl_regdatum; break; case 'E': - mg->mg_virtual = &vtbl_env; + mg->mg_virtual = &PL_vtbl_env; break; case 'f': - mg->mg_virtual = &vtbl_fm; + mg->mg_virtual = &PL_vtbl_fm; break; case 'e': - mg->mg_virtual = &vtbl_envelem; + mg->mg_virtual = &PL_vtbl_envelem; break; case 'g': - mg->mg_virtual = &vtbl_mglob; + mg->mg_virtual = &PL_vtbl_mglob; break; case 'I': - mg->mg_virtual = &vtbl_isa; + mg->mg_virtual = &PL_vtbl_isa; break; case 'i': - mg->mg_virtual = &vtbl_isaelem; + mg->mg_virtual = &PL_vtbl_isaelem; break; case 'k': - mg->mg_virtual = &vtbl_nkeys; + mg->mg_virtual = &PL_vtbl_nkeys; break; case 'L': SvRMAGICAL_on(sv); mg->mg_virtual = 0; break; case 'l': - mg->mg_virtual = &vtbl_dbline; + mg->mg_virtual = &PL_vtbl_dbline; break; #ifdef USE_THREADS case 'm': - mg->mg_virtual = &vtbl_mutex; + mg->mg_virtual = &PL_vtbl_mutex; break; #endif /* USE_THREADS */ #ifdef USE_LOCALE_COLLATE case 'o': - mg->mg_virtual = &vtbl_collxfrm; + mg->mg_virtual = &PL_vtbl_collxfrm; break; #endif /* USE_LOCALE_COLLATE */ case 'P': - mg->mg_virtual = &vtbl_pack; + mg->mg_virtual = &PL_vtbl_pack; break; case 'p': case 'q': - mg->mg_virtual = &vtbl_packelem; + mg->mg_virtual = &PL_vtbl_packelem; break; case 'r': - SvRMAGICAL_on(sv); - mg->mg_virtual = &vtbl_regexp; + mg->mg_virtual = &PL_vtbl_regexp; break; case 'S': - mg->mg_virtual = &vtbl_sig; + mg->mg_virtual = &PL_vtbl_sig; break; case 's': - mg->mg_virtual = &vtbl_sigelem; + mg->mg_virtual = &PL_vtbl_sigelem; break; case 't': - mg->mg_virtual = &vtbl_taint; + mg->mg_virtual = &PL_vtbl_taint; mg->mg_len = 1; break; case 'U': - mg->mg_virtual = &vtbl_uvar; + mg->mg_virtual = &PL_vtbl_uvar; break; case 'v': - mg->mg_virtual = &vtbl_vec; + mg->mg_virtual = &PL_vtbl_vec; break; case 'x': - mg->mg_virtual = &vtbl_substr; + mg->mg_virtual = &PL_vtbl_substr; break; case 'y': - mg->mg_virtual = &vtbl_defelem; + mg->mg_virtual = &PL_vtbl_defelem; break; case '*': - mg->mg_virtual = &vtbl_glob; + mg->mg_virtual = &PL_vtbl_glob; break; case '#': - mg->mg_virtual = &vtbl_arylen; + mg->mg_virtual = &PL_vtbl_arylen; break; case '.': - mg->mg_virtual = &vtbl_pos; + mg->mg_virtual = &PL_vtbl_pos; break; case '~': /* Reserved for use by extensions not perl internals. */ /* Useful for attaching extension internal data to perl vars. */ @@ -2777,7 +2858,7 @@ sv_clear(register SV *sv) if (SvOBJECT(sv)) { dTHR; - if (defstash) { /* Still have a symbol table? */ + if (PL_defstash) { /* Still have a symbol table? */ djSP; GV* destructor; SV tmpref; @@ -2793,7 +2874,7 @@ sv_clear(register SV *sv) destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); if (destructor) { ENTER; - PUSHSTACK(SI_DESTROY); + PUSHSTACKi(PERLSI_DESTROY); SvRV(&tmpref) = SvREFCNT_inc(sv); EXTEND(SP, 2); PUSHMARK(SP); @@ -2802,7 +2883,7 @@ sv_clear(register SV *sv) perl_call_sv((SV*)GvCV(destructor), G_DISCARD|G_EVAL|G_KEEPERR); SvREFCNT(sv)--; - POPSTACK(); + POPSTACK; LEAVE; } } while (SvOBJECT(sv) && SvSTASH(sv) != stash); @@ -2814,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; @@ -2828,7 +2909,8 @@ sv_clear(register SV *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); @@ -2848,6 +2930,9 @@ 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)); @@ -2857,7 +2942,6 @@ sv_clear(register SV *sv) -- JohnPC, 27 Mar 1998 */ stash = GvSTASH(sv); /* FALL THROUGH */ - case SVt_PVLV: case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -2953,15 +3037,16 @@ sv_free(SV *sv) 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; } @@ -2970,10 +3055,15 @@ sv_free(SV *sv) 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); @@ -2995,6 +3085,89 @@ 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); + if (s >= send) + s = send; + *offsetp = s - start; + if (lenp) { + I32 ulen = *lenp; + start = s; + while (s < send && ulen--) + s += UTF8SKIP(s); + if (s >= send) + s = send; + *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) { @@ -3056,7 +3229,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; @@ -3108,7 +3281,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; @@ -3119,7 +3292,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); @@ -3138,7 +3311,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; @@ -3163,23 +3336,18 @@ 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 (RsRECORD(rs)) { + else if (RsRECORD(PL_rs)) { I32 recsize, bytesread; char *buffer; /* Grab the size of the record we're getting */ - recsize = SvIV(SvRV(rs)); + recsize = SvIV(SvRV(PL_rs)); (void)SvPOK_only(sv); /* Validate pointer */ - /* Make sure we've got the room to yank in the whole thing */ - if (SvLEN(sv) <= recsize + 3) { - /* No, so make it bigger */ - SvGROW(sv, recsize + 3); - } - buffer = SvPVX(sv); /* Get the location of the final buffer */ + buffer = SvGROW(sv, recsize + 1); /* Go yank in */ #ifdef VMS /* VMS wants read instead of fread, because fread doesn't respect */ @@ -3190,17 +3358,18 @@ sv_gets(register SV *sv, register PerlIO *fp, I32 append) bytesread = PerlIO_read(fp, buffer, recsize); #endif SvCUR_set(sv, bytesread); + buffer[bytesread] = '\0'; return(SvCUR(sv) ? SvPVX(sv) : Nullch); } - else if (RsPARA(rs)) { + 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; @@ -3397,7 +3566,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') { @@ -3423,21 +3592,24 @@ sv_inc(register SV *sv) if (!sv) return; + if (SvGMAGICAL(sv)) + mg_get(sv); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) - croak(no_modify); + if (PL_curcop != &PL_compiling) + croak(PL_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)) - mg_get(sv); flags = SvFLAGS(sv); if (flags & SVp_NOK) { (void)SvNOK_only(sv); @@ -3476,10 +3648,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 */ @@ -3500,21 +3686,24 @@ sv_dec(register SV *sv) if (!sv) return; + if (SvGMAGICAL(sv)) + mg_get(sv); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) - croak(no_modify); + if (PL_curcop != &PL_compiling) + croak(PL_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)) - mg_get(sv); flags = SvFLAGS(sv); if (flags & SVp_NOK) { SvNVX(sv) -= 1.0; @@ -3550,8 +3739,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 * @@ -3565,9 +3754,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; } @@ -3582,9 +3771,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; } @@ -3596,11 +3785,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; } @@ -3677,7 +3866,7 @@ newSViv(IV i) } SV * -newRV(SV *tmpRef) +newRV_noinc(SV *tmpRef) { dTHR; register SV *sv; @@ -3688,21 +3877,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 */ @@ -3770,12 +3953,18 @@ sv_reset(register char *s, HV *stash) } for (i = 0; i <= (I32) HvMAX(stash); i++) { for (entry = HvARRAY(stash)[i]; - entry; - entry = HeNEXT(entry)) { + entry; + entry = HeNEXT(entry)) + { if (!todo[(U8)*HeKEY(entry)]) continue; gv = (GV*)HeVAL(entry); sv = GvSV(gv); + if (SvTHINKFIRST(sv)) { + if (!SvREADONLY(sv) && SvROK(sv)) + sv_unref(sv); + continue; + } (void)SvOK_off(sv); if (SvTYPE(sv) >= SVt_PV) { SvCUR_set(sv, 0); @@ -3789,7 +3978,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 } @@ -3816,16 +4005,16 @@ sv_2io(SV *sv) break; default: if (!SvOK(sv)) - croak(no_usym, "filehandle"); + croak(PL_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; @@ -3868,7 +4057,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; @@ -3885,7 +4074,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); } @@ -3960,8 +4149,8 @@ sv_pvn_force(SV *sv, STRLEN *lp) if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) - croak(no_modify); + if (PL_curcop != &PL_compiling) + croak(PL_no_modify); } if (SvPOK(sv)) { @@ -3977,7 +4166,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]); + PL_op_name[PL_op->op_type]); } } else @@ -4099,7 +4288,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 @@ -4138,16 +4327,16 @@ sv_bless(SV *sv, HV *stash) tmpRef = SvRV(sv); if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { if (SvREADONLY(tmpRef)) - croak(no_modify); + croak(PL_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); @@ -4356,6 +4545,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; @@ -4484,6 +4674,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 @@ -4502,8 +4702,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 '_': @@ -4738,17 +4949,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 ... */ @@ -5004,7 +5215,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));