X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=3635d352f2e488fb7147cc75a83abcd81541ffa1;hb=cf2649810f00335bd657355d81bcc9384a620135;hp=fb7108f56ebdeec166d78b28563b3175168b74b1;hpb=490a0e9885933990f72b0e0485666a1f8522f018;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index fb7108f..3635d35 100644 --- a/util.c +++ b/util.c @@ -366,14 +366,13 @@ void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { const register U8 *s; - register U8 *table; register U32 i; STRLEN len; I32 rarest = 0; U32 frequency = 256; if (flags & FBMcf_TAIL) { - MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; + 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() */ if (mg && mg->mg_len >= 0) mg->mg_len++; @@ -385,6 +384,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) if (len > 2) { const unsigned char *sb; const U8 mlen = (len>255) ? 255 : (U8)len; + register U8 *table; Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET); table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET); @@ -764,7 +764,7 @@ Perl_savepv(pTHX_ const char *pv) else { char *newaddr; const STRLEN pvlen = strlen(pv)+1; - New(902,newaddr,pvlen,char); + Newx(newaddr,pvlen,char); return memcpy(newaddr,pv,pvlen); } @@ -788,7 +788,7 @@ Perl_savepvn(pTHX_ const char *pv, register I32 len) { register char *newaddr; - New(903,newaddr,len+1,char); + Newx(newaddr,len+1,char); /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ if (pv) { /* might not be null terminated */ @@ -843,7 +843,7 @@ Perl_savesvpv(pTHX_ SV *sv) register char *newaddr; ++len; - New(903,newaddr,len,char); + Newx(newaddr,len,char); return (char *) CopyD(pv,newaddr,len,char); } @@ -863,8 +863,8 @@ S_mess_alloc(pTHX) return PL_mess_sv; /* Create as PVMG now, to avoid any upgrading later */ - New(905, sv, 1, SV); - Newz(905, any, 1, XPVMG); + Newx(sv, 1, SV); + Newxz(any, 1, XPVMG); SvFLAGS(sv) = SVt_PVMG; SvANY(sv) = (void*)any; SvPV_set(sv, 0); @@ -1074,7 +1074,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) GV *gv; CV *cv; /* sv_2cv might call Perl_croak() */ - SV *olddiehook = PL_diehook; + SV * const olddiehook = PL_diehook; assert(PL_diehook); ENTER; @@ -1116,7 +1116,7 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, const char *message; if (pat) { - SV *msv = vmess(pat, args); + SV * const msv = vmess(pat, args); if (PL_errors && SvCUR(PL_errors)) { sv_catsv(PL_errors, msv); message = SvPV_const(PL_errors, *msglen); @@ -1151,7 +1151,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) "%p: die: curstack = %p, mainstack = %p\n", thr, PL_curstack, PL_mainstack)); - message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); + message = vdie_croak_common(pat, args, &msglen, &utf8); PL_restartop = die_where(message, msglen); SvFLAGS(ERRSV) |= utf8; @@ -1278,6 +1278,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) SV *msg; ENTER; + SAVESPTR(PL_warnhook); + PL_warnhook = Nullsv; save_re_context(); msg = newSVpvn(message, msglen); SvFLAGS(msg) |= utf8; @@ -1376,6 +1378,58 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } } +/* implements the ckWARN? macros */ + +bool +Perl_ckwarn(pTHX_ U32 w) +{ + return + ( + isLEXWARN_on + && PL_curcop->cop_warnings != pWARN_NONE + && ( + PL_curcop->cop_warnings == pWARN_ALL + || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) + || (unpackWARN2(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) + || (unpackWARN3(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) + || (unpackWARN4(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) + ) + ) + || + ( + isLEXWARN_off && PL_dowarn & G_WARN_ON + ) + ; +} + +/* implements the ckWARN?_d macro */ + +bool +Perl_ckwarn_d(pTHX_ U32 w) +{ + return + isLEXWARN_off + || PL_curcop->cop_warnings == pWARN_ALL + || ( + PL_curcop->cop_warnings != pWARN_NONE + && ( + isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) + || (unpackWARN2(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) + || (unpackWARN3(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) + || (unpackWARN4(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) + ) + ) + ; +} + + + /* since we've already done strlen() for both nam and val * we can use that info to make things faster than * sprintf(s, "%s=%s", nam, val) @@ -1476,7 +1530,7 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) val = ""; } vlen = strlen(val); - New(904, envstr, nlen+vlen+2, char); + Newx(envstr, nlen+vlen+2, char); my_setenv_format(envstr, nam, nlen, val, vlen); (void)PerlEnv_putenv(envstr); Safefree(envstr); @@ -2359,10 +2413,10 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return SIG_ERR; + return (Sighandler_t) SIG_ERR; #endif - act.sa_handler = handler; + act.sa_handler = (void(*)(int))handler; sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART @@ -2370,13 +2424,13 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ - if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) + if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; #endif if (sigaction(signo, &act, &oact) == -1) - return SIG_ERR; + return (Sighandler_t) SIG_ERR; else - return oact.sa_handler; + return (Sighandler_t) oact.sa_handler; } Sighandler_t @@ -2385,9 +2439,9 @@ Perl_rsignal_state(pTHX_ int signo) struct sigaction oact; if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) - return SIG_ERR; + return (Sighandler_t) SIG_ERR; else - return oact.sa_handler; + return (Sighandler_t) oact.sa_handler; } int @@ -2402,7 +2456,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) return -1; #endif - act.sa_handler = handler; + act.sa_handler = (void(*)(int))handler; sigemptyset(&act.sa_mask); act.sa_flags = 0; #ifdef SA_RESTART @@ -2410,7 +2464,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */ #endif #if defined(SA_NOCLDWAIT) && !defined(BSDish) /* See [perl #18849] */ - if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN) + if (signo == SIGCHLD && handler == (Sighandler_t) SIG_IGN) act.sa_flags |= SA_NOCLDWAIT; #endif return sigaction(signo, &act, save); @@ -2437,7 +2491,7 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) #if defined(USE_ITHREADS) && !defined(WIN32) /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return SIG_ERR; + return (Sighandler_t) SIG_ERR; #endif return PerlProc_signal(signo, handler); @@ -2460,7 +2514,7 @@ Perl_rsignal_state(pTHX_ int signo) #if defined(USE_ITHREADS) && !defined(WIN32) /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) - return SIG_ERR; + return (Sighandler_t) SIG_ERR; #endif PL_sig_trapped = 0; @@ -2480,7 +2534,7 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) return -1; #endif *save = PerlProc_signal(signo, handler); - return (*save == SIG_ERR) ? -1 : 0; + return (*save == (Sighandler_t) SIG_ERR) ? -1 : 0; } int @@ -2491,7 +2545,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) if (PL_curinterp != aTHX) return -1; #endif - return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0; + return (PerlProc_signal(signo, *save) == (Sighandler_t) SIG_ERR) ? -1 : 0; } #endif /* !HAS_SIGACTION */ @@ -2534,9 +2588,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif #ifndef PERL_MICRO - rsignal_save(SIGHUP, SIG_IGN, &hstat); - rsignal_save(SIGINT, SIG_IGN, &istat); - rsignal_save(SIGQUIT, SIG_IGN, &qstat); + rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat); + rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat); + rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat); #endif do { pid2 = wait4pid(pid, &status, 0); @@ -2959,8 +3013,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **searc } scriptname = Nullch; } - if (xfailed) - Safefree(xfailed); + Safefree(xfailed); scriptname = xfound; } return (scriptname ? savepv(scriptname) : Nullch); @@ -3214,23 +3267,19 @@ Perl_my_fflush_all(pTHX) void Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op) { - const char *func = + const char * const func = op == OP_READLINE ? "readline" : /* "" not nice */ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ PL_op_desc[op]; - const char *pars = OP_IS_FILETEST(op) ? "" : "()"; - const char *type = OP_IS_SOCKET(op) + const char * const pars = OP_IS_FILETEST(op) ? "" : "()"; + const char * const type = OP_IS_SOCKET(op) || (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ? "socket" : "filehandle"; - const char *name = NULL; - - if (gv && isGV(gv)) { - name = GvENAME(gv); - } + const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL; if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { if (ckWARN(WARN_IO)) { - const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out"; + const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out"; if (name && *name) Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %s opened only for %sput", @@ -3587,7 +3636,7 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in } STMT_END; #endif buflen = 64; - New(0, buf, buflen, char); + Newx(buf, buflen, char); len = strftime(buf, buflen, fmt, &mytm); /* ** The following is needed to handle to the situation where @@ -3610,7 +3659,7 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in const int fmtlen = strlen(fmt); const int bufsize = fmtlen + buflen; - New(0, buf, bufsize, char); + Newx(buf, bufsize, char); while (buf) { buflen = strftime(buf, bufsize, fmt, &mytm); if (buflen > 0 && buflen < bufsize) @@ -4032,8 +4081,9 @@ Perl_new_version(pTHX_ SV *ver) if ( SvVOK(ver) ) { /* already a v-string */ char *version; MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); - version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); - sv_setpv(rv,version); + const STRLEN len = mg->mg_len; + version = savepvn( (const char*)mg->mg_ptr, len); + sv_setpvn(rv,version,len); Safefree(version); } else { @@ -4910,6 +4960,55 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) #endif /* PERL_GLOBAL_STRUCT */ +#ifdef PERL_MEM_LOG + +#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 + +Malloc_t +Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) +{ +#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)); +#endif + return newalloc; +} + +Malloc_t +Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) +{ +#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)); +#endif + return newalloc; +} + +Malloc_t +Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname) +{ +#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)); +#endif + return oldalloc; +} + +#endif /* PERL_MEM_LOG */ + /* * Local variables: * c-indentation-style: bsd