dTHX;
#endif
Malloc_t ptr;
+
+#ifdef USE_MDH
+ if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
+ goto out_of_memory;
size += PERL_MEMORY_DEBUG_HEADER_SIZE;
+#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
}
else {
+#ifdef USE_MDH
+ out_of_memory:
+#endif
+ {
#ifndef ALWAYS_NEED_THX
- dTHX;
+ dTHX;
#endif
- if (PL_nomemok)
- ptr = NULL;
- else
- croak_no_mem();
+ if (PL_nomemok)
+ ptr = NULL;
+ else
+ croak_no_mem();
+ }
}
return ptr;
}
else {
#ifdef USE_MDH
where = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE);
+ if (size + PERL_MEMORY_DEBUG_HEADER_SIZE < size)
+ goto out_of_memory;
size += PERL_MEMORY_DEBUG_HEADER_SIZE;
{
struct perl_memory_debug_header *const header
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
if (ptr == NULL) {
+#ifdef USE_MDH
+ out_of_memory:
+#endif
+ {
#ifndef ALWAYS_NEED_THX
- dTHX;
+ dTHX;
#endif
- if (PL_nomemok)
- ptr = NULL;
- else
- croak_no_mem();
+ if (PL_nomemok)
+ ptr = NULL;
+ else
+ croak_no_mem();
+ }
}
}
return ptr;
PERL_ARGS_ASSERT_INSTR;
- /* libc prior to 4.6.27 (late 1994) did not work properly on a NULL
- * 'little' */
- if (!little)
- return (char*)big;
return strstr((char*)big, (char*)little);
}
#if defined(USE_C_BACKTRACE) && defined(USE_C_BACKTRACE_ON_ERROR)
{
char *ws;
- int wi;
+ UV wi;
/* The PERL_C_BACKTRACE_ON_WARN must be an integer of one or more. */
- if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR")) &&
- (wi = grok_atou(ws, NULL)) > 0) {
- Perl_dump_c_backtrace(aTHX_ Perl_debug_log, wi, 1);
+ if ((ws = PerlEnv_getenv("PERL_C_BACKTRACE_ON_ERROR"))
+ && grok_atoUV(ws, &wi, NULL)
+ && wi <= PERL_INT_MAX
+ ) {
+ Perl_dump_c_backtrace(aTHX_ Perl_debug_log, (int)wi, 1);
}
}
#endif
SV *exarg;
ENTER;
+ save_re_context();
if (warn) {
SAVESPTR(*hook);
*hook = NULL;
{
dVAR;
PERL_ARGS_ASSERT_VWARNER;
- if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) {
+ if (
+ (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) &&
+ !(PL_in_eval & EVAL_KEEPERR)
+ ) {
SV * const msv = vmess(pat, args);
if (PL_parser && PL_parser->error_count) {
Perl_ckwarn(pTHX_ U32 w)
{
/* If lexical warnings have not been set, use $^W. */
- if (isLEXWARN_off) {
- /* TODO: Hardcoding this here sucks, see the commit that added this */
- if (w == WARN_VOID_UNUSUAL)
- return FALSE;
- else
- return PL_dowarn & G_WARN_ON;
- }
+ if (isLEXWARN_off)
+ return PL_dowarn & G_WARN_ON;
return ckwarn_common(w);
}
Perl_ckwarn_d(pTHX_ U32 w)
{
/* If lexical warnings have not been set then default classes warn. */
- if (isLEXWARN_off) {
- /* TODO: Hardcoding this here sucks, see the commit that added this */
- if (w == WARN_VOID_UNUSUAL)
- return FALSE;
- else
- return TRUE;
- }
+ if (isLEXWARN_off)
+ return TRUE;
return ckwarn_common(w);
}
static bool
S_ckwarn_common(pTHX_ U32 w)
{
- if (PL_curcop->cop_warnings == pWARN_ALL) {
- /* TODO: Hardcoding this here sucks, see the commit that added this */
- if (w == WARN_VOID_UNUSUAL)
- return FALSE;
- else
- return TRUE;
- }
+ if (PL_curcop->cop_warnings == pWARN_ALL)
+ return TRUE;
if (PL_curcop->cop_warnings == pWARN_NONE)
return FALSE;
*statusp = SvIVX(sv);
/* 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()
+ aggregate does more work, because 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. */
/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
* rewritten again by dougm, optimized for use with xs TARG, and to prefer
* getcwd(3) if available
- * Comments from the orignal:
+ * Comments from the original:
* This is a faster version of getcwd. It's also more dangerous
* because you might chdir out of a directory that you can't chdir
* back into. */
if (*p) {
if (isDIGIT(*p)) {
const char* endptr;
- opt = (U32) grok_atou(p, &endptr);
- p = endptr;
- if (*p && *p != '\n' && *p != '\r') {
- if(isSPACE(*p)) goto the_end_of_the_opts_parser;
- else
- Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
- }
- }
- else {
+ UV uv;
+ if (grok_atoUV(p, &uv, &endptr) && uv <= U32_MAX) {
+ opt = (U32)uv;
+ p = endptr;
+ if (p && *p && *p != '\n' && *p != '\r') {
+ if (isSPACE(*p))
+ goto the_end_of_the_opts_parser;
+ else
+ Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
+ }
+ }
+ }
+ else {
for (; *p; p++) {
switch (*p) {
case PERL_UNICODE_STDIN:
int fd;
#endif
U32 u;
-#ifdef VMS
- /* when[] = (low 32 bits, high 32 bits) of time since epoch
- * in 100-ns units, typically incremented ever 10 ms. */
- unsigned int when[2];
-#else
-# ifdef HAS_GETTIMEOFDAY
+#ifdef HAS_GETTIMEOFDAY
struct timeval when;
-# else
+#else
Time_t when;
-# endif
#endif
/* This test is an escape hatch, this symbol isn't set by Configure. */
}
#endif
-#ifdef VMS
- _ckvmssts(sys$gettim(when));
- u = (U32)SEED_C1 * when[0] + (U32)SEED_C2 * when[1];
-#else
-# ifdef HAS_GETTIMEOFDAY
+#ifdef HAS_GETTIMEOFDAY
PerlProc_gettimeofday(&when,NULL);
u = (U32)SEED_C1 * when.tv_sec + (U32)SEED_C2 * when.tv_usec;
-# else
+#else
(void)time(&when);
u = (U32)SEED_C1 * when;
-# endif
#endif
u += SEED_C3 * (U32)PerlProc_getpid();
u += SEED_C4 * (U32)PTR2UV(PL_stack_sp);
#ifdef PERL_MEM_LOG
-/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the
+/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including
* the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also
* given, and you supply your own implementation.
*
* The default implementation reads a single env var, PERL_MEM_LOG,
* expecting one or more of the following:
*
- * \d+ - fd fd to write to : must be 1st (grok_atou)
+ * \d+ - fd fd to write to : must be 1st (grok_atoUV)
* 'm' - memlog was PERL_MEM_LOG=1
* 's' - svlog was PERL_SV_LOG=1
* 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1
{
STRLEN len;
const char* endptr;
- int fd = grok_atou(pmlenv, &endptr); /* Ignore endptr. */
- if (!fd)
+ int fd;
+ UV uv;
+ if (grok_atoUV(pmlenv, &uv, &endptr) /* Ignore endptr. */
+ && uv && uv <= PERL_INT_MAX
+ ) {
+ fd = (int)uv;
+ } else {
fd = PERL_MEM_LOG_FD;
+ }
if (strchr(pmlenv, 't')) {
len = my_snprintf(buf, sizeof(buf),
return dir->dd_fd;
#else
Perl_croak_nocontext(PL_no_func, "dirfd");
- NOT_REACHED; /* NOT REACHED */
+ NOT_REACHED; /* NOTREACHED */
return 0;
#endif
}
const char* source_name_end;
const char* source_line_end;
const char* close_paren;
+ UV uv;
+
/* Skip trailing whitespace. */
while (p > start && isspace(*p)) p--;
/* Now we should be at the close paren. */
return NULL;
p++;
*source_name_size = source_name_end - p;
- *source_line = grok_atou(source_number_start, &source_line_end);
- if (source_line_end != close_paren)
- return NULL;
- return p;
+ if (grok_atoUV(source_number_start, &uv, &source_line_end)
+ && source_line_end == close_paren
+ && uv <= MAX_STRLEN
+ ) {
+ *source_line = (STRLEN)uv;
+ return p;
+ }
+ return NULL;
}
/* Given a raw frame, read a pipe from the symbolicator (that's the
#endif /* #ifdef USE_C_BACKTRACE */
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff