Re: [PATCH] add pTHX_ parameter to new_warnings_bitfield()

[perl5.git] / util.c

diff --git a/util.c b/util.c
index 420232c..32aac26 100644 (file)
--- 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,6 +340,7 @@ 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)
@@ -355,6 +370,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 +402,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 +431,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 +833,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 +849,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,6 +877,7 @@ be freed with the C<Safefree()> function.
 char *
 Perl_savepv(pTHX_ const char *pv)
 {
+    PERL_UNUSED_CONTEXT;
     if (!pv)
        return NULL;
     else {
@@ -863,7 +886,6 @@ Perl_savepv(pTHX_ const char *pv)
        Newx(newaddr,pvlen,char);
        return memcpy(newaddr,pv,pvlen);
     }
-
 }
 
 /* same thing but with a known length */
@@ -883,6 +905,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() */
@@ -1017,7 +1040,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 +1069,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 +1079,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 +1099,7 @@ S_closest_cop(pTHX_ COP *cop, const OP *o)
 
     /* Nothing found. */
 
-    return Null(COP *);
+    return NULL;
 }
 
 SV *
@@ -1084,11 +1107,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 +1118,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 +1128,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;
 }
@@ -1508,7 +1531,18 @@ 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;
 
+    buffer = 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
@@ -1645,6 +1679,7 @@ Perl_setenv_getix(pTHX_ const char *nam)
 {
     register I32 i;
     register const I32 len = strlen(nam);
+    PERL_UNUSED_CONTEXT;
 
     for (i = 0; environ[i]; i++) {
        if (
@@ -2109,7 +2144,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 +2156,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);
     }
@@ -2210,7 +2245,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 +2284,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 +2297,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 +2353,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
     }
@@ -2362,7 +2397,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 +2577,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 +2804,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 +2883,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;
@@ -3188,32 +3225,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 +3263,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 +3275,7 @@ MGVTBL*
 Perl_get_vtbl(pTHX_ int vtbl_id)
 {
     const MGVTBL* result;
+    PERL_UNUSED_CONTEXT;
 
     switch(vtbl_id) {
     case want_vtbl_sv:
@@ -3267,9 +3311,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 +3368,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id)
        result = &PL_vtbl_utf8;
        break;
     default:
-       result = Null(MGVTBL*);
+       result = NULL;
        break;
     }
     return (MGVTBL*)result;
@@ -3389,6 +3430,7 @@ Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
     const char * const func =
        op == OP_READLINE   ? "readline"  :     /* "<HANDLE>" not nice */
        op == OP_LEAVEWRITE ? "write" :         /* "write exit" not nice */
+       op < 0              ? "" :              /* handle phoney cases */
        PL_op_desc[op];
     const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
     const char * const type = OP_IS_SOCKET(op)
@@ -3534,6 +3576,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)
@@ -4843,6 +4886,7 @@ potentially warn under some level of strict-ness.
 void
 Perl_sv_nosharing(pTHX_ SV *sv)
 {
+    PERL_UNUSED_CONTEXT;
     PERL_UNUSED_ARG(sv);
 }
 
@@ -5026,6 +5070,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;