Replace ^M by a space in test for bug #37716, to make

[perl5.git] / perl.c

diff --git a/perl.c b/perl.c
index 9f8e385..4b005b6 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -137,6 +137,15 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
 #endif
 #endif
 
+#ifndef NO_MATHOMS
+/* This reference ensures that the mathoms are linked with perl */
+extern void Perl_mathoms(void);
+void Perl_mathoms_ref(void);
+void Perl_mathoms_ref(void) {
+    Perl_mathoms();
+}
+#endif
+
 static void
 S_init_tls_and_interp(PerlInterpreter *my_perl)
 {
@@ -259,7 +268,9 @@ perl_construct(pTHXx)
        }
 
        PL_sighandlerp = (Sighandler_t) Perl_sighandler;
+#ifdef PERL_USES_PL_PIDSTATUS
        PL_pidstatus = newHV();
+#endif
     }
 
     PL_rs = newSVpvn("\n", 1);
@@ -808,10 +819,10 @@ perl_destruct(pTHXx)
      */
     {
         I32 i = AvFILLp(PL_regex_padav) + 1;
-        SV **ary = AvARRAY(PL_regex_padav);
+        SV * const * const ary = AvARRAY(PL_regex_padav);
 
         while (i) {
-            SV *resv = ary[--i];
+            SV * const resv = ary[--i];
 
             if (SvFLAGS(resv) & SVf_BREAK) {
                 /* this is PL_reg_curpm, already freed
@@ -952,8 +963,10 @@ perl_destruct(pTHXx)
     PL_subname = Nullsv;
     SvREFCNT_dec(PL_linestr);
     PL_linestr = Nullsv;
+#ifdef PERL_USES_PL_PIDSTATUS
     SvREFCNT_dec(PL_pidstatus);
     PL_pidstatus = Nullhv;
+#endif
     SvREFCNT_dec(PL_toptarget);
     PL_toptarget = Nullsv;
     SvREFCNT_dec(PL_bodytarget);
@@ -1085,7 +1098,7 @@ perl_destruct(pTHXx)
         */
        I32 riter = 0;
        const I32 max = HvMAX(PL_strtab);
-       HE ** const array = HvARRAY(PL_strtab);
+       HE * const * const array = HvARRAY(PL_strtab);
        HE *hent = array[0];
 
        for (;;) {
@@ -1731,6 +1744,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #  ifdef DEBUGGING
                             " DEBUGGING"
 #  endif
+#  ifdef DEBUG_LEAKING_SCALARS
+                            " DEBUG_LEAKING_SCALARS"
+#  endif
 #  ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
                             " DEBUG_LEAKING_SCALARS_FORK_DUMP"
 #  endif
@@ -1743,6 +1759,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #  ifdef MYMALLOC
                             " MYMALLOC"
 #  endif
+#  ifdef NO_MATHOMS
+                            " NO_MATHOMS"
+#  endif
 #  ifdef PERL_DONT_CREATE_GVSV
                             " PERL_DONT_CREATE_GVSV"
 #  endif
@@ -1767,9 +1786,15 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #  ifdef PERL_OLD_COPY_ON_WRITE
                             " PERL_OLD_COPY_ON_WRITE"
 #  endif
+#  ifdef PERL_TRACK_MEMPOOL
+                            " PERL_TRACK_MEMPOOL"
+#  endif
 #  ifdef PERL_USE_SAFE_PUTENV
                             " PERL_USE_SAFE_PUTENV"
 #  endif
+#ifdef PERL_USES_PL_PIDSTATUS
+                            " PERL_USES_PL_PIDSTATUS"
+#endif
 #  ifdef PL_OP_SLAB_ALLOC
                             " PL_OP_SLAB_ALLOC"
 #  endif
@@ -1819,7 +1844,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
                         */
 
                        const char *space;
-                       char *pv = SvPV_nolen(opts_prog);
+                       char * const pv = SvPV_nolen(opts_prog);
                        const char c = pv[opts+76];
                        pv[opts+76] = '\0';
                        space = strrchr(pv+opts+26, ' ');
@@ -2049,7 +2074,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     if (xsinit)
        (*xsinit)(aTHX);        /* in case linked C routines want magical variables */
 #ifndef PERL_MICRO
-#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC)
+#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN)
     init_os_extras();
 #endif
 #endif
@@ -2330,7 +2355,7 @@ set and the variable does not exist then NULL is returned.
 AV*
 Perl_get_av(pTHX_ const char *name, I32 create)
 {
-    GV* gv = gv_fetchpv(name, create, SVt_PVAV);
+    GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
     if (create)
        return GvAVn(gv);
     if (gv)
@@ -2377,7 +2402,7 @@ subroutine does not exist then NULL is returned.
 CV*
 Perl_get_cv(pTHX_ const char *name, I32 create)
 {
-    GV* gv = gv_fetchpv(name, create, SVt_PVCV);
+    GV* const gv = gv_fetchpv(name, create, SVt_PVCV);
     /* XXX unsafe for threads if eval_owner isn't held */
     /* XXX this is probably not what they think they're getting.
      * It has the same effect as "sub name;", i.e. just a forward
@@ -2479,7 +2504,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
     I32 oldscope;
     bool oldcatch = CATCH_GET;
     int ret;
-    OP* oldop = PL_op;
+    OP* const oldop = PL_op;
     dJMPENV;
 
     if (flags & G_DISCARD) {
@@ -2646,7 +2671,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
     volatile I32 oldmark = SP - PL_stack_base;
     volatile I32 retval = 0;
     int ret;
-    OP* oldop = PL_op;
+    OP* const oldop = PL_op;
     dJMPENV;
 
     if (flags & G_DISCARD) {
@@ -2779,9 +2804,9 @@ Perl_require_pv(pTHX_ const char *pv)
 void
 Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
 {
-    register GV *gv;
+    register GV * const gv = gv_fetchpv(sym,TRUE, SVt_PV);
 
-    if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
+    if (gv)
        sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen);
 }
 
@@ -2873,7 +2898,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
        static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
 
        for (; isALNUM(**s); (*s)++) {
-           const char *d = strchr(debopts,**s);
+           const char * const d = strchr(debopts,**s);
            if (d)
                i |= 1 << (d - debopts);
            else if (ckWARN_d(WARN_DEBUGGING))
@@ -2982,8 +3007,7 @@ Perl_moreswitches(pTHX_ char *s)
           in the fashion that -MSome::Mod does. */
        if (*s == ':' || *s == '=') {
             const char *start;
-           SV *sv;
-           sv = newSVpv("use Devel::", 0);
+           SV * const sv = newSVpv("use Devel::", 0);
            start = ++s;
            /* We now allow -d:Module=Foo,Bar */
            while(isALNUM(*s) || *s==':') ++s;
@@ -3426,11 +3450,14 @@ S_init_main_stash(pTHX)
     SvREADONLY_on(gv);
     hv_name_set(PL_defstash, "main", 4, 0);
     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
+    SvREFCNT_inc(PL_incgv); /* Don't allow it to be freed */
     GvMULTI_on(PL_incgv);
     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
     GvMULTI_on(PL_hintgv);
     PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
+    SvREFCNT_inc(PL_defgv);
     PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
+    SvREFCNT_inc(PL_errgv);
     GvMULTI_on(PL_errgv);
     PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
     GvMULTI_on(PL_replgv);
@@ -3533,9 +3560,9 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
     }
 #else /* IAMSUID */
     else if (PL_preprocess) {
-       const char *cpp_cfg = CPPSTDIN;
-       SV *cpp = newSVpvn("",0);
-       SV *cmd = NEWSV(0,0);
+       const char * const cpp_cfg = CPPSTDIN;
+       SV * const cpp = newSVpvn("",0);
+       SV * const cmd = NEWSV(0,0);
 
        if (cpp_cfg[0] == 0) /* PERL_MICRO? */
             Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
@@ -3798,6 +3825,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
     if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
        I32 len;
        const char *linestr;
+       const char *s_end;
 
 #ifdef IAMSUID
        if (PL_fdscript < 0 || PL_suidscript != 1)
@@ -3903,7 +3931,8 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
        s = linestr;
        /* PSz 27 Feb 04 */
        /* Sanity check on line length */
-       if (strlen(s) < 1 || strlen(s) > 4000)
+       s_end = s + strlen(s);
+       if (s_end == s || (s_end - s) > 4000)
            Perl_croak(aTHX_ "Very long #! line");
        /* Allow more than a single space after #! */
        while (isSPACE(*s)) s++;
@@ -3942,7 +3971,8 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
        len = strlen(validarg);
        if (strEQ(validarg," PHOOEY ") ||
            strnNE(s,validarg,len) || !isSPACE(s[len]) ||
-           !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
+           !((s_end - s) == len+1
+             || ((s_end - s) == len+2 && isSPACE(s[len+1]))))
            Perl_croak(aTHX_ "Args must match #! line");
 
 #ifndef IAMSUID
@@ -4330,7 +4360,7 @@ S_forbid_setid(pTHX_ const char *s)
 void
 Perl_init_debugger(pTHX)
 {
-    HV *ostash = PL_curstash;
+    HV * const ostash = PL_curstash;
 
     PL_curstash = PL_debstash;
     PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
@@ -4901,8 +4931,8 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
        if (addsubdirs || addoldvers) {
 #ifdef PERL_INC_VERSION_LIST
            /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
-           const char *incverlist[] = { PERL_INC_VERSION_LIST };
-           const char **incver;
+           const char * const incverlist[] = { PERL_INC_VERSION_LIST };
+           const char * const *incver;
 #endif
 #ifdef VMS
            char *unix;
@@ -5157,7 +5187,7 @@ Perl_my_exit(pTHX_ U32 status)
        STATUS_ALL_FAILURE;
        break;
     default:
-       STATUS_UNIX_EXIT_SET(status);
+       STATUS_EXIT_SET(status);
        break;
     }
     my_exit_jump();