sv_setuv_mg is so rarely called that the IV optimisation test is not

[perl5.git] / util.c

diff --git a/util.c b/util.c
index e7cc539..6ef7a01 100644 (file)
--- a/util.c
+++ b/util.c
@@ -152,7 +152,6 @@ Perl_safesysfree(Malloc_t where)
 #endif
     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
     if (where) {
-       /*SUPPRESS 701*/
        PerlMem_free(where);
     }
 }
@@ -584,7 +583,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit
            register I32 tmp;
 
          top2:
-           /*SUPPRESS 560*/
            if ((tmp = table[*s])) {
                if ((s += tmp) < bigend)
                    goto top2;
@@ -767,7 +765,7 @@ Perl_savepv(pTHX_ const char *pv)
        char *newaddr;
        const STRLEN pvlen = strlen(pv)+1;
        New(902,newaddr,pvlen,char);
-       return strcpy(newaddr,pv);
+       return memcpy(newaddr,pv,pvlen);
     }
 
 }
@@ -814,16 +812,18 @@ char *
 Perl_savesharedpv(pTHX_ const char *pv)
 {
     register char *newaddr;
+    STRLEN pvlen;
     if (!pv)
        return Nullch;
 
-    newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1);
+    pvlen = strlen(pv)+1;
+    newaddr = (char*)PerlMemShared_malloc(pvlen);
     if (!newaddr) {
        PerlLIO_write(PerlIO_fileno(Perl_error_log),
                      PL_no_mem, strlen(PL_no_mem));
        my_exit(1);
     }
-    return strcpy(newaddr,pv);
+    return memcpy(newaddr,pv,pvlen);
 }
 
 /*
@@ -952,7 +952,7 @@ Perl_mess(pTHX_ const char *pat, ...)
 }
 
 STATIC COP*
-S_closest_cop(pTHX_ COP *cop, OP *o)
+S_closest_cop(pTHX_ COP *cop, const OP *o)
 {
     /* Look for PL_op starting from o.  cop is the last COP we've seen. */
 
@@ -979,7 +979,7 @@ S_closest_cop(pTHX_ COP *cop, OP *o)
 
     /* Nothing found. */
 
-    return 0;
+    return Null(COP *);
 }
 
 SV *
@@ -1053,9 +1053,9 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen)
     else {
 #ifdef USE_SFIO
        /* SFIO can really mess with your errno */
-       int e = errno;
+       const int e = errno;
 #endif
-       PerlIO *serr = Perl_error_log;
+       PerlIO * const serr = Perl_error_log;
 
        PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
        (void)PerlIO_flush(serr);
@@ -1256,21 +1256,18 @@ void
 Perl_vwarn(pTHX_ const char* pat, va_list *args)
 {
     dVAR;
-    const char *message;
-    HV *stash;
-    GV *gv;
-    CV *cv;
-    SV *msv;
     STRLEN msglen;
-    I32 utf8 = 0;
-
-    msv = vmess(pat, args);
-    utf8 = SvUTF8(msv);
-    message = SvPV_const(msv, msglen);
+    SV * const msv = vmess(pat, args);
+    const I32 utf8 = SvUTF8(msv);
+    const char * const message = SvPV_const(msv, msglen);
 
     if (PL_warnhook) {
        /* sv_2cv might call Perl_warn() */
-       SV *oldwarnhook = PL_warnhook;
+       SV * const oldwarnhook = PL_warnhook;
+       CV * cv;
+       HV * stash;
+       GV * gv;
+
        ENTER;
        SAVESPTR(PL_warnhook);
        PL_warnhook = Nullsv;
@@ -1379,6 +1376,58 @@ Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
     }
 }
 
+/* implements the ckWARN? macros */
+
+bool
+Perl_ckwarn(pTHX_ U32 w)
+{
+    return
+       (
+              isLEXWARN_on
+           && PL_curcop->cop_warnings != pWARN_NONE
+           && (
+                  PL_curcop->cop_warnings == pWARN_ALL
+               || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
+               || (unpackWARN2(w) &&
+                    isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
+               || (unpackWARN3(w) &&
+                    isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
+               || (unpackWARN4(w) &&
+                    isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
+               )
+       )
+       ||
+       (
+           isLEXWARN_off && PL_dowarn & G_WARN_ON
+       )
+       ;
+}
+
+/* implements the ckWARN?_d macro */
+
+bool
+Perl_ckwarn_d(pTHX_ U32 w)
+{
+    return
+          isLEXWARN_off
+       || PL_curcop->cop_warnings == pWARN_ALL
+       || (
+             PL_curcop->cop_warnings != pWARN_NONE 
+          && (
+                  isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))
+             || (unpackWARN2(w) &&
+                  isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w)))
+             || (unpackWARN3(w) &&
+                  isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w)))
+             || (unpackWARN4(w) &&
+                  isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w)))
+             )
+          )
+       ;
+}
+
+
+
 /* since we've already done strlen() for both nam and val
  * we can use that info to make things faster than
  * sprintf(s, "%s=%s", nam, val)
@@ -1412,7 +1461,6 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
        I32 max;
        char **tmpenv;
 
-       /*SUPPRESS 530*/
        for (max = i; environ[max]; max++) ;
        tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
        for (j=0; j<max; j++) {         /* copy environment */
@@ -1449,7 +1497,8 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
     setenv(nam, val, 1);
 #   else
     char *new_env;
-    int nlen = strlen(nam), vlen;
+    const int nlen = strlen(nam);
+    int vlen;
     if (!val) {
        val = "";
     }
@@ -1491,7 +1540,8 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val)
 I32
 Perl_setenv_getix(pTHX_ const char *nam)
 {
-    register I32 i, len = strlen(nam);
+    register I32 i;
+    const register I32 len = strlen(nam);
 
     for (i = 0; environ[i]; i++) {
        if (
@@ -2151,7 +2201,6 @@ Perl_my_popen(pTHX_ char *cmd, char *mode)
            PerlProc__exit(1);
        }
 #endif /* defined OS2 */
-       /*SUPPRESS 560*/
        if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
            SvREADONLY_off(GvSV(tmpgv));
            sv_setiv(GvSV(tmpgv), PerlProc_getpid());
@@ -2632,7 +2681,6 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
 #endif /* !DOSISH || OS2 || WIN32 || NETWARE */
 
 void
-/*SUPPRESS 590*/
 Perl_pidgone(pTHX_ Pid_t pid, int status)
 {
     register SV *sv;
@@ -2763,7 +2811,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **searc
     int extidx = 0, i = 0;
     const char *curext = Nullch;
 #else
-    (void)search_ext;
+    PERL_UNUSED_ARG(search_ext);
 #  define MAX_EXT_LEN 0
 #endif
 
@@ -2846,6 +2894,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **searc
                len = strlen(scriptname);
                if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
                    break;
+               /* FIXME? Convert to memcpy  */
                cur = strcpy(tmpbuf, scriptname);
            }
        } while (extidx >= 0 && ext[extidx]     /* try an extension? */
@@ -2900,15 +2949,17 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **searc
                tmpbuf[len++] = ':';
 #else
            if (len
-#if defined(atarist) || defined(__MINT__) || defined(DOSISH)
+#  if defined(atarist) || defined(__MINT__) || defined(DOSISH)
                && tmpbuf[len - 1] != '/'
                && tmpbuf[len - 1] != '\\'
-#endif
+#  endif
               )
                tmpbuf[len++] = '/';
            if (len == 2 && tmpbuf[0] == '.')
                seen_dot = 1;
 #endif
+           /* FIXME? Convert to memcpy by storing previous strlen(scriptname)
+            */
            (void)strcpy(tmpbuf + len, scriptname);
 #endif  /* !VMS */
 
@@ -2960,8 +3011,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **searc
            }
            scriptname = Nullch;
        }
-       if (xfailed)
-           Safefree(xfailed);
+       Safefree(xfailed);
        scriptname = xfound;
     }
     return (scriptname ? savepv(scriptname) : Nullch);
@@ -2994,7 +3044,7 @@ Perl_get_context(void)
 void
 Perl_set_context(void *t)
 {
-   dVAR;
+    dVAR;
 #if defined(USE_ITHREADS)
 #  ifdef I_MACH_CTHREADS
     cthread_set_data(cthread_self(), t);
@@ -3003,7 +3053,7 @@ Perl_set_context(void *t)
        Perl_croak_nocontext("panic: pthread_setspecific");
 #  endif
 #else
-    (void)t;
+    PERL_UNUSED_ARG(t);
 #endif
 }
 
@@ -3052,7 +3102,7 @@ Perl_get_ppaddr(pTHX)
 char *
 Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len)
 {
-    char *env_trans = PerlEnv_getenv(env_elem);
+    char * const env_trans = PerlEnv_getenv(env_elem);
     if (env_trans)
        *len = strlen(env_trans);
     return env_trans;
@@ -3346,11 +3396,13 @@ Perl_init_tm(pTHX_ struct tm *ptm)      /* see mktime, strftime and asctime */
 {
 #ifdef HAS_TM_TM_ZONE
     Time_t now;
-    struct tm* my_tm;
+    const struct tm* my_tm;
     (void)time(&now);
     my_tm = localtime(&now);
     if (my_tm)
         Copy(my_tm, ptm, 1, struct tm);
+#else
+    PERL_UNUSED_ARG(ptm);
 #endif
 }
 
@@ -3837,6 +3889,9 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
     AV *av = newAV();
     SV* hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
     (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+#ifndef NODEFAULT_SHAREKEYS
+    HvSHAREKEYS_on(hv);         /* key-sharing on by default */
+#endif
 
     if (*s == 'v') {
        s++;  /* get past 'v' */
@@ -3988,11 +4043,14 @@ Perl_new_version(pTHX_ SV *ver)
     if ( sv_derived_from(ver,"version") ) /* can just copy directly */
     {
        I32 key;
-       AV *av = newAV();
+       AV * const av = newAV();
        AV *sav;
        /* This will get reblessed later if a derived class*/
-       SV* hv = newSVrv(rv, "version"); 
+       SV*  const hv = newSVrv(rv, "version"); 
        (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
+#ifndef NODEFAULT_SHAREKEYS
+       HvSHAREKEYS_on(hv);         /* key-sharing on by default */
+#endif
 
        if ( SvROK(ver) )
            ver = SvRV(ver);
@@ -4006,7 +4064,7 @@ Perl_new_version(pTHX_ SV *ver)
        
        if ( hv_exists((HV*)ver, "width", 5 ) )
        {
-           I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
+           const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE));
            hv_store((HV *)hv, "width", 5, newSViv(width), 0);
        }
 
@@ -4025,8 +4083,9 @@ Perl_new_version(pTHX_ SV *ver)
     if ( SvVOK(ver) ) { /* already a v-string */
        char *version;
        MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring);
-       version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
-       sv_setpv(rv,version);
+       const STRLEN len = mg->mg_len;
+       version = savepvn( (const char*)mg->mg_ptr, len);
+       sv_setpvn(rv,version,len);
        Safefree(version);
     }
     else {
@@ -4100,7 +4159,7 @@ Perl_vnumify(pTHX_ SV *vs)
     I32 i, len, digit;
     int width;
     bool alpha = FALSE;
-    SV *sv = newSV(0);
+    SV * const sv = newSV(0);
     AV *av;
     if ( SvROK(vs) )
        vs = SvRV(vs);
@@ -4116,7 +4175,7 @@ Perl_vnumify(pTHX_ SV *vs)
 
     /* attempt to retrieve the version array */
     if ( !(av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE) ) ) {
-       Perl_sv_catpv(aTHX_ sv,"0");
+       sv_catpvn(sv,"0",1);
        return sv;
     }
 
@@ -4133,8 +4192,8 @@ Perl_vnumify(pTHX_ SV *vs)
     {
        digit = SvIV(*av_fetch(av, i, 0));
        if ( width < 3 ) {
-           int denom = (int)pow(10,(3-width));
-           div_t term = div((int)PERL_ABS(digit),denom);
+           const int denom = (int)pow(10,(3-width));
+           const div_t term = div((int)PERL_ABS(digit),denom);
            Perl_sv_catpvf(aTHX_ sv,"%0*d_%d", width, term.quot, term.rem);
        }
        else {
@@ -4604,7 +4663,7 @@ some level of strict-ness.
 void
 Perl_sv_nosharing(pTHX_ SV *sv)
 {
-    (void)sv;
+    PERL_UNUSED_ARG(sv);
 }
 
 /*
@@ -4620,7 +4679,7 @@ some level of strict-ness.
 void
 Perl_sv_nolocking(pTHX_ SV *sv)
 {
-    (void)sv;
+    PERL_UNUSED_ARG(sv);
 }
 
 
@@ -4637,7 +4696,7 @@ some level of strict-ness.
 void
 Perl_sv_nounlocking(pTHX_ SV *sv)
 {
-    (void)sv;
+    PERL_UNUSED_ARG(sv);
 }
 
 U32