X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=5560fc8a61f4abaaf6ac4b28de5bf34be2698d7c;hb=1d74b28c229b5172175a0073070beb529386ac4f;hp=ec0ba8cd8e936ae06536a0fc7f81f36d24f3460c;hpb=0bd48802b00657d8da2da444a1c97fb25cb7d562;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index ec0ba8c..5560fc8 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,11 +60,12 @@ 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)); my_exit(1); - NORETURN_FUNCTION_END + NORETURN_FUNCTION_END; } /* paranoid version of system's malloc() */ @@ -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; @@ -303,9 +335,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) @@ -317,28 +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++) { - 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; } @@ -352,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++); @@ -361,9 +391,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) @@ -394,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; @@ -402,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++; } @@ -661,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; @@ -880,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; @@ -894,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; @@ -981,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 @@ -1000,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; } } @@ -1012,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"; @@ -1092,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; @@ -1115,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); @@ -1125,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 * @@ -1161,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; } @@ -1169,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; @@ -1218,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; @@ -1289,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); @@ -1390,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); @@ -1410,6 +1428,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) bool Perl_ckwarn(pTHX_ U32 w) { + dVAR; return ( isLEXWARN_on @@ -1437,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 @@ -2040,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; @@ -2173,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; @@ -2547,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; @@ -2606,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; @@ -2662,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; @@ -2847,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]; @@ -3773,7 +3797,7 @@ int Perl_getcwd_sv(pTHX_ register SV *sv) { #ifndef PERL_MICRO - + dVAR; #ifndef INCOMPLETE_TAINTS SvTAINTED_on(sv); #endif @@ -3984,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 */ @@ -4101,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 */ { @@ -4174,7 +4202,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 */ @@ -4194,7 +4222,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; } @@ -4278,14 +4311,14 @@ Perl_vnumify(pTHX_ SV *vs) /* attempt to retrieve the version array */ if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) { - sv_catpvn(sv,"0",1); + sv_catpvs(sv,"0"); return sv; } len = av_len(av); if ( len == -1 ) { - sv_catpvn(sv,"0",1); + sv_catpvs(sv,"0"); return sv; } @@ -4308,12 +4341,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; } @@ -4352,7 +4385,7 @@ Perl_vnormal(pTHX_ SV *vs) len = av_len(av); if ( len == -1 ) { - sv_catpvn(sv,"",0); + sv_catpvs(sv,""); return sv; } digit = SvIV(*av_fetch(av, 0, 0)); @@ -4374,7 +4407,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; } @@ -4834,6 +4867,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 @@ -4915,6 +4949,7 @@ Perl_seed(pTHX) UV Perl_get_hash_seed(pTHX) { + dVAR; const char *s = PerlEnv_getenv("PERL_HASH_SEED"); UV myseed = 0; @@ -5055,7 +5090,7 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t " %s = %"IVdf": %"UVxf"\n", filename, linenumber, funcname, n, typesize, typename, n * typesize, PTR2UV(newalloc)); - PerlLIO_write(2, buf, len)); + PerlLIO_write(2, buf, len); #endif return newalloc; } @@ -5167,6 +5202,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