X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=abbf4ed8992cae293ff304b7485bf3d5fd328668;hb=5d0301b7eadf057a17208351b165dd2f711900b5;hp=5e5ba78465beabb58f807f5edd8a1ad94006e421;hpb=4fc877accbeee7820b3c87ff559c82a99f60fe83;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 5e5ba78..abbf4ed 100644 --- a/util.c +++ b/util.c @@ -1,7 +1,7 @@ /* util.c * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -60,6 +60,7 @@ int putenv(char *); static char * S_write_no_mem(pTHX) { + dVAR; /* Can't use PerlIO to write as it allocates memory */ PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem)); @@ -93,7 +94,11 @@ Perl_safesysmalloc(MEM_SIZE size) DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); if (ptr != Nullch) { #ifdef PERL_TRACK_MEMPOOL - *(tTHX*)ptr = aTHX; + ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX; +# ifdef PERL_POISON + ((struct perl_memory_debug_header *)ptr)->size = size; + ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE; +# endif ptr = (Malloc_t)((char*)ptr+sTHX); #endif return ptr; @@ -134,10 +139,18 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) #ifdef PERL_TRACK_MEMPOOL where = (Malloc_t)((char*)where-sTHX); size += sTHX; - if (*(tTHX*)where != aTHX) { - /* int *nowhere = NULL; *nowhere = 0; */ + if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) { Perl_croak_nocontext("panic: realloc from wrong pool"); } +# ifdef PERL_POISON + if (((struct perl_memory_debug_header *)where)->size > size) { + const MEM_SIZE freed_up = + ((struct perl_memory_debug_header *)where)->size - size; + char *start_of_freed = ((char *)where) + size; + Poison(start_of_freed, freed_up, char); + } + ((struct perl_memory_debug_header *)where)->size = size; +# endif #endif #ifdef DEBUGGING if ((long)size < 0) @@ -168,18 +181,33 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Free_t Perl_safesysfree(Malloc_t where) { - dVAR; #if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL) dTHX; +#else + dVAR; #endif DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { #ifdef PERL_TRACK_MEMPOOL where = (Malloc_t)((char*)where-sTHX); - if (*(tTHX*)where != aTHX) { - /* int *nowhere = NULL; *nowhere = 0; */ + if (((struct perl_memory_debug_header *)where)->interpreter != aTHX) { Perl_croak_nocontext("panic: free from wrong pool"); } +# ifdef PERL_POISON + { + if (((struct perl_memory_debug_header *)where)->in_use + == PERL_POISON_FREE) { + Perl_croak_nocontext("panic: duplicate free"); + } + if (((struct perl_memory_debug_header *)where)->in_use + != PERL_POISON_INUSE) { + Perl_croak_nocontext("panic: bad free "); + } + ((struct perl_memory_debug_header *)where)->in_use + = PERL_POISON_FREE; + } + Poison(where, ((struct perl_memory_debug_header *)where)->size, char); +# endif #endif PerlMem_free(where); } @@ -214,7 +242,11 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) if (ptr != Nullch) { memset((void*)ptr, 0, size); #ifdef PERL_TRACK_MEMPOOL - *(tTHX*)ptr = aTHX; + ((struct perl_memory_debug_header *)ptr)->interpreter = aTHX; +# ifdef PERL_POISON + ((struct perl_memory_debug_header *)ptr)->size = size; + ((struct perl_memory_debug_header *)ptr)->in_use = PERL_POISON_INUSE; +# endif ptr = (Malloc_t)((char*)ptr+sTHX); #endif return ptr; @@ -319,30 +351,24 @@ Perl_instr(pTHX_ register const char *big, register const char *little) /* same as instr but allow embedded nulls */ char * -Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend) +Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend) { - register const I32 first = *little; - register const char * const littleend = lend; - - if (!first && little >= littleend) - return (char*)big; - if (bigend - big < littleend - little) - return Nullch; - bigend -= littleend - little++; - while (big <= bigend) { - register const char *s, *x; - if (*big++ != first) - continue; - for (x=big,s=little; s < littleend; /**/ ) { - if (*s != *x) - break; - else { - s++; - x++; - } - } - if (s >= littleend) - return (char*)(big-1); + if (little >= lend) + return (char*)big; + { + char first = *little++; + const char *s, *x; + bigend -= lend - little; + OUTER: + while (big <= bigend) { + if (*big++ != first) + goto OUTER; + for (x=big,s=little; s < lend; x++,s++) { + if (*s != *x) + goto OUTER; + } + return (char*)(big-1); + } } return Nullch; } @@ -356,7 +382,7 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit register const I32 first = *little; register const char * const littleend = lend; - if (!first && little >= littleend) + if (little >= littleend) return (char*)bigend; bigbeg = big; big = bigend - (littleend - little++); @@ -400,6 +426,7 @@ Analyses the string in order to make fast searches on it using fbm_instr() void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { + dVAR; register const U8 *s; register U32 i; STRLEN len; @@ -408,7 +435,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) if (flags & FBMcf_TAIL) { MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; - sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ + sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */ if (mg && mg->mg_len >= 0) mg->mg_len++; } @@ -667,6 +694,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit char * Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) { + dVAR; register const unsigned char *big; register I32 pos; register I32 previous; @@ -886,11 +914,12 @@ Perl_savesvpv(pTHX_ SV *sv) STATIC SV * S_mess_alloc(pTHX) { + dVAR; SV *sv; XPVMG *any; if (!PL_dirty) - return sv_2mortal(newSVpvn("",0)); + return sv_2mortal(newSVpvs("")); if (PL_mess_sv) return PL_mess_sv; @@ -900,7 +929,7 @@ S_mess_alloc(pTHX) Newxz(any, 1, XPVMG); SvFLAGS(sv) = SVt_PVMG; SvANY(sv) = (void*)any; - SvPV_set(sv, 0); + SvPV_set(sv, NULL); SvREFCNT(sv) = 1 << 30; /* practically infinite */ PL_mess_sv = sv; return sv; @@ -987,14 +1016,15 @@ Perl_mess(pTHX_ const char *pat, ...) STATIC COP* S_closest_cop(pTHX_ COP *cop, const OP *o) { + dVAR; /* Look for PL_op starting from o. cop is the last COP we've seen. */ - if (!o || o == PL_op) return cop; + if (!o || o == PL_op) + return cop; if (o->op_flags & OPf_KIDS) { OP *kid; - for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) - { + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { COP *new_cop; /* If the OP_NEXTSTATE has been optimised away we can still use it @@ -1006,7 +1036,8 @@ S_closest_cop(pTHX_ COP *cop, const OP *o) /* Keep searching, and return when we've found something. */ new_cop = closest_cop(cop, kid); - if (new_cop) return new_cop; + if (new_cop) + return new_cop; } } @@ -1018,6 +1049,7 @@ S_closest_cop(pTHX_ COP *cop, const OP *o) SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { + dVAR; SV * const sv = mess_alloc(); static const char dgd[] = " during global destruction.\n"; @@ -1098,22 +1130,25 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) } } -/* Common code used by vcroak, vdie and vwarner */ +/* Common code used by vcroak, vdie, vwarn and vwarner */ -STATIC void -S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) +STATIC bool +S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) { + dVAR; HV *stash; GV *gv; CV *cv; - /* sv_2cv might call Perl_croak() */ - SV * const olddiehook = PL_diehook; + SV **const hook = warn ? &PL_warnhook : &PL_diehook; + /* sv_2cv might call Perl_croak() or Perl_warner() */ + SV * const oldhook = *hook; + + assert(oldhook); - assert(PL_diehook); ENTER; - SAVESPTR(PL_diehook); - PL_diehook = Nullsv; - cv = sv_2cv(olddiehook, &stash, &gv, 0); + SAVESPTR(*hook); + *hook = NULL; + cv = sv_2cv(oldhook, &stash, &gv, 0); LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; @@ -1121,7 +1156,11 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) ENTER; save_re_context(); - if (message) { + if (warn) { + SAVESPTR(*hook); + *hook = NULL; + } + if (warn || message) { msg = newSVpvn(message, msglen); SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); @@ -1131,14 +1170,16 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) msg = ERRSV; } - PUSHSTACKi(PERLSI_DIEHOOK); + PUSHSTACKi(warn ? PERLSI_WARNHOOK : PERLSI_DIEHOOK); PUSHMARK(SP); XPUSHs(msg); PUTBACK; call_sv((SV*)cv, G_DISCARD); POPSTACK; LEAVE; + return TRUE; } + return FALSE; } STATIC const char * @@ -1167,7 +1208,7 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, "%p: die/croak: message = %s\ndiehook = %p\n", thr, message, PL_diehook)); if (PL_diehook) { - S_vdie_common(aTHX_ message, *msglen, *utf8); + S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE); } return message; } @@ -1175,6 +1216,7 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, OP * Perl_vdie(pTHX_ const char* pat, va_list *args) { + dVAR; const char *message; const int was_in_eval = PL_in_eval; STRLEN msglen; @@ -1224,6 +1266,7 @@ Perl_die(pTHX_ const char* pat, ...) void Perl_vcroak(pTHX_ const char* pat, va_list *args) { + dVAR; const char *message; STRLEN msglen; I32 utf8 = 0; @@ -1295,39 +1338,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) const char * const message = SvPV_const(msv, msglen); if (PL_warnhook) { - /* sv_2cv might call Perl_warn() */ - SV * const oldwarnhook = PL_warnhook; - CV * cv; - HV * stash; - GV * gv; - - ENTER; - SAVESPTR(PL_warnhook); - PL_warnhook = Nullsv; - cv = sv_2cv(oldwarnhook, &stash, &gv, 0); - LEAVE; - if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { - dSP; - SV *msg; - - ENTER; - SAVESPTR(PL_warnhook); - PL_warnhook = Nullsv; - save_re_context(); - msg = newSVpvn(message, msglen); - SvFLAGS(msg) |= utf8; - SvREADONLY_on(msg); - SAVEFREESV(msg); - - PUSHSTACKi(PERLSI_WARNHOOK); - PUSHMARK(SP); - XPUSHs(msg); - PUTBACK; - call_sv((SV*)cv, G_DISCARD); - POPSTACK; - LEAVE; + if (vdie_common(message, msglen, utf8, TRUE)) return; - } } write_to_stderr(message, msglen); @@ -1396,7 +1408,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) if (PL_diehook) { assert(message); - S_vdie_common(aTHX_ message, msglen, utf8); + S_vdie_common(aTHX_ message, msglen, utf8, FALSE); } if (PL_in_eval) { PL_restartop = die_where(message, msglen); @@ -1416,6 +1428,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) bool Perl_ckwarn(pTHX_ U32 w) { + dVAR; return ( isLEXWARN_on @@ -1443,6 +1456,7 @@ Perl_ckwarn(pTHX_ U32 w) bool Perl_ckwarn_d(pTHX_ U32 w) { + dVAR; return isLEXWARN_off || PL_curcop->cop_warnings == pWARN_ALL @@ -2046,6 +2060,7 @@ PerlIO * Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) { #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) + dVAR; int p[2]; register I32 This, that; register Pid_t pid; @@ -2179,6 +2194,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { + dVAR; int p[2]; register I32 This, that; register Pid_t pid; @@ -2553,8 +2569,7 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) return PerlProc_signal(signo, handler); } -static -Signal_t +static Signal_t sig_trap(int signo) { dVAR; @@ -2612,6 +2627,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { + dVAR; Sigsave_t hstat, istat, qstat; int status; SV **svp; @@ -2668,6 +2684,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { + dVAR; I32 result = 0; if (!pid) return -1; @@ -2853,6 +2870,7 @@ char* Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char *const *const search_ext, I32 flags) { + dVAR; const char *xfound = Nullch; char *xfailed = Nullch; char tmpbuf[MAXPATHLEN]; @@ -3779,7 +3797,7 @@ int Perl_getcwd_sv(pTHX_ register SV *sv) { #ifndef PERL_MICRO - + dVAR; #ifndef INCOMPLETE_TAINTS SvTAINTED_on(sv); #endif @@ -3990,6 +4008,9 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) pos++; } + if ( alpha && !saw_period ) + Perl_croak(aTHX_ "Invalid version format (alpha without decimal)"); + if ( saw_period > 1 ) qv = 1; /* force quoted version processing */ @@ -4107,6 +4128,7 @@ want to upgrade the SV. SV * Perl_new_version(pTHX_ SV *ver) { + dVAR; SV * const rv = newSV(0); if ( sv_derived_from(ver,"version") ) /* can just copy directly */ { @@ -4132,11 +4154,11 @@ Perl_new_version(pTHX_ SV *ver) if ( hv_exists((HV*)ver, "width", 5 ) ) { - const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE)); + const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE)); hv_store((HV *)hv, "width", 5, newSViv(width), 0); } - sav = (AV *)SvRV(*hv_fetch((HV*)ver, "version", 7, FALSE)); + sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE)); /* This will get reblessed later if a derived class*/ for ( key = 0; key <= av_len(sav); key++ ) { @@ -4161,8 +4183,7 @@ Perl_new_version(pTHX_ SV *ver) #ifdef SvVOK } #endif - upg_version(rv); - return rv; + return upg_version(rv); } /* @@ -4180,7 +4201,7 @@ Returns a pointer to the upgraded SV. SV * Perl_upg_version(pTHX_ SV *ver) { - char *version; + const char *version, *s; bool qv = 0; if ( SvNOK(ver) ) /* may get too much accuracy */ @@ -4200,7 +4221,12 @@ Perl_upg_version(pTHX_ SV *ver) { version = savepv(SvPV_nolen(ver)); } - (void)scan_version(version, ver, qv); + s = scan_version(version, ver, qv); + if ( *s != '\0' ) + if(ckWARN(WARN_MISC)) + Perl_warner(aTHX_ packWARN(WARN_MISC), + "Version string '%s' contains invalid data; " + "ignoring: '%s'", version, s); Safefree(version); return ver; } @@ -4238,7 +4264,7 @@ Perl_vverify(pTHX_ SV *vs) /* see if the appropriate elements exist */ if ( SvTYPE(vs) == SVt_PVHV && hv_exists((HV*)vs, "version", 7) - && (sv = SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE))) + && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE))) && SvTYPE(sv) == SVt_PVAV ) return TRUE; else @@ -4277,21 +4303,21 @@ Perl_vnumify(pTHX_ SV *vs) if ( hv_exists((HV*)vs, "alpha", 5 ) ) alpha = TRUE; if ( hv_exists((HV*)vs, "width", 5 ) ) - width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE)); + width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE)); else width = 3; /* attempt to retrieve the version array */ - if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) { - sv_catpvn(sv,"0",1); + if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) { + sv_catpvs(sv,"0"); return sv; } len = av_len(av); if ( len == -1 ) { - sv_catpvn(sv,"0",1); + sv_catpvs(sv,"0"); return sv; } @@ -4314,12 +4340,12 @@ Perl_vnumify(pTHX_ SV *vs) { digit = SvIV(*av_fetch(av, len, 0)); if ( alpha && width == 3 ) /* alpha version */ - sv_catpvn(sv,"_",1); + sv_catpvs(sv,"_"); Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); } else /* len == 0 */ { - sv_catpvn(sv,"000",3); + sv_catpvs(sv, "000"); } return sv; } @@ -4353,12 +4379,12 @@ Perl_vnormal(pTHX_ SV *vs) if ( hv_exists((HV*)vs, "alpha", 5 ) ) alpha = TRUE; - av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)); + av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)); len = av_len(av); if ( len == -1 ) { - sv_catpvn(sv,"",0); + sv_catpvs(sv,""); return sv; } digit = SvIV(*av_fetch(av, 0, 0)); @@ -4380,7 +4406,7 @@ Perl_vnormal(pTHX_ SV *vs) if ( len <= 2 ) { /* short version, must be at least three */ for ( len = 2 - len; len != 0; len-- ) - sv_catpvn(sv,".0",2); + sv_catpvs(sv,".0"); } return sv; } @@ -4441,12 +4467,12 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) Perl_croak(aTHX_ "Invalid version object"); /* get the left hand term */ - lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, FALSE)); + lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE)); if ( hv_exists((HV*)lhv, "alpha", 5 ) ) lalpha = TRUE; /* and the right hand term */ - rav = (AV *)SvRV(*hv_fetch((HV*)rhv, "version", 7, FALSE)); + rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE)); if ( hv_exists((HV*)rhv, "alpha", 5 ) ) ralpha = TRUE; @@ -4840,6 +4866,7 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) U32 Perl_seed(pTHX) { + dVAR; /* * This is really just a quick hack which grabs various garbage * values. It really should be a real hash algorithm which @@ -4921,6 +4948,7 @@ Perl_seed(pTHX) UV Perl_get_hash_seed(pTHX) { + dVAR; const char *s = PerlEnv_getenv("PERL_HASH_SEED"); UV myseed = 0; @@ -5173,6 +5201,47 @@ Perl_my_clearenv(pTHX) #endif /* PERL_MICRO */ } +#ifdef PERL_IMPLICIT_CONTEXT + +/* implements the MY_CXT_INIT macro. The first time a module is loaded, +the global PL_my_cxt_index is incremented, and that value is assigned to +that module's static my_cxt_index (who's address is passed as an arg). +Then, for each interpreter this function is called for, it makes sure a +void* slot is available to hang the static data off, by allocating or +extending the interpreter's PL_my_cxt_list array */ + +void * +Perl_my_cxt_init(pTHX_ int *index, size_t size) +{ + dVAR; + void *p; + if (*index == -1) { + /* this module hasn't been allocated an index yet */ + MUTEX_LOCK(&PL_my_ctx_mutex); + *index = PL_my_cxt_index++; + MUTEX_UNLOCK(&PL_my_ctx_mutex); + } + + /* make sure the array is big enough */ + if (PL_my_cxt_size <= *index) { + if (PL_my_cxt_size) { + while (PL_my_cxt_size <= *index) + PL_my_cxt_size *= 2; + Renew(PL_my_cxt_list, PL_my_cxt_size, void *); + } + else { + PL_my_cxt_size = 16; + Newx(PL_my_cxt_list, PL_my_cxt_size, void *); + } + } + /* newSV() allocates one more than needed */ + p = (void*)SvPVX(newSV(size-1)); + PL_my_cxt_list[*index] = p; + Zero(p, size, char); + return p; +} +#endif + /* * Local variables: * c-indentation-style: bsd