X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f6bab5f637fea85f01e1e1f1882ace0bd404db4c..5478a2b983aa7a04b93cfaf83bb9805713bf2d3f:/util.c

diff --git a/util.c b/util.c
index 08f6abc..607f480 100644
--- a/util.c
+++ b/util.c
@@ -128,7 +128,12 @@ Perl_safesysmalloc(MEM_SIZE size)
     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);
@@ -175,13 +180,18 @@ Perl_safesysmalloc(MEM_SIZE 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;
 }
@@ -214,6 +224,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
     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
@@ -292,13 +304,18 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 	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;
@@ -539,10 +556,6 @@ Perl_instr(const char *big, const char *little)
 
     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);
 }
 
@@ -1358,11 +1371,13 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume)
 #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
@@ -1514,6 +1529,7 @@ S_invoke_exception_hook(pTHX_ SV *ex, bool warn)
 	SV *exarg;
 
 	ENTER;
+	save_re_context();
 	if (warn) {
 	    SAVESPTR(*hook);
 	    *hook = NULL;
@@ -1922,7 +1938,10 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
 {
     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) {
@@ -4403,15 +4422,19 @@ Perl_parse_unicode_opts(pTHX_ const char **popt)
   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:
@@ -4492,16 +4515,10 @@ Perl_seed(pTHX)
     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. */
@@ -4523,17 +4540,12 @@ Perl_seed(pTHX)
     }
 #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);
@@ -4712,14 +4724,14 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp)
 
 #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
@@ -4788,9 +4800,15 @@ S_mem_log_common(enum mem_log_type mlt, const UV n,
 	{
 	    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),
@@ -5676,7 +5694,7 @@ Perl_my_dirfd(DIR * dir) {
     return dir->dd_fd;
 #else
     Perl_croak_nocontext(PL_no_func, "dirfd");
-    NOT_REACHED; /* NOT REACHED */
+    NOT_REACHED; /* NOTREACHED */
     return 0;
 #endif 
 }
@@ -5991,6 +6009,8 @@ static const char* atos_parse(const char* p,
     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. */
@@ -6017,10 +6037,14 @@ static const char* atos_parse(const char* p,
         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
@@ -6461,11 +6485,5 @@ Perl_dump_c_backtrace(pTHX_ PerlIO* fp, int depth, int skip)
 #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:
  */