Apply #30197 to win32/makefile.mk too

[perl5.git] / pp_sys.c

diff --git a/pp_sys.c b/pp_sys.c
index 4465988..44adca6 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1,7 +1,7 @@
 /*    pp_sys.c
  *
- *    Copyright (C) 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
+ *    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ *    2004, 2005, 2006, 2007 by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -453,7 +453,7 @@ PP(pp_warn)
     if (!tmps || !len)
        tmpsv = sv_2mortal(newSVpvs("Warning: something's wrong"));
 
-    Perl_warn(aTHX_ "%"SVf, (void*)tmpsv);
+    Perl_warn(aTHX_ "%"SVf, SVfARG(tmpsv));
     RETSETYES;
 }
 
@@ -517,7 +517,7 @@ PP(pp_die)
     if (!tmps || !len)
        tmpsv = sv_2mortal(newSVpvs("Died"));
 
-    DIE(aTHX_ "%"SVf, (void*)tmpsv);
+    DIE(aTHX_ "%"SVf, SVfARG(tmpsv));
 }
 
 /* I/O. */
@@ -707,8 +707,12 @@ PP(pp_umask)
     Mode_t anum;
 
     if (MAXARG < 1) {
-       anum = PerlLIO_umask(0);
-       (void)PerlLIO_umask(anum);
+       anum = PerlLIO_umask(022);
+       /* setting it to 022 between the two calls to umask avoids
+        * to have a window where the umask is set to 0 -- meaning
+        * that another thread could create world-writeable files. */
+       if (anum != 022)
+           (void)PerlLIO_umask(anum);
     }
     else
        anum = PerlLIO_umask(POPi);
@@ -766,22 +770,23 @@ PP(pp_binmode)
     }
 
     PUTBACK;
-    if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
-                       (discp) ? SvPV_nolen_const(discp) : NULL)) {
-       if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
-            if (!PerlIO_binmode(aTHX_ IoOFP(io),IoTYPE(io),
-                       mode_from_discipline(discp),
-                       (discp) ? SvPV_nolen_const(discp) : NULL)) {
-               SPAGAIN;
-               RETPUSHUNDEF;
-            }
+    {
+       const int mode = mode_from_discipline(discp);
+       const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
+       if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
+           if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
+               if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
+                   SPAGAIN;
+                   RETPUSHUNDEF;
+               }
+           }
+           SPAGAIN;
+           RETPUSHYES;
+       }
+       else {
+           SPAGAIN;
+           RETPUSHUNDEF;
        }
-       SPAGAIN;
-       RETPUSHYES;
-    }
-    else {
-       SPAGAIN;
-       RETPUSHUNDEF;
     }
 }
 
@@ -839,10 +844,10 @@ PP(pp_tie)
        /* Not clear why we don't call call_method here too.
         * perhaps to get different error message ?
         */
-       stash = gv_stashsv(*MARK, FALSE);
+       stash = gv_stashsv(*MARK, 0);
        if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
            DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
-                methname, (void*)*MARK);
+                methname, SVfARG(*MARK));
        }
        ENTER;
        PUSHSTACKi(PERLSI_MAGIC);
@@ -941,7 +946,7 @@ PP(pp_dbmopen)
 
     HV * const hv = (HV*)POPs;
     SV * const sv = sv_2mortal(newSVpvs("AnyDBM_File"));
-    stash = gv_stashsv(sv, FALSE);
+    stash = gv_stashsv(sv, 0);
     if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
        PUTBACK;
        require_pv("AnyDBM_File.pm");
@@ -1265,6 +1270,7 @@ PP(pp_enterwrite)
     register IO *io;
     GV *fgv;
     CV *cv;
+    SV * tmpsv = NULL;
 
     if (MAXARG == 0)
        gv = PL_defoutgv;
@@ -1288,8 +1294,8 @@ PP(pp_enterwrite)
 
     cv = GvFORM(fgv);
     if (!cv) {
-       SV * const tmpsv = sv_newmortal();
        const char *name;
+       tmpsv = sv_newmortal();
        gv_efullname4(tmpsv, fgv, NULL, FALSE);
        name = SvPV_nolen_const(tmpsv);
        if (name && *name)
@@ -1483,6 +1489,8 @@ PP(pp_prtf)
        goto just_say_no;
     }
     else {
+       if (SvTAINTED(MARK[1]))
+           TAINT_PROPER("printf");
        do_sprintf(sv, SP - MARK, MARK + 1);
        if (!do_print(sv, fp))
            goto just_say_no;
@@ -1617,7 +1625,7 @@ PP(pp_sysread)
        buffer = SvGROW(bufsv, (STRLEN)(length+1));
        /* 'offset' means 'flags' here */
        count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
-                         (struct sockaddr *)namebuf, &bufsize);
+                                 (struct sockaddr *)namebuf, &bufsize);
        if (count < 0)
            RETPUSHUNDEF;
 #ifdef EPOC
@@ -1825,10 +1833,14 @@ PP(pp_send)
 
     SETERRNO(0,0);
     io = GvIO(gv);
-    if (!io || !IoIFP(io)) {
+    if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
        retval = -1;
-       if (ckWARN(WARN_CLOSED))
-           report_evil_fh(gv, io, PL_op->op_type);
+       if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
+           if (io && IoIFP(io))
+               report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
+           else
+               report_evil_fh(gv, io, PL_op->op_type);
+       }
        SETERRNO(EBADF,RMS_IFI);
        goto say_undef;
     }
@@ -2780,7 +2792,7 @@ PP(pp_stat)
 {
     dVAR;
     dSP;
-    GV *gv;
+    GV *gv = NULL;
     IO *io;
     I32 gimme;
     I32 max = 13;
@@ -2792,7 +2804,7 @@ PP(pp_stat)
            do_fstat_warning_check:
                if (ckWARN(WARN_IO))
                    Perl_warner(aTHX_ packWARN(WARN_IO),
-                       "lstat() on filehandle %s", GvENAME(gv));
+                       "lstat() on filehandle %s", gv ? GvENAME(gv) : "");
            } else if (PL_laststype != OP_LSTAT)
                Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
        }
@@ -2906,9 +2918,9 @@ PP(pp_stat)
        PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
        PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
 #else
-       PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
-       PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
-       PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
+       PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_atime)));
+       PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_mtime)));
+       PUSHs(sv_2mortal(newSViv((IV)PL_statcache.st_ctime)));
 #endif
 #ifdef USE_STAT_BLOCKS
        PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
@@ -3009,7 +3021,7 @@ PP(pp_ftrread)
 
     if (use_access) {
 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
-       const char *const name = POPpx;
+       const char *name = POPpx;
        if (effective) {
 #  ifdef PERL_EFF_ACCESS
            result = PERL_EFF_ACCESS(name, access_mode);
@@ -4645,7 +4657,7 @@ PP(pp_ghostent)
        STRLEN addrlen;
        Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
 
-       hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
+       hent = PerlSock_gethostbyaddr((const char*)addr, (Netdb_hlen_t) addrlen, addrtype);
 #else
        DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
 #endif