X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7cb608b5fc09aa914d5f91646e40ed772b6bac01..317f7c8a941b7bf35ae65f6c2b1ed46e040c4441:/util.c diff --git a/util.c b/util.c index 420232c..7a89c5c 100644 --- a/util.c +++ b/util.c @@ -96,7 +96,13 @@ Perl_safesysmalloc(MEM_SIZE size) #ifdef PERL_TRACK_MEMPOOL struct perl_memory_debug_header *const header = (struct perl_memory_debug_header *)ptr; +#endif + +#ifdef PERL_POISON + PoisonNew(((char *)ptr), size, char); +#endif +#ifdef PERL_TRACK_MEMPOOL header->interpreter = aTHX; /* Link us into the list. */ header->prev = &PL_memory_debug_header; @@ -159,7 +165,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) if (header->size > size) { const MEM_SIZE freed_up = header->size - size; char *start_of_freed = ((char *)where) + size; - Poison(start_of_freed, freed_up, char); + PoisonFree(start_of_freed, freed_up, char); } header->size = size; # endif @@ -180,6 +186,14 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) struct perl_memory_debug_header *const header = (struct perl_memory_debug_header *)ptr; +# ifdef PERL_POISON + if (header->size < size) { + const MEM_SIZE fresh = size - header->size; + char *start_of_fresh = ((char *)ptr) + size; + PoisonNew(start_of_fresh, fresh, char); + } +# endif + header->next->prev = header; header->prev->next = header; @@ -227,7 +241,7 @@ Perl_safesysfree(Malloc_t where) header->next->prev = header->prev; header->prev->next = header->next; # ifdef PERL_POISON - Poison(where, header->size, char); + PoisonNew(where, header->size, char); # endif /* Trigger the duplicate free warning. */ header->next = NULL; @@ -326,16 +340,16 @@ char * Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen) { register I32 tolen; + PERL_UNUSED_CONTEXT; + for (tolen = 0; from < fromend; from++, tolen++) { if (*from == '\\') { - if (from[1] == delim) - from++; - else { + if (from[1] != delim) { if (to < toend) *to++ = *from; tolen++; - from++; } + from++; } else if (*from == delim) break; @@ -355,6 +369,7 @@ char * Perl_instr(pTHX_ register const char *big, register const char *little) { register I32 first; + PERL_UNUSED_CONTEXT; if (!little) return (char*)big; @@ -386,6 +401,7 @@ Perl_instr(pTHX_ register const char *big, register const char *little) char * Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend) { + PERL_UNUSED_CONTEXT; if (little >= lend) return (char*)big; { @@ -414,6 +430,7 @@ 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 * const littleend = lend; + PERL_UNUSED_CONTEXT; if (little >= littleend) return (char*)bigend; @@ -815,6 +832,8 @@ Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) { register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; + PERL_UNUSED_CONTEXT; + while (len--) { if (*a != *b && *a != PL_fold[*b]) return 1; @@ -829,6 +848,8 @@ Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) dVAR; register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; + PERL_UNUSED_CONTEXT; + while (len--) { if (*a != *b && *a != PL_fold_locale[*b]) return 1; @@ -855,15 +876,15 @@ be freed with the C function. char * Perl_savepv(pTHX_ const char *pv) { + PERL_UNUSED_CONTEXT; if (!pv) return NULL; else { char *newaddr; const STRLEN pvlen = strlen(pv)+1; - Newx(newaddr,pvlen,char); - return memcpy(newaddr,pv,pvlen); + Newx(newaddr, pvlen, char); + return (char*)memcpy(newaddr, pv, pvlen); } - } /* same thing but with a known length */ @@ -873,8 +894,8 @@ Perl_savepv(pTHX_ const char *pv) Perl's version of what C would be if it existed. Returns a pointer to a newly allocated string which is a duplicate of the first -C bytes from C. The memory allocated for the new string can be -freed with the C function. +C bytes from C, plus a trailing NUL byte. The memory allocated for +the new string can be freed with the C function. =cut */ @@ -883,6 +904,7 @@ char * Perl_savepvn(pTHX_ const char *pv, register I32 len) { register char *newaddr; + PERL_UNUSED_CONTEXT; Newx(newaddr,len+1,char); /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ @@ -917,7 +939,7 @@ Perl_savesharedpv(pTHX_ const char *pv) if (!newaddr) { return write_no_mem(); } - return memcpy(newaddr,pv,pvlen); + return (char*)memcpy(newaddr, pv, pvlen); } /* @@ -1017,7 +1039,7 @@ char * Perl_vform(pTHX_ const char *pat, va_list *args) { SV * const sv = mess_alloc(); - sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); return SvPVX(sv); } @@ -1046,8 +1068,8 @@ Perl_mess(pTHX_ const char *pat, ...) return retval; } -STATIC COP* -S_closest_cop(pTHX_ COP *cop, const OP *o) +STATIC const COP* +S_closest_cop(pTHX_ const COP *cop, const OP *o) { dVAR; /* Look for PL_op starting from o. cop is the last COP we've seen. */ @@ -1056,15 +1078,15 @@ S_closest_cop(pTHX_ COP *cop, const OP *o) return cop; if (o->op_flags & OPf_KIDS) { - OP *kid; + const OP *kid; for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) { - COP *new_cop; + const COP *new_cop; /* If the OP_NEXTSTATE has been optimised away we can still use it * the get the file and line number. */ if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) - cop = (COP *)kid; + cop = (const COP *)kid; /* Keep searching, and return when we've found something. */ @@ -1076,7 +1098,7 @@ S_closest_cop(pTHX_ COP *cop, const OP *o) /* Nothing found. */ - return Null(COP *); + return NULL; } SV * @@ -1084,11 +1106,9 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) { dVAR; 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*)); + sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { - /* * Try and find the file and line for PL_op. This will usually be * PL_curcop, but it might be a cop that has been optimised away. We @@ -1097,7 +1117,8 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) */ const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling); - if (!cop) cop = PL_curcop; + if (!cop) + cop = PL_curcop; if (CopLINE(cop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, @@ -1106,12 +1127,13 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) const bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n'); Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, - PL_last_in_gv == PL_argvgv ? - "" : GvNAME(PL_last_in_gv), + PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), line_mode ? "line" : "chunk", (IV)IoLINES(GvIOp(PL_last_in_gv))); } - sv_catpv(sv, PL_dirty ? dgd : ".\n"); + if (PL_dirty) + sv_catpvs(sv, " during global destruction"); + sv_catpvs(sv, ".\n"); } return sv; } @@ -1433,7 +1455,7 @@ void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) { dVAR; - if (ckDEAD(err)) { + if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { SV * const msv = vmess(pat, args); STRLEN msglen; const char * const message = SvPV_const(msv, msglen); @@ -1508,7 +1530,21 @@ Perl_ckwarn_d(pTHX_ U32 w) ; } +/* Set buffer=NULL to get a new one. */ +STRLEN * +Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, + STRLEN size) { + const MEM_SIZE len_wanted = sizeof(STRLEN) + size; + PERL_UNUSED_CONTEXT; + buffer = (STRLEN*) + (specialWARN(buffer) ? + PerlMemShared_malloc(len_wanted) : + PerlMemShared_realloc(buffer, len_wanted)); + buffer[0] = size; + Copy(bits, (buffer + 1), size, char); + return buffer; +} /* since we've already done strlen() for both nam and val * we can use that info to make things faster than @@ -1543,7 +1579,9 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) I32 max; char **tmpenv; - for (max = i; environ[max]; max++) ; + max = i; + while (environ[max]) + max++; tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); for (j=0; j= 0; i++) ; - return i ? 0 : -1; + while (PerlLIO_unlink(f) >= 0) + retries++; + return retries ? 0 : -1; } #endif @@ -1859,8 +1899,8 @@ Perl_my_ntohl(pTHX_ long l) type value; \ char c[sizeof(type)]; \ } u; \ - register I32 i; \ - register I32 s = 0; \ + register U32 i; \ + register U32 s = 0; \ for (i = 0; i < sizeof(u.c); i++, s += 8) { \ u.c[i] = (n >> s) & 0xFF; \ } \ @@ -1875,8 +1915,8 @@ Perl_my_ntohl(pTHX_ long l) type value; \ char c[sizeof(type)]; \ } u; \ - register I32 i; \ - register I32 s = 0; \ + register U32 i; \ + register U32 s = 0; \ u.value = n; \ n = 0; \ for (i = 0; i < sizeof(u.c); i++, s += 8) { \ @@ -1897,8 +1937,8 @@ Perl_my_ntohl(pTHX_ long l) type value; \ char c[sizeof(type)]; \ } u; \ - register I32 i; \ - register I32 s = 8*(sizeof(u.c)-1); \ + register U32 i; \ + register U32 s = 8*(sizeof(u.c)-1); \ for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ u.c[i] = (n >> s) & 0xFF; \ } \ @@ -1913,8 +1953,8 @@ Perl_my_ntohl(pTHX_ long l) type value; \ char c[sizeof(type)]; \ } u; \ - register I32 i; \ - register I32 s = 8*(sizeof(u.c)-1); \ + register U32 i; \ + register U32 s = 8*(sizeof(u.c)-1); \ u.value = n; \ n = 0; \ for (i = 0; i < sizeof(u.c); i++, s -= 8) { \ @@ -2109,7 +2149,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) taint_proper("Insecure %s%s", "EXEC"); } if (PerlProc_pipe(p) < 0) - return Nullfp; + return NULL; /* Try for another pipe pair for error return */ if (PerlProc_pipe(pp) >= 0) did_pipes = 1; @@ -2121,7 +2161,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) PerlLIO_close(pp[0]); PerlLIO_close(pp[1]); } - return Nullfp; + return NULL; } sleep(5); } @@ -2189,7 +2229,8 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) /* If we managed to get status pipe check for exec fail */ if (did_pipes && pid > 0) { int errkid; - int n = 0, n1; + unsigned n = 0; + SSize_t n1; while (n < sizeof(int)) { n1 = PerlLIO_read(pp[0], @@ -2210,7 +2251,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) pid2 = wait4pid(pid, &status, 0); } while (pid2 == -1 && errno == EINTR); errno = errkid; /* Propagate errno from kid */ - return Nullfp; + return NULL; } } if (did_pipes) @@ -2249,7 +2290,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) taint_proper("Insecure %s%s", "EXEC"); } if (PerlProc_pipe(p) < 0) - return Nullfp; + return NULL; if (doexec && PerlProc_pipe(pp) >= 0) did_pipes = 1; while ((pid = PerlProc_fork()) < 0) { @@ -2262,7 +2303,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) } if (!doexec) Perl_croak(aTHX_ "Can't fork"); - return Nullfp; + return NULL; } sleep(5); } @@ -2318,7 +2359,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) #ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); /* we have no children */ #endif - return Nullfp; + return NULL; #undef THIS #undef THAT } @@ -2341,7 +2382,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) PL_forkprocess = pid; if (did_pipes && pid > 0) { int errkid; - int n = 0, n1; + unsigned n = 0; + SSize_t n1; while (n < sizeof(int)) { n1 = PerlLIO_read(pp[0], @@ -2362,7 +2404,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) pid2 = wait4pid(pid, &status, 0); } while (pid2 == -1 && errno == EINTR); errno = errkid; /* Propagate errno from kid */ - return Nullfp; + return NULL; } } if (did_pipes) @@ -2542,6 +2584,7 @@ Sighandler_t Perl_rsignal_state(pTHX_ int signo) { struct sigaction oact; + PERL_UNUSED_CONTEXT; if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1) return (Sighandler_t) SIG_ERR; @@ -2768,7 +2811,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) goto finish; #endif #if !defined(HAS_WAITPID) && defined(HAS_WAIT4) - result = wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *)); + result = wait4((pid==-1)?0:pid,statusp,flags,NULL); goto finish; #endif #ifdef PERL_USES_PL_PIDSTATUS @@ -2847,6 +2890,7 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi { register I32 todo; register const char * const frombase = from; + PERL_UNUSED_CONTEXT; if (len == 1) { register const char c = *from; @@ -2980,7 +3024,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, if ((strlen(tmpbuf) + strlen(scriptname) + MAX_EXT_LEN) >= sizeof tmpbuf) continue; /* don't search dir with too-long name */ - strcat(tmpbuf, scriptname); + my_strlcat(tmpbuf, scriptname, sizeof(tmpbuf)); #else /* !VMS */ #ifdef DOSISH @@ -3012,11 +3056,11 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, len = strlen(scriptname); if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf)) break; - /* FIXME? Convert to memcpy */ - cur = strcpy(tmpbuf, scriptname); + my_strlcpy(tmpbuf, scriptname, sizeof(tmpbuf)); + cur = tmpbuf; } } while (extidx >= 0 && ext[extidx] /* try an extension? */ - && strcpy(tmpbuf+len, ext[extidx++])); + && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len)); #endif } #endif @@ -3076,9 +3120,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, if (len == 2 && tmpbuf[0] == '.') seen_dot = 1; #endif - /* FIXME? Convert to memcpy by storing previous strlen(scriptname) - */ - (void)strcpy(tmpbuf + len, scriptname); + (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len); #endif /* !VMS */ #ifdef SEARCH_EXTS @@ -3095,7 +3137,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, #ifdef SEARCH_EXTS } while ( retval < 0 /* not there */ && extidx>=0 && ext[extidx] /* try an extension? */ - && strcpy(tmpbuf+len, ext[extidx++]) + && my_strlcpy(tmpbuf+len, ext[extidx++], sizeof(tmpbuf) - len) ); #endif if (retval < 0) @@ -3188,32 +3230,37 @@ Perl_GetVars(pTHX) char ** Perl_get_op_names(pTHX) { - return (char **)PL_op_name; + PERL_UNUSED_CONTEXT; + return (char **)PL_op_name; } char ** Perl_get_op_descs(pTHX) { - return (char **)PL_op_desc; + PERL_UNUSED_CONTEXT; + return (char **)PL_op_desc; } const char * Perl_get_no_modify(pTHX) { - return PL_no_modify; + PERL_UNUSED_CONTEXT; + return PL_no_modify; } U32 * Perl_get_opargs(pTHX) { - return (U32 *)PL_opargs; + PERL_UNUSED_CONTEXT; + return (U32 *)PL_opargs; } PPADDR_t* Perl_get_ppaddr(pTHX) { - dVAR; - return (PPADDR_t*)PL_ppaddr; + dVAR; + PERL_UNUSED_CONTEXT; + return (PPADDR_t*)PL_ppaddr; } #ifndef HAS_GETENV_LEN @@ -3221,6 +3268,7 @@ char * Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) { char * const env_trans = PerlEnv_getenv(env_elem); + PERL_UNUSED_CONTEXT; if (env_trans) *len = strlen(env_trans); return env_trans; @@ -3232,6 +3280,7 @@ MGVTBL* Perl_get_vtbl(pTHX_ int vtbl_id) { const MGVTBL* result; + PERL_UNUSED_CONTEXT; switch(vtbl_id) { case want_vtbl_sv: @@ -3267,9 +3316,6 @@ Perl_get_vtbl(pTHX_ int vtbl_id) case want_vtbl_arylen: result = &PL_vtbl_arylen; break; - case want_vtbl_glob: - result = &PL_vtbl_glob; - break; case want_vtbl_mglob: result = &PL_vtbl_mglob; break; @@ -3327,7 +3373,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) result = &PL_vtbl_utf8; break; default: - result = Null(MGVTBL*); + result = NULL; break; } return (MGVTBL*)result; @@ -3386,19 +3432,12 @@ Perl_my_fflush_all(pTHX) void Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op) { - const char * const func = - op == OP_READLINE ? "readline" : /* "" not nice */ - op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ - PL_op_desc[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 * 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 * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out"; + const char * const direction = + (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out"); if (name && *name) Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %s opened only for %sput", @@ -3422,6 +3461,19 @@ Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op) } if (ckWARN(warn_type)) { + const char * const pars = + (const char *)(OP_IS_FILETEST(op) ? "" : "()"); + const char * const func = + (const char *) + (op == OP_READLINE ? "readline" : /* "" not nice */ + op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ + op < 0 ? "" : /* handle phoney cases */ + PL_op_desc[op]); + const char * const type = + (const char *) + (OP_IS_SOCKET(op) || + (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ? + "socket" : "filehandle"); if (name && *name) { Perl_warner(aTHX_ packWARN(warn_type), "%s%s on %s %s %s", func, pars, vile, type, name); @@ -3534,6 +3586,7 @@ Perl_mini_mktime(pTHX_ struct tm *ptm) int secs; int month, mday, year, jday; int odd_cent, odd_year; + PERL_UNUSED_CONTEXT; #define DAYS_PER_YEAR 365 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) @@ -4099,7 +4152,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) /* Append revision */ av_push(av, newSViv(rev)); - if ( *pos == '.' && isDIGIT(pos[1]) ) + if ( *pos == '.' ) s = ++pos; else if ( *pos == '_' && isDIGIT(pos[1]) ) s = ++pos; @@ -4140,6 +4193,11 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */ av_push(av, newSViv(0)); + /* fix RT#19517 - special case 'undef' as string */ + if ( *s == 'u' && strEQ(s,"undef") ) { + s += 5; + } + /* And finally, store the AV in the hash */ hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); return s; @@ -4204,7 +4262,7 @@ Perl_new_version(pTHX_ SV *ver) } #ifdef SvVOK { - const MAGIC* const mg = SvVOK(ver); + const MAGIC* const mg = SvVSTRING_mg(ver); if ( mg ) { /* already a v-string */ const STRLEN len = mg->mg_len; char * const version = savepvn( (const char*)mg->mg_ptr, len); @@ -4245,11 +4303,12 @@ Perl_upg_version(pTHX_ SV *ver) if ( SvNOK(ver) ) /* may get too much accuracy */ { char tbuf[64]; - const STRLEN len = my_sprintf(tbuf,"%.9"NVgf, SvNVX(ver)); + STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver)); + while (tbuf[len-1] == '0' && len > 0) len--; version = savepvn(tbuf, len); } #ifdef SvVOK - else if ( (mg = SvVOK(ver)) ) { /* already a v-string */ + else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); qv = 1; } @@ -4258,12 +4317,13 @@ Perl_upg_version(pTHX_ SV *ver) { version = savepv(SvPV_nolen(ver)); } + s = scan_version(version, ver, qv); if ( *s != '\0' ) - if(ckWARN(WARN_MISC)) + if(ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), - "Version string '%s' contains invalid data; " - "ignoring: '%s'", version, s); + "Version string '%s' contains invalid data; " + "ignoring: '%s'", version, s); Safefree(version); return ver; } @@ -4843,6 +4903,7 @@ potentially warn under some level of strict-ness. void Perl_sv_nosharing(pTHX_ SV *sv) { + PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(sv); } @@ -4855,7 +4916,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) if (*p) { if (isDIGIT(*p)) { opt = (U32) atoi(p); - while (isDIGIT(*p)) p++; + while (isDIGIT(*p)) + p++; if (*p && *p != '\n' && *p != '\r') Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p); } @@ -4880,6 +4942,8 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) opt |= PERL_UNICODE_LOCALE_FLAG; break; case PERL_UNICODE_ARGV: opt |= PERL_UNICODE_ARGV_FLAG; break; + case PERL_UNICODE_UTF8CACHEASSERT: + opt |= PERL_UNICODE_UTF8CACHEASSERT_FLAG; break; default: if (*p != '\n' && *p != '\r') Perl_croak(aTHX_ @@ -4990,7 +5054,8 @@ Perl_get_hash_seed(pTHX) UV myseed = 0; if (s) - while (isSPACE(*s)) s++; + while (isSPACE(*s)) + s++; if (s && isDIGIT(*s)) myseed = (UV)Atoul(s); else @@ -5026,6 +5091,7 @@ Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv) { const char * const stashpv = CopSTASHPV(c); const char * const name = HvNAME_get(hv); + PERL_UNUSED_CONTEXT; if (stashpv == name) return TRUE; @@ -5113,20 +5179,78 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) #ifdef PERL_MEM_LOG +/* + * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled. + * + * PERL_MEM_LOG_ENV: if defined, during run time the environment + * variable PERL_MEM_LOG will be consulted, and if the integer value + * of that is true, the logging will happen. (The default is to + * always log if the PERL_MEM_LOG define was in effect.) + */ + +/* + * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer + * the Perl_mem_log_...() will use (either via sprintf or snprintf). + */ #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 +/* + * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will + * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD, + * in which case the environment variable PERL_MEM_LOG_FD will be + * consulted for the file descriptor number to use. + */ +#ifndef PERL_MEM_LOG_FD +# define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */ +#endif + 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]; - 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); +# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) + char *s; +# endif +# ifdef PERL_MEM_LOG_ENV + s = getenv("PERL_MEM_LOG"); + if (s ? atoi(s) : 0) +# endif + { + /* We can't use SVs or PerlIO for obvious reasons, + * so we'll use stdio and low-level IO instead. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; +# ifdef PERL_MEM_LOG_TIMESTAMP + struct timeval tv; +# ifdef HAS_GETTIMEOFDAY + gettimeofday(&tv, 0); +# endif + /* If there are other OS specific ways of hires time than + * gettimeofday() (see ext/Time/HiRes), the easiest way is + * probably that they would be used to fill in the struct + * timeval. */ +# endif + { + const STRLEN len = + my_snprintf(buf, + sizeof(buf), +# ifdef PERL_MEM_LOG_TIMESTAMP + "%10d.%06d: " +# endif + "alloc: %s:%d:%s: %"IVdf" %"UVuf + " %s = %"IVdf": %"UVxf"\n", +# ifdef PERL_MEM_LOG_TIMESTAMP + (int)tv.tv_sec, (int)tv.tv_usec, +# endif + filename, linenumber, funcname, n, typesize, + typename, n * typesize, PTR2UV(newalloc)); +# ifdef PERL_MEM_LOG_ENV_FD + s = PerlEnv_getenv("PERL_MEM_LOG_FD"); + PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len); +# else + PerlLIO_write(PERL_MEM_LOG_FD, buf, len); +#endif + } + } #endif return newalloc; } @@ -5135,14 +5259,44 @@ 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]; - 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); +# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) + char *s; +# endif +# ifdef PERL_MEM_LOG_ENV + s = PerlEnv_getenv("PERL_MEM_LOG"); + if (s ? atoi(s) : 0) +# endif + { + /* We can't use SVs or PerlIO for obvious reasons, + * so we'll use stdio and low-level IO instead. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; +# ifdef PERL_MEM_LOG_TIMESTAMP + struct timeval tv; + gettimeofday(&tv, 0); +# endif + { + const STRLEN len = + my_snprintf(buf, + sizeof(buf), +# ifdef PERL_MEM_LOG_TIMESTAMP + "%10d.%06d: " +# endif + "realloc: %s:%d:%s: %"IVdf" %"UVuf + " %s = %"IVdf": %"UVxf" -> %"UVxf"\n", +# ifdef PERL_MEM_LOG_TIMESTAMP + (int)tv.tv_sec, (int)tv.tv_usec, +# endif + filename, linenumber, funcname, n, typesize, + typename, n * typesize, PTR2UV(oldalloc), + PTR2UV(newalloc)); +# ifdef PERL_MEM_LOG_ENV_FD + s = PerlEnv_getenv("PERL_MEM_LOG_FD"); + PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len); +# else + PerlLIO_write(PERL_MEM_LOG_FD, buf, len); +# endif + } + } #endif return newalloc; } @@ -5151,12 +5305,42 @@ 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]; - const STRLEN len = my_sprintf(buf, "free: %s:%d:%s: %"UVxf"\n", - filename, linenumber, funcname, - PTR2UV(oldalloc)); - PerlLIO_write(2, buf, len); +# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) + char *s; +# endif +# ifdef PERL_MEM_LOG_ENV + s = PerlEnv_getenv("PERL_MEM_LOG"); + if (s ? atoi(s) : 0) +# endif + { + /* We can't use SVs or PerlIO for obvious reasons, + * so we'll use stdio and low-level IO instead. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; +# ifdef PERL_MEM_LOG_TIMESTAMP + struct timeval tv; + gettimeofday(&tv, 0); +# endif + { + const STRLEN len = + my_snprintf(buf, + sizeof(buf), +# ifdef PERL_MEM_LOG_TIMESTAMP + "%10d.%06d: " +# endif + "free: %s:%d:%s: %"UVxf"\n", +# ifdef PERL_MEM_LOG_TIMESTAMP + (int)tv.tv_sec, (int)tv.tv_usec, +# endif + filename, linenumber, funcname, + PTR2UV(oldalloc)); +# ifdef PERL_MEM_LOG_ENV_FD + s = PerlEnv_getenv("PERL_MEM_LOG_FD"); + PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len); +# else + PerlLIO_write(PERL_MEM_LOG_FD, buf, len); +# endif + } + } #endif return oldalloc; } @@ -5184,6 +5368,74 @@ Perl_my_sprintf(char *buffer, const char* pat, ...) } #endif +/* +=for apidoc my_snprintf + +The C library C functionality, if available and +standards-compliant (uses C, actually). However, if the +C is not available, will unfortunately use the unsafe +C which can overrun the buffer (there is an overrun check, +but that may be too late). Consider using C instead, or +getting C. + +=cut +*/ +int +Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) +{ + dTHX; + int retval; + va_list ap; + va_start(ap, format); +#ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, ap); +#else + retval = vsprintf(buffer, format, ap); +#endif + va_end(ap); + /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */ + if (retval < 0 || (len > 0 && (Size_t)retval >= len)) + Perl_croak(aTHX_ "panic: my_snprintf buffer overflow"); + return retval; +} + +/* +=for apidoc my_vsnprintf + +The C library C if available and standards-compliant. +However, if if the C is not available, will unfortunately +use the unsafe C which can overrun the buffer (there is an +overrun check, but that may be too late). Consider using +C instead, or getting C. + +=cut +*/ +int +Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap) +{ + dTHX; + int retval; +#ifdef NEED_VA_COPY + va_list apc; + Perl_va_copy(ap, apc); +# ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, apc); +# else + retval = vsprintf(buffer, format, apc); +# endif +#else +# ifdef HAS_VSNPRINTF + retval = vsnprintf(buffer, len, format, ap); +# else + retval = vsprintf(buffer, format, ap); +# endif +#endif /* #ifdef NEED_VA_COPY */ + /* vsnprintf() shows failure with >= len, vsprintf() with < 0 */ + if (retval < 0 || (len > 0 && (Size_t)retval >= len)) + Perl_croak(aTHX_ "panic: my_vsnprintf buffer overflow"); + return retval; +} + void Perl_my_clearenv(pTHX) { @@ -5213,17 +5465,17 @@ Perl_my_clearenv(pTHX) (void)clearenv(); # elif defined(HAS_UNSETENV) int bsiz = 80; /* Most envvar names will be shorter than this. */ - char *buf = (char*)safesysmalloc(bsiz * sizeof(char)); + int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */ + char *buf = (char*)safesysmalloc(bufsiz); while (*environ != NULL) { char *e = strchr(*environ, '='); int l = e ? e - *environ : strlen(*environ); if (bsiz < l + 1) { (void)safesysfree(buf); - bsiz = l + 1; - buf = (char*)safesysmalloc(bsiz * sizeof(char)); + bsiz = l + 1; /* + 1 for the \0. */ + buf = (char*)safesysmalloc(bufsiz); } - strncpy(buf, *environ, l); - *(buf + l) = '\0'; + my_strlcpy(buf, *environ, l + 1); (void)unsetenv(buf); } (void)safesysfree(buf); @@ -5279,6 +5531,39 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size) } #endif +#ifndef HAS_STRLCAT +Size_t +Perl_my_strlcat(char *dst, const char *src, Size_t size) +{ + Size_t used, length, copy; + + used = strlen(dst); + length = strlen(src); + if (size > 0 && used < size - 1) { + copy = (length >= size - used) ? size - used - 1 : length; + memcpy(dst + used, src, copy); + dst[used + copy] = '\0'; + } + return used + length; +} +#endif + +#ifndef HAS_STRLCPY +Size_t +Perl_my_strlcpy(char *dst, const char *src, Size_t size) +{ + Size_t length, copy; + + length = strlen(src); + if (size > 0) { + copy = (length >= size) ? size - 1 : length; + memcpy(dst, src, copy); + dst[copy] = '\0'; + } + return length; +} +#endif + /* * Local variables: * c-indentation-style: bsd