move DProf things around to where they are supposed to be

[perl5.git] / doio.c

diff --git a/doio.c b/doio.c
index 92a463c..d55acb1 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -64,7 +64,12 @@
 
 #if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
 # include <sys/socket.h>
-# include <netdb.h>
+# if defined(USE_SOCKS) && defined(I_SOCKS)
+#   include <socks.h>
+# endif 
+# ifdef I_NETBSD
+#  include <netdb.h>
+# endif
 # ifndef ENOTSOCK
 #  ifdef I_NET_ERRNO
 #   include <net/errno.h>
@@ -455,8 +460,10 @@ Perl_nextargv(pTHX_ register GV *gv)
                fileuid = PL_statbuf.st_uid;
                filegid = PL_statbuf.st_gid;
                if (!S_ISREG(PL_filemode)) {
-                   Perl_warn(aTHX_ "Can't do inplace edit: %s is not a regular file",
-                     PL_oldname );
+                   if (ckWARN_d(WARN_INPLACE)) 
+                       Perl_warner(aTHX_ WARN_INPLACE,
+                           "Can't do inplace edit: %s is not a regular file",
+                           PL_oldname );
                    do_close(gv,FALSE);
                    continue;
                }
@@ -483,9 +490,12 @@ Perl_nextargv(pTHX_ register GV *gv)
 #ifdef DJGPP
                       || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0
 #endif
-                      ) {
-                       Perl_warn(aTHX_ "Can't do inplace edit: %s would not be unique",
-                         SvPVX(sv) );
+                      )
+                   {
+                       if (ckWARN_d(WARN_INPLACE))     
+                           Perl_warner(aTHX_ WARN_INPLACE,
+                             "Can't do inplace edit: %s would not be unique",
+                             SvPVX(sv));
                        do_close(gv,FALSE);
                        continue;
                    }
@@ -493,8 +503,10 @@ Perl_nextargv(pTHX_ register GV *gv)
 #ifdef HAS_RENAME
 #ifndef DOSISH
                    if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) {
-                       Perl_warn(aTHX_ "Can't rename %s to %s: %s, skipping file",
-                         PL_oldname, SvPVX(sv), Strerror(errno) );
+                       if (ckWARN_d(WARN_INPLACE))     
+                           Perl_warner(aTHX_ WARN_INPLACE, 
+                             "Can't rename %s to %s: %s, skipping file",
+                             PL_oldname, SvPVX(sv), Strerror(errno) );
                        do_close(gv,FALSE);
                        continue;
                    }
@@ -507,8 +519,10 @@ Perl_nextargv(pTHX_ register GV *gv)
 #else
                    (void)UNLINK(SvPVX(sv));
                    if (link(PL_oldname,SvPVX(sv)) < 0) {
-                       Perl_warn(aTHX_ "Can't rename %s to %s: %s, skipping file",
-                         PL_oldname, SvPVX(sv), Strerror(errno) );
+                       if (ckWARN_d(WARN_INPLACE))     
+                           Perl_warner(aTHX_ WARN_INPLACE,
+                             "Can't rename %s to %s: %s, skipping file",
+                             PL_oldname, SvPVX(sv), Strerror(errno) );
                        do_close(gv,FALSE);
                        continue;
                    }
@@ -519,8 +533,10 @@ Perl_nextargv(pTHX_ register GV *gv)
 #if !defined(DOSISH) && !defined(AMIGAOS)
 #  ifndef VMS  /* Don't delete; use automatic file versioning */
                    if (UNLINK(PL_oldname) < 0) {
-                       Perl_warn(aTHX_ "Can't remove %s: %s, skipping file",
-                         PL_oldname, Strerror(errno) );
+                       if (ckWARN_d(WARN_INPLACE))     
+                           Perl_warner(aTHX_ WARN_INPLACE,
+                             "Can't remove %s: %s, skipping file",
+                             PL_oldname, Strerror(errno) );
                        do_close(gv,FALSE);
                        continue;
                    }
@@ -540,8 +556,9 @@ Perl_nextargv(pTHX_ register GV *gv)
                if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0,
                             O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) {
 #endif
-                   Perl_warn(aTHX_ "Can't do inplace edit on %s: %s",
-                     PL_oldname, Strerror(errno) );
+                   if (ckWARN_d(WARN_INPLACE)) 
+                       Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s",
+                         PL_oldname, Strerror(errno) );
                    do_close(gv,FALSE);
                    continue;
                }
@@ -568,9 +585,18 @@ Perl_nextargv(pTHX_ register GV *gv)
            }
            return IoIFP(GvIOp(gv));
        }
-       else
-           PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",
-             SvPV(sv, oldlen), Strerror(errno));
+       else {
+           dTHR;
+           if (ckWARN_d(WARN_INPLACE)) {
+               if (!S_ISREG(PL_statbuf.st_mode))       
+                   Perl_warner(aTHX_ WARN_INPLACE,
+                               "Can't do inplace edit: %s is not a regular file",
+                               PL_oldname );
+               else
+                   Perl_warner(aTHX_ WARN_INPLACE, "Can't open %s: %s\n",
+                               PL_oldname, Strerror(errno));
+           }
+       }
     }
     if (PL_inplace) {
        (void)do_close(PL_argvoutgv,FALSE);
@@ -701,6 +727,15 @@ Perl_do_eof(pTHX_ GV *gv)
 
     if (!io)
        return TRUE;
+    else if (ckWARN(WARN_IO)
+            && (IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
+                || IoIFP(io) == PerlIO_stderr()))
+    {
+       SV* sv = sv_newmortal();
+       gv_efullname3(sv, gv, Nullch);
+       Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
+                   SvPV_nolen(sv));
+    }
 
     while (IoIFP(io)) {
 
@@ -819,7 +854,7 @@ Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int flag)
 #endif
 #else
 #if defined(USEMYBINMODE)
-    if (my_binmode(fp,iotype) != NULL)
+    if (my_binmode(fp,iotype) != FALSE)
        return 1;
     else
        return 0;
@@ -893,7 +928,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
        if (SvGMAGICAL(sv))
            mg_get(sv);
         if (SvIOK(sv) && SvIVX(sv) != 0) {
-           PerlIO_printf(fp, PL_ofmt, (double)SvIVX(sv));
+           PerlIO_printf(fp, PL_ofmt, (NV)SvIVX(sv));
            return !PerlIO_error(fp);
        }
        if (  (SvNOK(sv) && SvNVX(sv) != 0.0)
@@ -1014,6 +1049,13 @@ Perl_my_lstat(pTHX)
 bool
 Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
 {
+    return do_aexec5(really, mark, sp, 0, 0);
+}
+
+bool
+Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
+              int fd, int do_report)
+{
     register char **a;
     char *tmps;
     STRLEN n_a;
@@ -1038,6 +1080,12 @@ Perl_do_aexec(pTHX_ SV *really, register SV **mark, register SV **sp)
        if (ckWARN(WARN_EXEC))
            Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s", 
                PL_Argv[0], Strerror(errno));
+       if (do_report) {
+           int e = errno;
+
+           PerlLIO_write(fd, (void*)&e, sizeof(int));
+           PerlLIO_close(fd);
+       }
     }
     do_execfree();
     return FALSE;
@@ -1056,7 +1104,7 @@ Perl_do_execfree(pTHX)
     }
 }
 
-#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP)
+#if !defined(OS2) && !defined(WIN32) && !defined(DJGPP) && !defined(EPOC)
 
 bool
 Perl_do_exec(pTHX_ char *cmd)
@@ -1121,6 +1169,20 @@ Perl_do_exec3(pTHX_ char *cmd, int fd, int do_report)
                *s = '\0';
                break;
            }
+           /* handle the 2>&1 construct at the end */
+           if (*s == '>' && s[1] == '&' && s[2] == '1'
+               && s > cmd + 1 && s[-1] == '2' && isSPACE(s[-2])
+               && (!s[3] || isSPACE(s[3])))
+           {
+               char *t = s + 3;
+
+               while (*t && isSPACE(*t))
+                   ++t;
+               if (!*t && (dup2(1,2) != -1)) {
+                   s[-2] = '\0';
+                   break;
+               }
+           }
          doshell:
            PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char*)0);
            return FALSE;