Merge common code. Reduces object size by 1K on x86, 6K on PPC

[perl5.git] / perl.c

diff --git a/perl.c b/perl.c
index 86b7e2a..1e39037 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -186,7 +186,7 @@ perl_alloc(void)
     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
 
     S_init_tls_and_interp(my_perl);
-    return ZeroD(my_perl, 1, PerlInterpreter);
+    return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
 }
 #endif /* PERL_IMPLICIT_SYS */
 
@@ -359,7 +359,7 @@ perl_destruct(pTHXx)
     {
        char *s;
        if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
-           int i = atoi(s);
+            const int i = atoi(s);
            if (destruct_level < i)
                destruct_level = i;
        }
@@ -827,8 +827,16 @@ perl_destruct(pTHXx)
                if (SvTYPE(sv) != SVTYPEMASK) {
                    PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
                        " flags=0x08%"UVxf
-                       " refcnt=%"UVuf pTHX__FORMAT "\n",
-                       sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE);
+                       " refcnt=%"UVuf pTHX__FORMAT "\n"
+                       "\tallocated at %s:%d %s %s%s\n",
+                       sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
+                       sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
+                       sv->sv_debug_line,
+                       sv->sv_debug_inpad ? "for" : "by",
+                       sv->sv_debug_optype ?
+                           PL_op_name[sv->sv_debug_optype]: "(none)",
+                       sv->sv_debug_cloned ? " (cloned)" : ""
+                   );
                }
            }
        }
@@ -980,7 +988,7 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
    bytes of stack longer than necessary
  */
 STATIC void
-S_procself_val(pTHX_ SV *sv, char *arg0)
+S_procself_val(pTHX_ SV *sv, const char *arg0)
 {
     char buf[MAXPATHLEN];
     int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
@@ -1081,7 +1089,7 @@ setuid perl scripts securely.\n");
         * the area we are able to modify is limited to the size of
         * the original argv[0].  (See below for 'contiguous', though.)
         * --jhi */
-        char *s = NULL;
+        const char *s = NULL;
         int i;
         UV mask =
           ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
@@ -1223,12 +1231,12 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 {
     int argc = PL_origargc;
     char **argv = PL_origargv;
-    char *scriptname = NULL;
+    const char *scriptname = NULL;
     VOL bool dosearch = FALSE;
-    char *validarg = "";
+    const char *validarg = "";
     register SV *sv;
     register char *s;
-    char *cddir = Nullch;
+    const char *cddir = Nullch;
     bool minus_f = FALSE;
 
     PL_fdscript = -1;
@@ -1412,8 +1420,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
                 while (SvCUR(PL_Sv) > opts+76) {
                     /* find last space after "options: " and before col 76 */
 
-                    char *space, *pv = SvPV_nolen(PL_Sv);
-                    char c = pv[opts+76];
+                    const char *space;
+                    char *pv = SvPV_nolen(PL_Sv);
+                    const char c = pv[opts+76];
                     pv[opts+76] = '\0';
                     space = strrchr(pv+opts+26, ' ');
                     pv[opts+76] = c;
@@ -1482,11 +1491,11 @@ print \"  \\@INC:\\n    @INC\\n\";");
            }
            /* catch use of gnu style long options */
            if (strEQ(s, "version")) {
-               s = "v";
+               s = (char *)"v";
                goto reswitch;
            }
            if (strEQ(s, "help")) {
-               s = "h";
+               s = (char *)"h";
                goto reswitch;
            }
            s--;
@@ -1503,7 +1512,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
 #endif
        (s = PerlEnv_getenv("PERL5OPT")))
     {
-       char *popt = s;
+       const char *popt = s;
        while (isSPACE(*s))
            s++;
        if (*s == '-' && *(s+1) == 'T') {
@@ -1611,7 +1620,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
     if (PL_doextract) {
 #endif
        find_beginning();
-       if (cddir && PerlDir_chdir(cddir) < 0)
+       if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
            Perl_croak(aTHX_ "Can't chdir to %s",cddir);
 
     }
@@ -1819,7 +1828,7 @@ perl_run(pTHXx)
 }
 
 
-STATIC void *
+STATIC void
 S_run_body(pTHX_ I32 oldscope)
 {
     DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
@@ -1863,7 +1872,6 @@ S_run_body(pTHX_ I32 oldscope)
 
     my_exit(0);
     /* NOTREACHED */
-    return NULL;
 }
 
 /*
@@ -2191,7 +2199,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
 }
 
 STATIC void
-S_call_body(pTHX_ OP *myop, int is_eval)
+S_call_body(pTHX_ const OP *myop, bool is_eval)
 {
     if (PL_op == myop) {
        if (is_eval)
@@ -2360,7 +2368,7 @@ Perl_require_pv(pTHX_ const char *pv)
 }
 
 void
-Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
+Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
 {
     register GV *gv;
 
@@ -2369,7 +2377,7 @@ Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
 }
 
 STATIC void
-S_usage(pTHX_ char *name)              /* XXX move this out into a module ? */
+S_usage(pTHX_ const char *name)                /* XXX move this out into a module ? */
 {
     /* This message really ought to be max 23 lines.
      * Removed -h because the user already knows that option. Others? */
@@ -2406,7 +2414,7 @@ S_usage(pTHX_ char *name)         /* XXX move this out into a module ? */
 "\n",
 NULL
 };
-    char **p = usage_msg;
+    const char **p = usage_msg;
 
     PerlIO_printf(PerlIO_stdout(),
                  "\nUsage: %s [switches] [--] [programfile] [arguments]",
@@ -2420,7 +2428,7 @@ NULL
 
 #ifdef DEBUGGING
 int
-Perl_get_debug_opts(pTHX_ char **s, bool givehelp)
+Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
 {
     static const char *usage_msgd[] = {
       " Debugging flag values: (see also -d)",
@@ -2455,7 +2463,7 @@ Perl_get_debug_opts(pTHX_ char **s, bool givehelp)
        static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
 
        for (; isALNUM(**s); (*s)++) {
-           char *d = strchr(debopts,**s);
+           const char *d = strchr(debopts,**s);
            if (d)
                i |= 1 << (d - debopts);
            else if (ckWARN_d(WARN_DEBUGGING))
@@ -2468,7 +2476,7 @@ Perl_get_debug_opts(pTHX_ char **s, bool givehelp)
        for (; isALNUM(**s); (*s)++) ;
     }
     else if (givehelp) {
-      char **p = usage_msgd;
+      const char **p = usage_msgd;
       while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
     }
 #  ifdef EBCDIC
@@ -2531,7 +2539,7 @@ Perl_moreswitches(pTHX_ char *s)
     }
     case 'C':
         s++;
-        PL_unicode = parse_unicode_opts(&s);
+        PL_unicode = parse_unicode_opts( (const char **)&s );
        return s;
     case 'F':
        PL_minus_F = TRUE;
@@ -2561,7 +2569,7 @@ Perl_moreswitches(pTHX_ char *s)
        /* The following permits -d:Mod to accepts arguments following an =
           in the fashion that -MSome::Mod does. */
        if (*s == ':' || *s == '=') {
-           char *start;
+            const char *start;
            SV *sv;
            sv = newSVpv("use Devel::", 0);
            start = ++s;
@@ -2588,7 +2596,7 @@ Perl_moreswitches(pTHX_ char *s)
 #ifdef DEBUGGING
        forbid_setid("-D");
        s++;
-       PL_debug = get_debug_opts(&s, 1) | DEBUG_TOP_FLAG;
+       PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
 #else /* !DEBUGGING */
        if (ckWARN_d(WARN_DEBUGGING))
            Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
@@ -2690,7 +2698,7 @@ Perl_moreswitches(pTHX_ char *s)
        if (*++s) {
            char *start;
            SV *sv;
-           char *use = "use ";
+           const char *use = "use ";
            /* -M-foo == 'no foo'       */
            if (*s == '-') { use = "no "; ++s; }
            sv = newSVpv(use,0);
@@ -3016,13 +3024,13 @@ S_init_main_stash(pTHX)
 
 /* PSz 18 Nov 03  fdscript now global but do not change prototype */
 STATIC void
-S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
+S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
 {
 #ifndef IAMSUID
-    char *quote;
-    char *code;
-    char *cpp_discard_flag;
-    char *perl;
+    const char *quote;
+    const char *code;
+    const char *cpp_discard_flag;
+    const char *perl;
 #endif
 
     PL_fdscript = -1;
@@ -3033,10 +3041,10 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
     }
     else {
        /* if find_script() returns, it returns a malloc()-ed value */
-       PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
+       scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1);
 
        if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
-           char *s = scriptname + 8;
+            const char *s = scriptname + 8;
            PL_fdscript = atoi(s);
            while (isDIGIT(*s))
                s++;
@@ -3063,7 +3071,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
                }
                scriptname = savepv(s + 1);
                Safefree(PL_origfilename);
-               PL_origfilename = scriptname;
+               PL_origfilename = (char *)scriptname;
            }
        }
     }
@@ -3071,7 +3079,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
     CopFILE_free(PL_curcop);
     CopFILE_set(PL_curcop, PL_origfilename);
     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
-       scriptname = "";
+       scriptname = (char *)"";
     if (PL_fdscript >= 0) {
        PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
 #       if defined(HAS_FCNTL) && defined(F_SETFD)
@@ -3098,7 +3106,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
     }
 #else /* IAMSUID */
     else if (PL_preprocess) {
-       char *cpp_cfg = CPPSTDIN;
+       const char *cpp_cfg = CPPSTDIN;
        SV *cpp = newSVpvn("",0);
        SV *cmd = NEWSV(0,0);
 
@@ -3158,7 +3166,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
                               "PL_preprocess: cmd=\"%s\"\n",
                               SvPVX(cmd)));
 
-       PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
+       PL_rsfp = PerlProc_popen(SvPVX(cmd), (char *)"r");
        SvREFCNT_dec(cmd);
        SvREFCNT_dec(cpp);
     }
@@ -3318,7 +3326,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
 #endif /* IAMSUID */
 
 STATIC void
-S_validate_suid(pTHX_ char *validarg, char *scriptname)
+S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
 {
 #ifdef IAMSUID
     /* int which; */
@@ -3712,12 +3720,15 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
        /* not set-id, must be wrapped */
     }
 #endif /* DOSUID */
+    (void)validarg;
+    (void)scriptname;
 }
 
 STATIC void
 S_find_beginning(pTHX)
 {
-    register char *s, *s2;
+    register char *s;
+    register const char *s2;
 #ifdef MACOS_TRADITIONAL
     int maclines = 0;
 #endif
@@ -3827,6 +3838,7 @@ Perl_doing_taint(int argc, char *argv[], char *envp[])
     int euid = PerlProc_geteuid();
     int gid  = PerlProc_getgid();
     int egid = PerlProc_getegid();
+    (void)envp;
 
 #ifdef VMS
     uid  |=  gid << 16;
@@ -3845,7 +3857,7 @@ Perl_doing_taint(int argc, char *argv[], char *envp[])
 }
 
 STATIC void
-S_forbid_setid(pTHX_ char *s)
+S_forbid_setid(pTHX_ const char *s)
 {
 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
     if (PL_euid != PL_uid)
@@ -3894,7 +3906,6 @@ Perl_init_debugger(pTHX)
     PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
     PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
     PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
-    sv_upgrade(GvSV(PL_DBsub), SVt_IV);        /* IVX accessed if PERLDB_SUB_NN */
     PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
     sv_setiv(PL_DBsingle, 0);
     PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
@@ -4298,10 +4309,11 @@ S_incpush_if_exists(pTHX_ SV *dir)
 }
 
 STATIC void
-S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep,
-         int canrelocate)
+S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
+         bool canrelocate)
 {
     SV *subdir = Nullsv;
+    const char *p = dir;
 
     if (!p || !*p)
        return;
@@ -4313,7 +4325,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep,
     /* Break at all separators */
     while (p && *p) {
        SV *libdir = NEWSV(55,0);
-       char *s;
+        const char *s;
 
        /* skip any consecutive separators */
        if (usesep) {
@@ -4343,6 +4355,9 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep,
            sv_catpv(libdir, ":");
 #endif
 
+       /* Do the if() outside the #ifdef to avoid warnings about an unused
+          parameter.  */
+       if (canrelocate) {
 #ifdef PERL_RELOCATABLE_INC
        /*
         * Relocatable include entries are marked with a leading .../
@@ -4360,7 +4375,6 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep,
         * The intent is that /usr/local/bin/perl and .../../lib/perl5
         * generates /usr/local/lib/perl5
         */
-       {
            char *libpath = SvPVX(libdir);
            STRLEN libpath_len = SvCUR(libdir);
            if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
@@ -4437,8 +4451,8 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep,
                }
                SvREFCNT_dec(prefix_sv);
            }
-       }
 #endif
+       }
        /*
         * BEFORE pushing libdir onto @INC we may first push version- and
         * archname-specific sub-directories.
@@ -4536,7 +4550,7 @@ S_init_main_thread(pTHX)
     SvFLAGS(PL_thrsv) = SVt_PV;
     SvANY(PL_thrsv) = (void*)xpv;
     SvREFCNT(PL_thrsv) = 1 << 30;      /* practically infinite */
-    SvPVX(PL_thrsv) = (char*)thr;
+    SvPV_set(PL_thrsvr, (char*)thr);
     SvCUR_set(PL_thrsv, sizeof(thr));
     SvLEN_set(PL_thrsv, sizeof(thr));
     *SvEND(PL_thrsv) = '\0';   /* in the trailing_nul field */
@@ -4596,13 +4610,13 @@ void
 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
 {
     SV *atsv;
-    line_t oldline = CopLINE(PL_curcop);
+    const line_t oldline = CopLINE(PL_curcop);
     CV *cv;
     STRLEN len;
     int ret;
     dJMPENV;
 
-    while (AvFILL(paramList) >= 0) {
+    while (av_len(paramList) >= 0) {
        cv = (CV*)av_shift(paramList);
        if (PL_savebegin) {
            if (paramList == PL_beginav) {
@@ -4763,6 +4777,9 @@ static I32
 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
 {
     char *p, *nl;
+    (void)idx;
+    (void)maxlen;
+
     p  = SvPVX(PL_e_script);
     nl = strchr(p, '\n');
     nl = (nl) ? nl+1 : SvEND(PL_e_script);