X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=ecec11005800411322acc1370df9885f1eab755e;hb=f1cb2d481d972775b9a182636a99d99ab903f097;hp=67d27d7381ce2e6e75982b268e928744ecd8dbcf;hpb=a6e20a404b42cad25eb97280fa2bcacffda64cd6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 67d27d7..ecec110 100644 --- a/util.c +++ b/util.c @@ -365,15 +365,14 @@ Analyses the string in order to make fast searches on it using fbm_instr() void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { - const register U8 *s; - register U8 *table; + register const U8 *s; 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); @@ -552,7 +552,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit return Nullch; } if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) { - char *b = ninstr((char*)big,(char*)bigend, + char * const b = ninstr((char*)big,(char*)bigend, (char*)little, (char*)little + littlelen); if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */ @@ -569,8 +569,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } { /* Do actual FBM. */ - register const unsigned char *table = little + littlelen + FBM_TABLE_OFFSET; - const register unsigned char *oldlittle; + register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET; + register const unsigned char *oldlittle; if (littlelen > (STRLEN)(bigend - big)) return Nullch; @@ -632,13 +632,13 @@ 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) { - const register unsigned char *big; + register const unsigned char *big; register I32 pos; register I32 previous; register I32 first; - const register unsigned char *little; + register const unsigned char *little; register I32 stop_pos; - const register unsigned char *littleend; + register const unsigned char *littleend; I32 found = 0; if (*old_posp == -1 @@ -680,7 +680,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift } big -= previous; do { - const register unsigned char *s, *x; + register const unsigned char *s, *x; if (pos >= stop_pos) break; if (big[pos] != first) continue; @@ -764,8 +764,8 @@ Perl_savepv(pTHX_ const char *pv) else { char *newaddr; const STRLEN pvlen = strlen(pv)+1; - New(902,newaddr,pvlen,char); - return strcpy(newaddr,pv); + 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 */ @@ -812,16 +812,18 @@ char * Perl_savesharedpv(pTHX_ const char *pv) { register char *newaddr; + STRLEN pvlen; if (!pv) return Nullch; - newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1); + 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 strcpy(newaddr,pv); + return memcpy(newaddr,pv,pvlen); } /* @@ -841,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); } @@ -861,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); @@ -919,7 +921,7 @@ Perl_form(pTHX_ const char* pat, ...) char * Perl_vform(pTHX_ const char *pat, va_list *args) { - SV *sv = mess_alloc(); + SV * const sv = mess_alloc(); sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); return SvPVX(sv); } @@ -950,7 +952,7 @@ Perl_mess(pTHX_ const char *pat, ...) } STATIC COP* -S_closest_cop(pTHX_ COP *cop, OP *o) +S_closest_cop(pTHX_ COP *cop, const OP *o) { /* Look for PL_op starting from o. cop is the last COP we've seen. */ @@ -977,13 +979,13 @@ S_closest_cop(pTHX_ COP *cop, OP *o) /* Nothing found. */ - return 0; + return Null(COP *); } SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { - SV *sv = mess_alloc(); + SV * const sv = mess_alloc(); static const char dgd[] = " during global destruction.\n"; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); @@ -1051,9 +1053,9 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) else { #ifdef USE_SFIO /* SFIO can really mess with your errno */ - int e = errno; + const int e = errno; #endif - PerlIO *serr = Perl_error_log; + PerlIO * const serr = Perl_error_log; PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); @@ -1072,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; @@ -1114,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); @@ -1149,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; @@ -1254,21 +1256,18 @@ void Perl_vwarn(pTHX_ const char* pat, va_list *args) { dVAR; - const char *message; - HV *stash; - GV *gv; - CV *cv; - SV *msv; STRLEN msglen; - I32 utf8 = 0; - - msv = vmess(pat, args); - utf8 = SvUTF8(msv); - message = SvPV_const(msv, msglen); + SV * const msv = vmess(pat, args); + const I32 utf8 = SvUTF8(msv); + const char * const message = SvPV_const(msv, msglen); if (PL_warnhook) { /* sv_2cv might call Perl_warn() */ - SV *oldwarnhook = PL_warnhook; + SV * const oldwarnhook = PL_warnhook; + CV * cv; + HV * stash; + GV * gv; + ENTER; SAVESPTR(PL_warnhook); PL_warnhook = Nullsv; @@ -1279,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; @@ -1377,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) @@ -1442,19 +1495,41 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) my_setenv_format(environ[i], nam, nlen, val, vlen); } else { # endif -# if defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN) - setenv(nam, val, 1); +# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) +# if defined(HAS_UNSETENV) + if (val == NULL) { + (void)unsetenv(nam); + } else { + (void)setenv(nam, val, 1); + } +# else /* ! HAS_UNSETENV */ + (void)setenv(nam, val, 1); +# endif /* HAS_UNSETENV */ # else - char *new_env; - int nlen = strlen(nam), vlen; - if (!val) { - val = ""; - } - vlen = strlen(val); - new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char)); - /* all that work just for this */ - my_setenv_format(new_env, nam, nlen, val, vlen); - (void)putenv(new_env); +# if defined(HAS_UNSETENV) + if (val == NULL) { + (void)unsetenv(nam); + } else { + const int nlen = strlen(nam); + const int vlen = strlen(val); + char * const new_env = + (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char)); + my_setenv_format(new_env, nam, nlen, val, vlen); + (void)putenv(new_env); + } +# else /* ! HAS_UNSETENV */ + char *new_env; + const int nlen = strlen(nam); + int vlen; + if (!val) { + val = ""; + } + vlen = strlen(val); + new_env = (char*)safesysmalloc((nlen + vlen + 2) * sizeof(char)); + /* all that work just for this */ + my_setenv_format(new_env, nam, nlen, val, vlen); + (void)putenv(new_env); +# endif /* HAS_UNSETENV */ # endif /* __CYGWIN__ */ #ifndef PERL_USE_SAFE_PUTENV } @@ -1476,7 +1551,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); @@ -1488,7 +1563,8 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) I32 Perl_setenv_getix(pTHX_ const char *nam) { - register I32 i, len = strlen(nam); + register I32 i; + register const I32 len = strlen(nam); for (i = 0; environ[i]; i++) { if ( @@ -1508,7 +1584,7 @@ Perl_setenv_getix(pTHX_ const char *nam) #ifdef UNLINK_ALL_VERSIONS I32 -Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */ +Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */ { I32 i; @@ -1522,7 +1598,7 @@ Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */ char * Perl_my_bcopy(register const char *from,register char *to,register I32 len) { - char *retval = to; + char * const retval = to; if (from - to >= 0) { while (len--) @@ -1543,7 +1619,7 @@ Perl_my_bcopy(register const char *from,register char *to,register I32 len) void * Perl_my_memset(register char *loc, register I32 ch, register I32 len) { - char *retval = loc; + char * const retval = loc; while (len--) *loc++ = ch; @@ -1556,7 +1632,7 @@ Perl_my_memset(register char *loc, register I32 ch, register I32 len) char * Perl_my_bzero(register char *loc, register I32 len) { - char *retval = loc; + char * const retval = loc; while (len--) *loc++ = 0; @@ -2068,13 +2144,13 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) /* VMS' my_popen() is in VMS.c, same with OS/2. */ #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) PerlIO * -Perl_my_popen(pTHX_ char *cmd, char *mode) +Perl_my_popen(pTHX_ const char *cmd, const char *mode) { int p[2]; register I32 This, that; register Pid_t pid; SV *sv; - I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); + const I32 doexec = !(*cmd == '-' && cmd[1] == '\0'); I32 did_pipes = 0; int pp[2]; @@ -2157,7 +2233,9 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) PL_ppid = (IV)getppid(); #endif PL_forkprocess = 0; +#ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); /* we have no children */ +#endif return Nullfp; #undef THIS #undef THAT @@ -2358,10 +2436,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 @@ -2369,13 +2447,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 @@ -2384,9 +2462,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 @@ -2401,7 +2479,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 @@ -2409,7 +2487,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); @@ -2436,7 +2514,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); @@ -2459,7 +2537,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; @@ -2479,7 +2557,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 @@ -2490,7 +2568,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 */ @@ -2533,9 +2611,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); @@ -2560,17 +2638,16 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) I32 result = 0; if (!pid) return -1; -#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) +#ifdef PERL_USES_PL_PIDSTATUS { - char spid[TYPE_CHARS(IV)]; - if (pid > 0) { - SV** svp; - sprintf(spid, "%"IVdf, (IV)pid); - svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE); + /* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the + pid, rather than a string form. */ + SV * const * const svp = hv_fetch(PL_pidstatus,(const char*) &pid,sizeof(Pid_t),FALSE); if (svp && *svp != &PL_sv_undef) { *statusp = SvIVX(*svp); - (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); + (void)hv_delete(PL_pidstatus,(const char*) &pid,sizeof(Pid_t), + G_DISCARD); return pid; } } @@ -2579,12 +2656,21 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) hv_iterinit(PL_pidstatus); if ((entry = hv_iternext(PL_pidstatus))) { - SV *sv = hv_iterval(PL_pidstatus,entry); + SV * const sv = hv_iterval(PL_pidstatus,entry); + I32 len; + const char *spid = hv_iterkey(entry,&len); - pid = atoi(hv_iterkey(entry,(I32*)statusp)); + assert (len == sizeof(Pid_t)); + memcpy((char *)&pid, spid, len); *statusp = SvIVX(sv); - sprintf(spid, "%"IVdf, (IV)pid); - (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD); + /* The hash iterator is currently on this entry, so simply + calling hv_delete would trigger the lazy delete, which on + aggregate does more work, beacuse next call to hv_iterinit() + would spot the flag, and have to call the delete routine, + while in the meantime any new entries can't re-use that + memory. */ + hv_iterinit(PL_pidstatus); + (void)hv_delete(PL_pidstatus,spid,len,G_DISCARD); return pid; } } @@ -2602,7 +2688,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); goto finish; #endif -#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME) +#ifdef PERL_USES_PL_PIDSTATUS #if defined(HAS_WAITPID) && defined(HAS_WAITPID_RUNTIME) hard_way: #endif @@ -2627,18 +2713,18 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) } #endif /* !DOSISH || OS2 || WIN32 || NETWARE */ +#ifdef PERL_USES_PL_PIDSTATUS void Perl_pidgone(pTHX_ Pid_t pid, int status) { register SV *sv; - char spid[TYPE_CHARS(IV)]; - sprintf(spid, "%"IVdf, (IV)pid); - sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE); + sv = *hv_fetch(PL_pidstatus,(const char*)&pid,sizeof(Pid_t),TRUE); SvUPGRADE(sv,SVt_IV); SvIV_set(sv, status); return; } +#endif #if defined(atarist) || defined(OS2) || defined(EPOC) int pclose(); @@ -2652,7 +2738,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #endif { /* Needs work for PerlIO ! */ - FILE *f = PerlIO_findFILE(ptr); + FILE * const f = PerlIO_findFILE(ptr); I32 result = pclose(f); PerlIO_releaseFILE(ptr,f); return result; @@ -2665,7 +2751,7 @@ I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { /* Needs work for PerlIO ! */ - FILE *f = PerlIO_findFILE(ptr); + FILE * const f = PerlIO_findFILE(ptr); I32 result = djgpp_pclose(f); result = (result << 8) & 0xff00; PerlIO_releaseFILE(ptr,f); @@ -2677,7 +2763,7 @@ void Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count) { register I32 todo; - register const char *frombase = from; + register const char * const frombase = from; if (len == 1) { register const char c = *from; @@ -2701,7 +2787,7 @@ Perl_same_dirent(pTHX_ const char *a, const char *b) char *fb = strrchr(b,'/'); Stat_t tmpstatbuf1; Stat_t tmpstatbuf2; - SV *tmpsv = sv_newmortal(); + SV * const tmpsv = sv_newmortal(); if (fa) fa++; @@ -2731,7 +2817,8 @@ Perl_same_dirent(pTHX_ const char *a, const char *b) #endif /* !HAS_RENAME */ char* -Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **search_ext, I32 flags) +Perl_find_script(pTHX_ const char *scriptname, bool dosearch, + const char *const *const search_ext, I32 flags) { const char *xfound = Nullch; char *xfailed = Nullch; @@ -2753,12 +2840,12 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **searc #endif /* additional extensions to try in each dir if scriptname not found */ #ifdef SEARCH_EXTS - const char *exts[] = { SEARCH_EXTS }; - const char **ext = search_ext ? search_ext : exts; + 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; #else - (void)search_ext; + PERL_UNUSED_ARG(search_ext); # define MAX_EXT_LEN 0 #endif @@ -2786,16 +2873,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **searc # ifdef ALWAYS_DEFTYPES len = strlen(scriptname); if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') { - int hasdir, idx = 0, deftypes = 1; + int idx = 0, deftypes = 1; bool seen_dot = 1; - hasdir = !dosearch || (strpbrk(scriptname,":[= sizeof(tmpbuf)) break; + /* FIXME? Convert to memcpy */ cur = strcpy(tmpbuf, scriptname); } } while (extidx >= 0 && ext[extidx] /* try an extension? */ @@ -2895,15 +2983,17 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **searc tmpbuf[len++] = ':'; #else if (len -#if defined(atarist) || defined(__MINT__) || defined(DOSISH) +# if defined(atarist) || defined(__MINT__) || defined(DOSISH) && tmpbuf[len - 1] != '/' && tmpbuf[len - 1] != '\\' -#endif +# endif ) tmpbuf[len++] = '/'; if (len == 2 && tmpbuf[0] == '.') seen_dot = 1; #endif + /* FIXME? Convert to memcpy by storing previous strlen(scriptname) + */ (void)strcpy(tmpbuf + len, scriptname); #endif /* !VMS */ @@ -2955,8 +3045,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); @@ -2989,7 +3078,7 @@ Perl_get_context(void) void Perl_set_context(void *t) { - dVAR; + dVAR; #if defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); @@ -2998,7 +3087,7 @@ Perl_set_context(void *t) Perl_croak_nocontext("panic: pthread_setspecific"); # endif #else - (void)t; + PERL_UNUSED_ARG(t); #endif } @@ -3047,7 +3136,7 @@ Perl_get_ppaddr(pTHX) char * Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) { - char *env_trans = PerlEnv_getenv(env_elem); + char * const env_trans = PerlEnv_getenv(env_elem); if (env_trans) *len = strlen(env_trans); return env_trans; @@ -3210,23 +3299,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", @@ -3341,11 +3426,13 @@ Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ { #ifdef HAS_TM_TM_ZONE Time_t now; - struct tm* my_tm; + const struct tm* my_tm; (void)time(&now); my_tm = localtime(&now); if (my_tm) Copy(my_tm, ptm, 1, struct tm); +#else + PERL_UNUSED_ARG(ptm); #endif } @@ -3581,7 +3668,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 @@ -3604,7 +3691,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) @@ -3823,54 +3910,59 @@ it doesn't. const char * Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) { - const char *start = s; + const char *start; const char *pos; const char *last; int saw_period = 0; - int saw_under = 0; + int alpha = 0; int width = 3; AV *av = newAV(); - SV* hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ + SV *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 + HvSHAREKEYS_on(hv); /* key-sharing on by default */ +#endif + + while (isSPACE(*s)) /* leading whitespace is OK */ + s++; + if (*s == 'v') { s++; /* get past 'v' */ qv = 1; /* force quoted version processing */ } - last = pos = s; + start = last = pos = s; /* pre-scan the input string to check for decimals/underbars */ while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) { if ( *pos == '.' ) { - if ( saw_under ) + if ( alpha ) Perl_croak(aTHX_ "Invalid version format (underscores before decimal)"); saw_period++ ; last = pos; } else if ( *pos == '_' ) { - if ( saw_under ) + if ( alpha ) Perl_croak(aTHX_ "Invalid version format (multiple underscores)"); - saw_under = 1; + alpha = 1; width = pos - last - 1; /* natural width of sub-version */ } pos++; } - if ( saw_period > 1 ) { + if ( saw_period > 1 ) qv = 1; /* force quoted version processing */ - } pos = s; if ( qv ) - hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0); - if ( saw_under ) { - hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); - } + hv_store((HV *)hv, "qv", 2, newSViv(qv), 0); + if ( alpha ) + hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0); if ( !qv && width < 3 ) hv_store((HV *)hv, "width", 5, newSViv(width), 0); @@ -3891,7 +3983,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) * point of a version originally created with a bare * floating point number, i.e. not quoted in any way */ - if ( !qv && s > start+1 && saw_period == 1 ) { + if ( !qv && s > start && saw_period == 1 ) { mult *= 100; while ( s < end ) { orev = rev; @@ -3959,7 +4051,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) av_push(av, newSViv(0)); /* And finally, store the AV in the hash */ - hv_store((HV *)hv, "version", 7, (SV *)av, 0); + hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); return s; } @@ -3979,15 +4071,18 @@ want to upgrade the SV. SV * Perl_new_version(pTHX_ SV *ver) { - SV *rv = newSV(0); + SV * const rv = newSV(0); if ( sv_derived_from(ver,"version") ) /* can just copy directly */ { I32 key; - AV *av = newAV(); + AV * const av = newAV(); AV *sav; /* This will get reblessed later if a derived class*/ - SV* hv = newSVrv(rv, "version"); + SV * const hv = newSVrv(rv, "version"); (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(hv); /* key-sharing on by default */ +#endif if ( SvROK(ver) ) ver = SvRV(ver); @@ -4001,11 +4096,11 @@ Perl_new_version(pTHX_ SV *ver) if ( hv_exists((HV*)ver, "width", 5 ) ) { - I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE)); + const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE)); hv_store((HV *)hv, "width", 5, newSViv(width), 0); } - sav = (AV *)*hv_fetch((HV*)ver, "version", 7, FALSE); + sav = (AV *)SvRV(*hv_fetch((HV*)ver, "version", 7, FALSE)); /* This will get reblessed later if a derived class*/ for ( key = 0; key <= av_len(sav); key++ ) { @@ -4013,15 +4108,15 @@ Perl_new_version(pTHX_ SV *ver) av_push(av, newSViv(rev)); } - hv_store((HV *)hv, "version", 7, (SV *)av, 0); + hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); return rv; } #ifdef SvVOK 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 MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring); + const STRLEN len = mg->mg_len; + char * const version = savepvn( (const char*)mg->mg_ptr, len); + sv_setpvn(rv,version,len); Safefree(version); } else { @@ -4060,7 +4155,7 @@ Perl_upg_version(pTHX_ SV *ver) } #ifdef SvVOK else if ( SvVOK(ver) ) { /* already a v-string */ - MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); + const MAGIC* const mg = mg_find(ver,PERL_MAGIC_vstring); version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); qv = 1; } @@ -4074,6 +4169,45 @@ Perl_upg_version(pTHX_ SV *ver) return ver; } +/* +=for apidoc vverify + +Validates that the SV contains a valid version object. + + bool vverify(SV *vobj); + +Note that it only confirms the bare minimum structure (so as not to get +confused by derived classes which may contain additional hash entries): + +=over 4 + +=item * The SV contains a [reference to a] hash + +=item * The hash contains a "version" key + +=item * The "version" key has [a reference to] an AV as its value + +=back + +=cut +*/ + +bool +Perl_vverify(pTHX_ SV *vs) +{ + SV *sv; + if ( SvROK(vs) ) + vs = SvRV(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))) + && SvTYPE(sv) == SVt_PVAV ) + return TRUE; + else + return FALSE; +} /* =for apidoc vnumify @@ -4095,11 +4229,14 @@ Perl_vnumify(pTHX_ SV *vs) I32 i, len, digit; int width; bool alpha = FALSE; - SV *sv = newSV(0); + SV * const sv = newSV(0); AV *av; if ( SvROK(vs) ) vs = SvRV(vs); + if ( !vverify(vs) ) + Perl_croak(aTHX_ "Invalid version object"); + /* see if various flags exist */ if ( hv_exists((HV*)vs, "alpha", 5 ) ) alpha = TRUE; @@ -4110,8 +4247,8 @@ Perl_vnumify(pTHX_ SV *vs) /* attempt to retrieve the version array */ - if ( !(av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE) ) ) { - Perl_sv_catpv(aTHX_ sv,"0"); + if ( !(av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)) ) ) { + sv_catpvn(sv,"0",1); return sv; } @@ -4123,17 +4260,17 @@ Perl_vnumify(pTHX_ SV *vs) } digit = SvIV(*av_fetch(av, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit)); + Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit)); for ( i = 1 ; i < len ; i++ ) { digit = SvIV(*av_fetch(av, i, 0)); if ( width < 3 ) { - int denom = (int)pow(10,(3-width)); - div_t term = div((int)PERL_ABS(digit),denom); - Perl_sv_catpvf(aTHX_ sv,"%0*d_%d", width, term.quot, term.rem); + const int denom = (int)pow(10,(3-width)); + const div_t term = div((int)PERL_ABS(digit),denom); + Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem); } else { - Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit); + Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); } } @@ -4141,14 +4278,12 @@ Perl_vnumify(pTHX_ SV *vs) { digit = SvIV(*av_fetch(av, len, 0)); if ( alpha && width == 3 ) /* alpha version */ - Perl_sv_catpv(aTHX_ sv,"_"); - /* Don't display additional trailing zeros */ - if ( digit > 0 ) - Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit); + sv_catpvn(sv,"_",1); + Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit); } - else /* len == 1 */ + else /* len == 0 */ { - sv_catpvn(sv,"000",3); + sv_catpvn(sv,"000",3); } return sv; } @@ -4172,28 +4307,33 @@ Perl_vnormal(pTHX_ SV *vs) { I32 i, len, digit; bool alpha = FALSE; - SV *sv = newSV(0); + SV * const sv = newSV(0); AV *av; if ( SvROK(vs) ) vs = SvRV(vs); + if ( !vverify(vs) ) + Perl_croak(aTHX_ "Invalid version object"); + if ( hv_exists((HV*)vs, "alpha", 5 ) ) alpha = TRUE; - av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE); + av = (AV *)SvRV(*hv_fetch((HV*)vs, "version", 7, FALSE)); len = av_len(av); - if ( len == -1 ) { + if ( len == -1 ) + { sv_catpvn(sv,"",0); return sv; } digit = SvIV(*av_fetch(av, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"v%"IVdf,(IV)digit); - for ( i = 1 ; i <= len-1 ; i++ ) { + Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit); + for ( i = 1 ; i < len ; i++ ) { digit = SvIV(*av_fetch(av, i, 0)); Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); } - if ( len > 0 ) { + if ( len > 0 ) + { /* handle last digit specially */ digit = SvIV(*av_fetch(av, len, 0)); if ( alpha ) @@ -4206,7 +4346,6 @@ Perl_vnormal(pTHX_ SV *vs) for ( len = 2 - len; len != 0; len-- ) sv_catpvn(sv,".0",2); } - return sv; } @@ -4224,14 +4363,13 @@ the original version contained 1 or more dots, respectively SV * Perl_vstringify(pTHX_ SV *vs) { - I32 qv = 0; if ( SvROK(vs) ) vs = SvRV(vs); + if ( !vverify(vs) ) + Perl_croak(aTHX_ "Invalid version object"); + if ( hv_exists((HV *)vs, "qv", 2) ) - qv = 1; - - if ( qv ) return vnormal(vs); else return vnumify(vs); @@ -4260,13 +4398,19 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) if ( SvROK(rhv) ) rhv = SvRV(rhv); + if ( !vverify(lhv) ) + Perl_croak(aTHX_ "Invalid version object"); + + if ( !vverify(rhv) ) + Perl_croak(aTHX_ "Invalid version object"); + /* get the left hand term */ - lav = (AV *)*hv_fetch((HV*)lhv, "version", 7, FALSE); + lav = (AV *)SvRV(*hv_fetch((HV*)lhv, "version", 7, FALSE)); if ( hv_exists((HV*)lhv, "alpha", 5 ) ) lalpha = TRUE; /* and the right hand term */ - rav = (AV *)*hv_fetch((HV*)rhv, "version", 7, FALSE); + rav = (AV *)SvRV(*hv_fetch((HV*)rhv, "version", 7, FALSE)); if ( hv_exists((HV*)rhv, "alpha", 5 ) ) ralpha = TRUE; @@ -4590,8 +4734,9 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { =for apidoc sv_nosharing Dummy routine which "shares" an SV when there is no sharing module present. -Exists to avoid test for a NULL function pointer and because it could potentially warn under -some level of strict-ness. +Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument. +Exists to avoid test for a NULL function pointer and because it could +potentially warn under some level of strict-ness. =cut */ @@ -4599,40 +4744,7 @@ some level of strict-ness. void Perl_sv_nosharing(pTHX_ SV *sv) { - (void)sv; -} - -/* -=for apidoc sv_nolocking - -Dummy routine which "locks" an SV when there is no locking module present. -Exists to avoid test for a NULL function pointer and because it could potentially warn under -some level of strict-ness. - -=cut -*/ - -void -Perl_sv_nolocking(pTHX_ SV *sv) -{ - (void)sv; -} - - -/* -=for apidoc sv_nounlocking - -Dummy routine which "unlocks" an SV when there is no locking module present. -Exists to avoid test for a NULL function pointer and because it could potentially warn under -some level of strict-ness. - -=cut -*/ - -void -Perl_sv_nounlocking(pTHX_ SV *sv) -{ - (void)sv; + PERL_UNUSED_ARG(sv); } U32 @@ -4898,6 +5010,76 @@ 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 */ + +/* +=for apidoc my_sprintf + +The C library C, wrapped if necessary, to ensure that it will return +the length of the string written to the buffer. Only rare pre-ANSI systems +need the wrapper function - usually this is a direct call to C. + +=cut +*/ +#ifndef SPRINTF_RETURNS_STRLEN +int +Perl_my_sprintf(char *buffer, const char* pat, ...) +{ + va_list args; + va_start(args, pat); + vsprintf(buffer, pat, args); + va_end(args); + return strlen(buffer); +} +#endif + /* * Local variables: * c-indentation-style: bsd