X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=d253126c8cb5d0846c25035b54f007e8e89e0058;hb=3246d7a3ad86dfa806dd7e514ae5fd2dacd5c0ef;hp=6c5605c224bc981a1ba2f135a25f4439b0c641a1;hpb=b0269e46d70f4b0ab23ffad2f94b10b64091afa3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 6c5605c..d253126 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. @@ -57,6 +57,16 @@ int putenv(char *); * XXX This advice seems to be widely ignored :-( --AD August 1996. */ +static char * +S_write_no_mem(pTHX) +{ + /* Can't use PerlIO to write as it allocates memory */ + PerlLIO_write(PerlIO_fileno(Perl_error_log), + PL_no_mem, strlen(PL_no_mem)); + my_exit(1); + NORETURN_FUNCTION_END; +} + /* paranoid version of system's malloc() */ Malloc_t @@ -71,6 +81,9 @@ Perl_safesysmalloc(MEM_SIZE size) my_exit(1); } #endif /* HAS_64K_LIMIT */ +#ifdef PERL_TRACK_MEMPOOL + size += sTHX; +#endif #ifdef DEBUGGING if ((long)size < 0) Perl_croak_nocontext("panic: malloc"); @@ -78,16 +91,21 @@ Perl_safesysmalloc(MEM_SIZE size) ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ PERL_ALLOC_CHECK(ptr); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); - if (ptr != Nullch) + if (ptr != Nullch) { +#ifdef PERL_TRACK_MEMPOOL + ((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; +} else if (PL_nomemok) return Nullch; else { - /* Can't use PerlIO to write as it allocates memory */ - PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, strlen(PL_no_mem)); - my_exit(1); - return Nullch; + return write_no_mem(); } /*NOTREACHED*/ } @@ -117,6 +135,22 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (!where) return safesysmalloc(size); +#ifdef PERL_TRACK_MEMPOOL + where = (Malloc_t)((char*)where-sTHX); + size += sTHX; + 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) Perl_croak_nocontext("panic: realloc"); @@ -127,16 +161,16 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); - if (ptr != Nullch) + if (ptr != Nullch) { +#ifdef PERL_TRACK_MEMPOOL + ptr = (Malloc_t)((char*)ptr+sTHX); +#endif return ptr; + } else if (PL_nomemok) return Nullch; else { - /* Can't use PerlIO to write as it allocates memory */ - PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, strlen(PL_no_mem)); - my_exit(1); - return Nullch; + return write_no_mem(); } /*NOTREACHED*/ } @@ -147,11 +181,32 @@ Free_t Perl_safesysfree(Malloc_t where) { dVAR; -#ifdef PERL_IMPLICIT_SYS +#if defined(PERL_IMPLICIT_SYS) || defined(PERL_TRACK_MEMPOOL) dTHX; #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 (((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); } } @@ -176,23 +231,27 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) Perl_croak_nocontext("panic: calloc"); #endif size *= count; +#ifdef PERL_TRACK_MEMPOOL + size += sTHX; +#endif ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ PERL_ALLOC_CHECK(ptr); DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size)); if (ptr != Nullch) { memset((void*)ptr, 0, size); +#ifdef PERL_TRACK_MEMPOOL + ((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; } else if (PL_nomemok) return Nullch; - else { - /* Can't use PerlIO to write as it allocates memory */ - PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, strlen(PL_no_mem)); - my_exit(1); - return Nullch; - } - /*NOTREACHED*/ + return write_no_mem(); } /* These must be defined when not using Perl's malloc for binary @@ -274,9 +333,11 @@ Perl_instr(pTHX_ register const char *big, register const char *little) for (x=big,s=little; *s; /**/ ) { if (!*x) return Nullch; - if (*s++ != *x++) { - s--; + if (*s != *x) break; + else { + s++; + x++; } } if (!*s) @@ -288,28 +349,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 *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++) { - s--; - break; - } - } - 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; } @@ -321,9 +378,9 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit { register const char *bigbeg; register const I32 first = *little; - register const char *littleend = lend; + register const char * const littleend = lend; - if (!first && little >= littleend) + if (little >= littleend) return (char*)bigend; bigbeg = big; big = bigend - (littleend - little++); @@ -332,9 +389,11 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit if (*big-- != first) continue; for (x=big+2,s=little; s < littleend; /**/ ) { - if (*s++ != *x++) { - s--; + if (*s != *x) break; + else { + x++; + s++; } } if (s >= littleend) @@ -819,9 +878,7 @@ Perl_savesharedpv(pTHX_ const char *pv) pvlen = strlen(pv)+1; newaddr = (char*)PerlMemShared_malloc(pvlen); if (!newaddr) { - PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, strlen(PL_no_mem)); - my_exit(1); + return write_no_mem(); } return memcpy(newaddr,pv,pvlen); } @@ -839,7 +896,7 @@ char * Perl_savesvpv(pTHX_ SV *sv) { STRLEN len; - const char *pv = SvPV_const(sv, len); + const char * const pv = SvPV_const(sv, len); register char *newaddr; ++len; @@ -956,12 +1013,12 @@ S_closest_cop(pTHX_ COP *cop, const OP *o) { /* 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 @@ -973,7 +1030,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; } } @@ -1358,7 +1416,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) if (ckDEAD(err)) { SV * const msv = vmess(pat, args); STRLEN msglen; - const char *message = SvPV_const(msv, msglen); + const char * const message = SvPV_const(msv, msglen); const I32 utf8 = SvUTF8(msv); if (PL_diehook) { @@ -2520,8 +2578,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; @@ -2658,7 +2715,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) if ((entry = hv_iternext(PL_pidstatus))) { SV * const sv = hv_iterval(PL_pidstatus,entry); I32 len; - const char *spid = hv_iterkey(entry,&len); + const char * const spid = hv_iterkey(entry,&len); assert (len == sizeof(Pid_t)); memcpy((char *)&pid, spid, len); @@ -2739,7 +2796,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) { /* Needs work for PerlIO ! */ FILE * const f = PerlIO_findFILE(ptr); - I32 result = pclose(f); + const I32 result = pclose(f); PerlIO_releaseFILE(ptr,f); return result; } @@ -2840,7 +2897,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, #endif /* additional extensions to try in each dir if scriptname not found */ #ifdef SEARCH_EXTS - const char *const exts[] = { SEARCH_EXTS }; + static const char *const exts[] = { SEARCH_EXTS }; const char *const *const ext = search_ext ? search_ext : exts; int extidx = 0, i = 0; const char *curext = Nullch; @@ -3147,7 +3204,7 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) MGVTBL* Perl_get_vtbl(pTHX_ int vtbl_id) { - const MGVTBL* result = Null(MGVTBL*); + const MGVTBL* result; switch(vtbl_id) { case want_vtbl_sv: @@ -3242,6 +3299,9 @@ Perl_get_vtbl(pTHX_ int vtbl_id) case want_vtbl_utf8: result = &PL_vtbl_utf8; break; + default: + result = Null(MGVTBL*); + break; } return (MGVTBL*)result; } @@ -3756,7 +3816,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) * size from the heap if they are given a NULL buffer pointer. * The problem is that this behaviour is not portable. */ if (getcwd(buf, sizeof(buf) - 1)) { - sv_setpvn(sv, buf, strlen(buf)); + sv_setpv(sv, buf); return TRUE; } else { @@ -3916,8 +3976,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) int saw_period = 0; int alpha = 0; int width = 3; - AV *av = newAV(); - SV *hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ + AV * const av = newAV(); + SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ #ifndef NODEFAULT_SHAREKEYS @@ -4150,8 +4210,8 @@ Perl_upg_version(pTHX_ SV *ver) if ( SvNOK(ver) ) /* may get too much accuracy */ { char tbuf[64]; - sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); - version = savepv(tbuf); + const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); + version = savepvn(tbuf, len); } #ifdef SvVOK else if ( SvVOK(ver) ) { /* already a v-string */ @@ -4265,7 +4325,7 @@ Perl_vnumify(pTHX_ SV *vs) { digit = SvIV(*av_fetch(av, i, 0)); if ( width < 3 ) { - const int denom = (int)pow(10,(3-width)); + const int denom = (width == 2 ? 10 : 100); const div_t term = div((int)PERL_ABS(digit),denom); Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem); } @@ -4705,7 +4765,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { #endif tidy_up_and_fail: { - int save_errno = errno; + const int save_errno = errno; if (listener != -1) PerlLIO_close(listener); if (connector != -1) @@ -4945,8 +5005,8 @@ Perl_init_global_struct(pTHX) #ifdef PERL_GLOBAL_STRUCT # define PERL_GLOBAL_STRUCT_INIT # include "opcode.h" /* the ppaddr and check */ - IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t); - IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t); + const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t); + const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t); # ifdef PERL_GLOBAL_STRUCT_PRIVATE /* PerlMem_malloc() because can't use even safesysmalloc() this early. */ plvarsp = (struct perl_vars*)PerlMem_malloc(sizeof(struct perl_vars)); @@ -5020,11 +5080,12 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t #ifdef PERL_MEM_LOG_STDERR /* We can't use PerlIO for obvious reasons. */ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; - sprintf(buf, - "alloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf"\n", - filename, linenumber, funcname, - n, typesize, typename, n * typesize, PTR2UV(newalloc)); - PerlLIO_write(2, buf, strlen(buf)); + const STRLEN len = my_sprintf(buf, + "alloc: %s:%d:%s: %"IVdf" %"UVuf + " %s = %"IVdf": %"UVxf"\n", + filename, linenumber, funcname, n, typesize, + typename, n * typesize, PTR2UV(newalloc)); + PerlLIO_write(2, buf, len); #endif return newalloc; } @@ -5035,11 +5096,12 @@ Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc #ifdef PERL_MEM_LOG_STDERR /* We can't use PerlIO for obvious reasons. */ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; - sprintf(buf, - "realloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf" -> %"UVxf"\n", - filename, linenumber, funcname, - n, typesize, typename, n * typesize, PTR2UV(oldalloc), PTR2UV(newalloc)); - PerlLIO_write(2, buf, strlen(buf)); + const STRLEN len = my_sprintf(buf, "realloc: %s:%d:%s: %"IVdf" %"UVuf + " %s = %"IVdf": %"UVxf" -> %"UVxf"\n", + filename, linenumber, funcname, n, typesize, + typename, n * typesize, PTR2UV(oldalloc), + PTR2UV(newalloc)); + PerlLIO_write(2, buf, len); #endif return newalloc; } @@ -5050,9 +5112,10 @@ Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, #ifdef PERL_MEM_LOG_STDERR /* We can't use PerlIO for obvious reasons. */ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; - sprintf(buf, "free: %s:%d:%s: %"UVxf"\n", - filename, linenumber, funcname, PTR2UV(oldalloc)); - PerlLIO_write(2, buf, strlen(buf)); + const STRLEN len = my_sprintf(buf, "free: %s:%d:%s: %"UVxf"\n", + filename, linenumber, funcname, + PTR2UV(oldalloc)); + PerlLIO_write(2, buf, len); #endif return oldalloc; } @@ -5134,6 +5197,46 @@ 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) +{ + 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