X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=0495e8acf5cad2db0ce440278df92fcd26084554;hb=aba27d8868c4da5501a93098d949549307dd9a6a;hp=f9872b09292d63f597ed92508321b96223159105;hpb=ec12f1140dd78d67c95825bf881ff58a52e9d030;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index f9872b0..0495e8a 100644 --- a/sv.c +++ b/sv.c @@ -40,13 +40,19 @@ # define FAST_SV_GETS #endif +#ifdef PERL_OBJECT +#define FCALL this->*f +#define VTBL this->*vtbl + +#else /* !PERL_OBJECT */ + 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)); @@ -59,13 +65,17 @@ 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 typedef void (*SVFUNC) _((SV*)); +#define VTBL *vtbl +#define FCALL *f + +#endif /* PERL_OBJECT */ + +#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_check_thinkfirst(sv) #ifdef PURIFY @@ -86,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"); \ @@ -111,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; @@ -132,7 +142,7 @@ SV* sv; } REG_ADD(sv); - ++sv_count; + ++PL_sv_count; } static void @@ -140,7 +150,7 @@ reg_remove(sv) SV* sv; { REG_REMOVE(sv); - --sv_count; + --PL_sv_count; } static void @@ -149,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); } } @@ -174,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(); \ @@ -201,22 +211,22 @@ U32 flags; #define del_SV(p) do { \ LOCK_SV_MUTEX; \ - if (debug & 32768) \ + if (PL_debug & 32768) \ del_sv(p); \ else \ plant_SV(p); \ UNLOCK_SV_MUTEX; \ } while (0) -static void +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) @@ -245,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; @@ -264,14 +274,14 @@ sv_add_arena(char *ptr, U32 size, U32 flags) } /* sv_mutex must be held while calling more_sv() */ -static SV* +STATIC SV* 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 */ @@ -282,25 +292,25 @@ more_sv(void) return sv; } -static void +STATIC void visit(SVFUNC f) { SV* sva; 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) - (*f)(sv); + (FCALL)(sv); } } } #endif /* PURIFY */ -static void +STATIC void do_report_used(SV *sv) { if (SvTYPE(sv) != SVTYPEMASK) { @@ -313,10 +323,10 @@ do_report_used(SV *sv) void sv_report_used(void) { - visit(do_report_used); + visit(FUNC_NAME_TO_PTR(do_report_used)); } -static void +STATIC void do_clean_objs(SV *sv) { SV* rv; @@ -332,43 +342,49 @@ do_clean_objs(SV *sv) } #ifndef DISABLE_DESTRUCTOR_KLUDGE -static void +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 -static bool in_clean_objs = FALSE; - 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 +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); } -static bool in_clean_all = FALSE; - 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 @@ -380,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); @@ -389,76 +405,85 @@ 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* +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 +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* +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 +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; @@ -466,83 +491,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* +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 +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* +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 +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 @@ -581,7 +609,7 @@ more_xpv(void) # define my_safemalloc(s) safemalloc(s) # define my_safefree(s) free(s) #else -static void* +STATIC void* my_safemalloc(MEM_SIZE size) { char *p; @@ -898,10 +926,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; @@ -916,15 +944,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)) && @@ -1042,9 +1070,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) @@ -1095,8 +1125,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); @@ -1135,7 +1173,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 */ @@ -1179,14 +1217,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); @@ -1201,7 +1233,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; @@ -1216,7 +1248,7 @@ sv_setnv_mg(register SV *sv, double num) SvSETMAGIC(sv); } -static void +STATIC void not_a_number(SV *sv) { dTHR; @@ -1264,11 +1296,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 @@ -1289,10 +1321,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; } @@ -1315,8 +1347,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; } } @@ -1344,8 +1379,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", @@ -1367,10 +1402,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; } @@ -1390,8 +1425,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; } } @@ -1415,10 +1453,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; } @@ -1437,7 +1475,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)); @@ -1445,10 +1484,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; } @@ -1463,16 +1502,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; } } @@ -1493,15 +1533,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); @@ -1511,7 +1552,7 @@ sv_2nv(register SV *sv) return SvNVX(sv); } -static IV +STATIC IV asIV(SV *sv) { I32 numtype = looks_like_number(sv); @@ -1519,8 +1560,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) @@ -1529,7 +1573,7 @@ asIV(SV *sv) return (IV) U_V(d); } -static UV +STATIC UV asUV(SV *sv) { I32 numtype = looks_like_number(sv); @@ -1538,8 +1582,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))); } @@ -1653,10 +1700,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 ""; @@ -1673,7 +1720,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: @@ -1681,14 +1775,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; } @@ -1715,8 +1808,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 ""; } @@ -1763,8 +1859,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 ""; } @@ -1873,7 +1969,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); @@ -1891,26 +1987,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); @@ -1918,7 +2041,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; @@ -1943,9 +2066,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]); + op_name[PL_op->op_type]); else croak("Bizarre copy of %s", sv_reftype(sstr, 0)); break; @@ -1964,8 +2087,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); @@ -1973,7 +2096,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; @@ -2000,7 +2123,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); @@ -2012,7 +2134,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); @@ -2023,7 +2145,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: @@ -2032,7 +2154,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: @@ -2041,7 +2163,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)); } @@ -2053,22 +2175,27 @@ 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) { + 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("Subroutine %s redefined", + warner(WARN_REDEFINE, const_sv ? + "Constant subroutine %s redefined" + : "Subroutine %s redefined", GvENAME((GV*)dstr)); } } @@ -2078,9 +2205,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 +2223,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 +2321,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 +2413,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); @@ -2299,12 +2432,12 @@ sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len) SvSETMAGIC(sv); } -static void +STATIC void sv_check_thinkfirst(register SV *sv) { if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) + if (PL_curcop != &PL_compiling) croak(no_modify); } if (SvROK(sv)) @@ -2406,11 +2539,7 @@ sv_catpv_mg(register SV *sv, register char *ptr) } SV * -#ifdef LEAKTEST -newSV(I32 x, STRLEN len) -#else newSV(STRLEN len) -#endif { register SV *sv; @@ -2434,7 +2563,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 +2613,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; @@ -2589,8 +2724,8 @@ sv_unmagic(SV *sv, int type) if (mg->mg_type == type) { MGVTBL* vtbl = mg->mg_virtual; *mgp = mg->mg_moremagic; - if (vtbl && vtbl->svt_free) - (*vtbl->svt_free)(sv, mg); + if (vtbl && (vtbl->svt_free != NULL)) + (VTBL->svt_free)(sv, mg); if (mg->mg_ptr && mg->mg_type != 'g') if (mg->mg_len >= 0) Safefree(mg->mg_ptr); @@ -2619,10 +2754,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 */ @@ -2724,45 +2866,47 @@ 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 ref; + SV tmpref; - Zero(&ref, 1, SV); - sv_upgrade(&ref, SVt_RV); - SvROK_on(&ref); - SvREADONLY_on(&ref); /* DESTROY() could be naughty */ - SvREFCNT(&ref) = 1; + Zero(&tmpref, 1, SV); + sv_upgrade(&tmpref, SVt_RV); + SvROK_on(&tmpref); + SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */ + SvREFCNT(&tmpref) = 1; do { stash = SvSTASH(sv); destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY"); if (destructor) { ENTER; - SvRV(&ref) = SvREFCNT_inc(sv); + PUSHSTACKi(PERLSI_DESTROY); + SvRV(&tmpref) = SvREFCNT_inc(sv); EXTEND(SP, 2); PUSHMARK(SP); - PUSHs(&ref); + PUSHs(&tmpref); PUTBACK; perl_call_sv((SV*)GvCV(destructor), G_DISCARD|G_EVAL|G_KEEPERR); SvREFCNT(sv)--; + POPSTACK; LEAVE; } } while (SvOBJECT(sv) && SvSTASH(sv) != stash); - del_XRV(SvANY(&ref)); + del_XRV(SvANY(&tmpref)); } if (SvOBJECT(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; @@ -2773,7 +2917,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); @@ -2793,6 +2938,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)); @@ -2802,7 +2950,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: @@ -2898,15 +3045,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; } @@ -2915,10 +3063,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); @@ -2934,12 +3087,91 @@ sv_len(register SV *sv) return 0; if (SvGMAGICAL(sv)) - len = mg_len(sv); + len = mg_length(sv); else junk = SvPV(sv, len); 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) { @@ -3001,7 +3233,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; @@ -3053,7 +3285,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; @@ -3064,7 +3296,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); @@ -3083,7 +3315,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; @@ -3108,19 +3340,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; @@ -3317,7 +3570,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') { @@ -3346,14 +3599,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)) @@ -3396,10 +3652,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 */ @@ -3423,14 +3693,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)) @@ -3466,12 +3739,12 @@ sv_dec(register SV *sv) * hopefully we won't free it until it has been assigned to a * permanent location. */ -static void +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 * @@ -3485,9 +3758,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; } @@ -3502,9 +3775,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; } @@ -3516,11 +3789,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; } @@ -3541,9 +3814,7 @@ newSVpv(char *s, STRLEN len) } SV * -newSVpvn(s,len) -char *s; -STRLEN len; +newSVpvn(char *s, STRLEN len) { register SV *sv; @@ -3555,16 +3826,8 @@ 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; @@ -3573,11 +3836,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; @@ -3611,7 +3870,7 @@ newSViv(IV i) } SV * -newRV(SV *ref) +newRV_noinc(SV *tmpRef) { dTHR; register SV *sv; @@ -3621,22 +3880,16 @@ newRV(SV *ref) SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv_upgrade(sv, SVt_RV); - SvTEMP_off(ref); - SvRV(sv) = SvREFCNT_inc(ref); + SvTEMP_off(tmpRef); + SvRV(sv) = tmpRef; SvROK_on(sv); return sv; } - - SV * -Perl_newRV_noinc(SV *ref) +newRV(SV *tmpRef) { - register SV *sv; - - sv = newRV(ref); - SvREFCNT_dec(ref); - return sv; + return newRV_noinc(SvREFCNT_inc(tmpRef)); } /* make an exact duplicate of old */ @@ -3682,7 +3935,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; } @@ -3723,7 +3976,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 } @@ -3753,13 +4006,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; @@ -3802,7 +4055,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; @@ -3819,7 +4072,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); } @@ -3894,7 +4147,7 @@ sv_pvn_force(SV *sv, STRLEN *lp) if (SvREADONLY(sv)) { dTHR; - if (curcop != &compiling) + if (PL_curcop != &PL_compiling) croak(no_modify); } @@ -3911,7 +4164,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 @@ -3962,7 +4215,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"; } } @@ -4033,7 +4286,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 @@ -4066,24 +4319,24 @@ SV* sv_bless(SV *sv, HV *stash) { dTHR; - SV *ref; + SV *tmpRef; if (!SvROK(sv)) croak("Can't bless non-reference value"); - ref = SvRV(sv); - if (SvFLAGS(ref) & (SVs_OBJECT|SVf_READONLY)) { - if (SvREADONLY(ref)) + tmpRef = SvRV(sv); + if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { + if (SvREADONLY(tmpRef)) croak(no_modify); - if (SvOBJECT(ref)) { - if (SvTYPE(ref) != SVt_PVIO) - --sv_objcount; - SvREFCNT_dec(SvSTASH(ref)); + if (SvOBJECT(tmpRef)) { + if (SvTYPE(tmpRef) != SVt_PVIO) + --PL_sv_objcount; + SvREFCNT_dec(SvSTASH(tmpRef)); } } - SvOBJECT_on(ref); - if (SvTYPE(ref) != SVt_PVIO) - ++sv_objcount; - (void)SvUPGRADE(ref, SVt_PVMG); - SvSTASH(ref) = (HV*)SvREFCNT_inc(stash); + SvOBJECT_on(tmpRef); + if (SvTYPE(tmpRef) != SVt_PVIO) + ++PL_sv_objcount; + (void)SvUPGRADE(tmpRef, SVt_PVMG); + SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash); #ifdef OVERLOAD if (Gv_AMG(stash)) @@ -4095,13 +4348,17 @@ sv_bless(SV *sv, HV *stash) return sv; } -static void +STATIC void sv_unglob(SV *sv) { assert(SvTYPE(sv) == SVt_PVGV); 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); @@ -4190,92 +4447,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); @@ -4338,6 +4543,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; @@ -4466,6 +4672,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 @@ -4484,8 +4700,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 '_': @@ -4720,17 +4947,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 ... */ @@ -4784,10 +5011,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; @@ -4986,7 +5213,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)); @@ -5051,14 +5278,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 - - - -