begin filling the 5.16.0 delta from 5.15.7

[perl5.git] / util.c

diff --git a/util.c b/util.c
index 9d7683d..1ff5913 100644 (file)
--- a/util.c
+++ b/util.c
@@ -95,7 +95,7 @@ Perl_safesysmalloc(MEM_SIZE size)
 #endif
 #ifdef DEBUGGING
     if ((SSize_t)size < 0)
-       Perl_croak_nocontext("panic: malloc");
+       Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
 #endif
     ptr = (Malloc_t)PerlMem_malloc(size?size:1);       /* malloc(0) is NASTY on our system */
     PERL_ALLOC_CHECK(ptr);
@@ -172,7 +172,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
            = (struct perl_memory_debug_header *)where;
 
        if (header->interpreter != aTHX) {
-           Perl_croak_nocontext("panic: realloc from wrong pool");
+           Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
+                                header->interpreter, aTHX);
        }
        assert(header->next->prev == header);
        assert(header->prev->next == header);
@@ -188,7 +189,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
 #endif
 #ifdef DEBUGGING
     if ((SSize_t)size < 0)
-       Perl_croak_nocontext("panic: realloc");
+       Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
 #endif
     ptr = (Malloc_t)PerlMem_realloc(where,size);
     PERL_ALLOC_CHECK(ptr);
@@ -258,14 +259,19 @@ Perl_safesysfree(Malloc_t where)
                = (struct perl_memory_debug_header *)where;
 
            if (header->interpreter != aTHX) {
-               Perl_croak_nocontext("panic: free from wrong pool");
+               Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
+                                    header->interpreter, aTHX);
            }
            if (!header->prev) {
                Perl_croak_nocontext("panic: duplicate free");
            }
-           if (!(header->next) || header->next->prev != header
-               || header->prev->next != header) {
-               Perl_croak_nocontext("panic: bad free");
+           if (!(header->next))
+               Perl_croak_nocontext("panic: bad free, header->next==NULL");
+           if (header->next->prev != header || header->prev->next != header) {
+               Perl_croak_nocontext("panic: bad free, ->next->prev=%p, "
+                                    "header=%p, ->prev->next=%p",
+                                    header->next->prev, header,
+                                    header->prev->next);
            }
            /* Unlink us from the chain.  */
            header->next->prev = header->prev;
@@ -317,7 +323,8 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
 #endif /* HAS_64K_LIMIT */
 #ifdef DEBUGGING
     if ((SSize_t)size < 0 || (SSize_t)count < 0)
-       Perl_croak_nocontext("panic: calloc");
+       Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
+                            (UV)size, (UV)count);
 #endif
 #ifdef PERL_TRACK_MEMPOOL
     /* Have to use malloc() because we've added some space for our tracking
@@ -460,7 +467,8 @@ Perl_instr(register const char *big, register const char *little)
     return NULL;
 }
 
-/* same as instr but allow embedded nulls */
+/* same as instr but allow embedded nulls.  The end pointers point to 1 beyond
+ * the final character desired to be checked */
 
 char *
 Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend)
@@ -2735,7 +2743,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
            int pid2, status;
            PerlLIO_close(p[This]);
            if (n != sizeof(int))
-               Perl_croak(aTHX_ "panic: kid popen errno read");
+               Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
            do {
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);
@@ -2849,9 +2857,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
       default, binary, low-level mode; see PerlIOBuf_open(). */
    PerlLIO_setmode((*mode == 'r'), O_BINARY);
 #endif 
-#ifdef THREADS_HAVE_PIDS
-       PL_ppid = (IV)getppid();
-#endif
        PL_forkprocess = 0;
 #ifdef PERL_USES_PL_PIDSTATUS
        hv_clear(PL_pidstatus); /* we have no children */
@@ -2894,7 +2899,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
            int pid2, status;
            PerlLIO_close(p[This]);
            if (n != sizeof(int))
-               Perl_croak(aTHX_ "panic: kid popen errno read");
+               Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n);
            do {
                pid2 = wait4pid(pid, &status, 0);
            } while (pid2 == -1 && errno == EINTR);
@@ -3705,8 +3710,9 @@ Perl_get_context(void)
 #if defined(USE_ITHREADS)
 #  ifdef OLD_PTHREADS_API
     pthread_addr_t t;
-    if (pthread_getspecific(PL_thr_key, &t))
-       Perl_croak_nocontext("panic: pthread_getspecific");
+    int error = pthread_getspecific(PL_thr_key, &t)
+    if (error)
+       Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
     return (void*)t;
 #  else
 #    ifdef I_MACH_CTHREADS
@@ -3729,8 +3735,11 @@ Perl_set_context(void *t)
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
 #  else
-    if (pthread_setspecific(PL_thr_key, t))
-       Perl_croak_nocontext("panic: pthread_setspecific");
+    {
+       const int error = pthread_setspecific(PL_thr_key, t);
+       if (error)
+           Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
+    }
 #  endif
 #else
     PERL_UNUSED_ARG(t);
@@ -3908,26 +3917,18 @@ Perl_report_evil_fh(pTHX_ const GV *gv)
            (const char *)
            (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET)
             ? "socket" : "filehandle");
-       if (name && SvPOK(name) && *SvPV_nolen(name)) {
-           Perl_warner(aTHX_ packWARN(warn_type),
-                       "%s%s on %s %s %"SVf, func, pars, vile, type, SVfARG(name));
-           if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
-               Perl_warner(
-                           aTHX_ packWARN(warn_type),
-                           "\t(Are you trying to call %s%s on dirhandle %"SVf"?)\n",
-                           func, pars, SVfARG(name)
-                           );
-       }
-       else {
-           Perl_warner(aTHX_ packWARN(warn_type),
-                       "%s%s on %s %s", func, pars, vile, type);
-           if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
+       const bool have_name = name && SvPOK(name) && *SvPV_nolen(name);
+       Perl_warner(aTHX_ packWARN(warn_type),
+                  "%s%s on %s %s%s%"SVf, func, pars, vile, type,
+                   have_name ? " " : "",
+                   SVfARG(have_name ? name : &PL_sv_no));
+       if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP))
                Perl_warner(
                            aTHX_ packWARN(warn_type),
-                           "\t(Are you trying to call %s%s on dirhandle?)\n",
-                           func, pars
+                       "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n",
+                       func, pars, have_name ? " " : "",
+                       SVfARG(have_name ? name : &PL_sv_no)
                            );
-       }
     }
 }
 
@@ -4545,7 +4546,7 @@ dotted_decimal_version:
 
        /* and we never support negative versions */
        if ( *d == '-') {
-               BADVERSION(s,errstr,"Invalid version format (negative version number)");                
+           BADVERSION(s,errstr,"Invalid version format (negative version number)");
        }
 
        /* consume all of the integer part */
@@ -5859,6 +5860,7 @@ Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv)
     else
         return (stashpv == name
                     || strEQ(stashpv, name));
+    /*NOTREACHED*/
     return FALSE;
 }
 #endif