{
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;
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);
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 = specialWARN(buffer) ? PerlMemShared_malloc(len_wanted)
: PerlMemShared_realloc(buffer, len_wanted);
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<max; j++) { /* copy environment */
const int len = strlen(environ[j]);
I32
Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */
{
- I32 i;
+ I32 retries = 0;
- for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
- return i ? 0 : -1;
+ while (PerlLIO_unlink(f) >= 0)
+ retries++;
+ return retries ? 0 : -1;
}
#endif
if (len == 2 && tmpbuf[0] == '.')
seen_dot = 1;
#endif
+#ifdef HAS_STRLCAT
+ (void)strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len);
+#else
/* FIXME? Convert to memcpy by storing previous strlen(scriptname)
*/
(void)strcpy(tmpbuf + len, scriptname);
+#endif /* #ifdef HAS_STRLCAT */
#endif /* !VMS */
#ifdef SEARCH_EXTS
/* Append revision */
av_push(av, newSViv(rev));
- if ( *pos == '.' && isDIGIT(pos[1]) )
+ if ( *pos == '.' )
s = ++pos;
else if ( *pos == '_' && isDIGIT(pos[1]) )
s = ++pos;
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;
}
#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);
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;
}
{
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;
}
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);
}
UV myseed = 0;
if (s)
- while (isSPACE(*s)) s++;
+ while (isSPACE(*s))
+ s++;
if (s && isDIGIT(*s))
myseed = (UV)Atoul(s);
else
#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,
+ PERL_MEM_LOG_SPRINTF_BUF_SIZE,
+# 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;
}
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,
+ PERL_MEM_LOG_SPRINTF_BUF_SIZE,
+# 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;
}
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,
+ PERL_MEM_LOG_SPRINTF_BUF_SIZE,
+# 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;
}
}
#endif
+/*
+=for apidoc my_snprintf
+
+The C library C<snprintf> functionality, if available and
+standards-compliant (uses C<vsnprintf>, actually). However, if the
+C<vsnprintf> is not available, will unfortunately use the unsafe
+C<vsprintf> which can overrun the buffer (there is an overrun check,
+but that may be too late). Consider using C<sv_vcatpvf> instead, or
+getting C<vsnprintf>.
+
+=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<vsnprintf> if available and standards-compliant.
+However, if if the C<vsnprintf> is not available, will unfortunately
+use the unsafe C<vsprintf> which can overrun the buffer (there is an
+overrun check, but that may be too late). Consider using
+C<sv_vcatpvf> instead, or getting C<vsnprintf>.
+
+=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)
{