Version bumping thanks to the Coverity deluge.

[perl5.git] / perl.c

diff --git a/perl.c b/perl.c
index 3007dc7..8480a5d 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -256,6 +256,13 @@ perl_construct(pTHXx)
 
     init_i18nl10n(1);
 
+    /* Keep LC_NUMERIC in the C locale for backwards compatibility for XS
+     * modules.  (Core operations that need the underlying locale change to it
+     * temporarily).  An explicit call to POSIX::setlocale() still will cause
+     * XS module failures, but this is how it has been for a long time [perl
+     * #121317] */
+    SET_NUMERIC_STANDARD();
+
 #if defined(LOCAL_PATCH_COUNT)
     PL_localpatches = local_patches;   /* For possible -v */
 #endif
@@ -670,7 +677,7 @@ perl_destruct(pTHXx)
                msg.msg_name = NULL;
                msg.msg_namelen = 0;
                msg.msg_iov = vec;
-               msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
+               msg.msg_iovlen = C_ARRAY_LENGTH(vec);
 
                vec[0].iov_base = (void*)⌖
                vec[0].iov_len = sizeof(target);
@@ -1489,8 +1496,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
         * --jhi */
         const char *s = NULL;
         int i;
-        const UV mask =
-          ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
+        const UV mask = ~(UV)(PTRSIZE-1);
          /* Do the mask check only if the args seem like aligned. */
         const UV aligned =
           (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
@@ -3684,6 +3690,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
     PerlIO *rsfp = NULL;
     dVAR;
     Stat_t tmpstatbuf;
+    int fd;
 
     PERL_ARGS_ASSERT_OPEN_SCRIPT;
 
@@ -3756,7 +3763,9 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
        const char * const err = "Failed to create a fake bit bucket";
        if (strEQ(scriptname, BIT_BUCKET)) {
 #ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
+            int old_umask = umask(0600);
            int tmpfd = mkstemp(tmpname);
+            umask(old_umask);
            if (tmpfd > -1) {
                scriptname = tmpname;
                close(tmpfd);
@@ -3789,13 +3798,20 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
            Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
                    CopFILE(PL_curcop), Strerror(errno));
     }
+    fd = PerlIO_fileno(rsfp);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    /* ensure close-on-exec */
-    fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+    if (fd >= 0) {
+        /* ensure close-on-exec */
+        if (fcntl(fd, F_SETFD, 1) < 0) {
+            Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+                       CopFILE(PL_curcop), Strerror(errno));
+        }
+    }
 #endif
 
-    if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
-        && S_ISDIR(tmpstatbuf.st_mode))
+    if (fd < 0 ||
+        (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
+         && S_ISDIR(tmpstatbuf.st_mode)))
         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
             CopFILE(PL_curcop),
             Strerror(EISDIR));
@@ -3826,12 +3842,18 @@ S_validate_suid(pTHX_ PerlIO *rsfp)
 
     if (my_euid != my_uid || my_egid != my_gid) {      /* (suidperl doesn't exist, in fact) */
        dVAR;
-
-       PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
-       if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
-           ||
-           (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
-          )
+        int fd = PerlIO_fileno(rsfp);
+        if (fd < 0) {
+            Perl_croak(aTHX_ "Illegal suidscript");
+        } else {
+            if (PerlLIO_fstat(fd, &PL_statbuf) < 0) {  /* may be either wrapped or real suid */
+                Perl_croak(aTHX_ "Illegal suidscript");
+            }
+        }
+        if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+            ||
+            (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+            )
            if (!PL_do_undump)
                Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
@@ -4745,7 +4767,7 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
 #ifdef PERL_IS_MINIPERL
            const Size_t extra = 0;
 #else
-           Size_t extra = av_len(av) + 1;
+           Size_t extra = av_tindex(av) + 1;
 #endif
            av_unshift(inc, extra + push_basedir);
            if (push_basedir)
@@ -4832,7 +4854,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
 
     PERL_ARGS_ASSERT_CALL_LIST;
 
-    while (av_len(paramList) >= 0) {
+    while (av_tindex(paramList) >= 0) {
        cv = MUTABLE_CV(av_shift(paramList));
        if (PL_savebegin) {
            if (paramList == PL_beginav) {