(replaced by #13336)

[p5sagit/p5-mst-13.2.git] / doio.c

diff --git a/doio.c b/doio.c
index 47a5af6..f5a26af 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -172,13 +172,18 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
        STRLEN olen = len;
        char *tend;
        int dodup = 0;
+       PerlIO *that_fp = NULL;
 
        type = savepvn(name, len);
        tend = type+len;
        SAVEFREEPV(type);
-       /* Loose trailing white space */
-       while (tend > type && isSPACE(tend[-1]))
-           *tend-- = '\0';
+
+        /* Lose leading and trailing white space */
+        /*SUPPRESS 530*/
+        for (; isSPACE(*type); type++) ;
+        while (tend > type && isSPACE(tend[-1]))
+           *--tend = '\0';
+
        if (num_svs) {
            /* New style explict name, type is just mode and discipline/layer info */
            STRLEN l = 0;
@@ -186,8 +191,6 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            len = (I32)l;
            name = savepvn(name, len);
            SAVEFREEPV(name);
-           /*SUPPRESS 530*/
-           for (; isSPACE(*type); type++) ;
        }
        else {
            name = type;
@@ -264,7 +267,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 
            if (*type == '&') {
              duplicity:
-               dodup = 1;
+               dodup = PERLIO_DUP_FD;
                type++;
                if (*type == '=') {
                    dodup = 0;
@@ -304,8 +307,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 #endif
                            goto say_false;
                        }
-                       if (IoIFP(thatio)) {
-                           PerlIO *fp = IoIFP(thatio);
+                       if ((that_fp = IoIFP(thatio))) {
                            /* Flush stdio buffer before dup. --mjd
                             * Unfortunately SEEK_CURing 0 seems to
                             * be optimized away on most platforms;
@@ -315,21 +317,21 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                            /* sfio fails to clear error on next
                               sfwrite, contrary to documentation.
                               -- Nick Clark */
-                           if (PerlIO_seek(fp, 0, SEEK_CUR) == -1)
-                               PerlIO_clearerr(fp);
+                           if (PerlIO_seek(that_fp, 0, SEEK_CUR) == -1)
+                               PerlIO_clearerr(that_fp);
 #endif
                            /* On the other hand, do all platforms
                             * take gracefully to flushing a read-only
                             * filehandle?  Perhaps we should do
                             * fsetpos(src)+fgetpos(dst)?  --nik */
-                           PerlIO_flush(fp);
-                           fd = PerlIO_fileno(fp);
+                           PerlIO_flush(that_fp);
+                           fd = PerlIO_fileno(that_fp);
                            /* When dup()ing STDIN, STDOUT or STDERR
                             * explicitly set appropriate access mode */
-                           if (IoIFP(thatio) == PerlIO_stdout()
-                               || IoIFP(thatio) == PerlIO_stderr())
+                           if (that_fp == PerlIO_stdout()
+                               || that_fp == PerlIO_stderr())
                                IoTYPE(io) = IoTYPE_WRONLY;
-                           else if (IoIFP(thatio) == PerlIO_stdin())
+                           else if (that_fp == PerlIO_stdin())
                                 IoTYPE(io) = IoTYPE_RDONLY;
                            /* When dup()ing a socket, say result is
                             * one as well */
@@ -339,15 +341,20 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                        else
                            fd = -1;
                    }
-                   if (dodup)
-                       fd = PerlLIO_dup(fd);
-                   else
-                       was_fdopen = TRUE;
                    if (!num_svs)
                        type = Nullch;
-                   if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
+                   if (that_fp) {
+                       fp = PerlIO_fdupopen(aTHX_ that_fp, NULL, dodup);
+                   }
+                   else {
                        if (dodup)
-                           PerlLIO_close(fd);
+                           fd = PerlLIO_dup(fd);
+                       else
+                           was_fdopen = TRUE;
+                       if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) {
+                           if (dodup)
+                               PerlLIO_close(fd);
+                       }
                    }
                }
            } /* & */
@@ -533,6 +540,10 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
        if (savefd != fd) {
            Pid_t pid;
            SV *sv;
+           /* Still a small can-of-worms here if (say) PerlIO::Scalar
+              is assigned to (say) STDOUT - for now let dup2() fail
+              and provide the error
+            */
            if (PerlLIO_dup2(fd, savefd) < 0) {
                (void)PerlIO_close(fp);
                goto say_false;
@@ -555,8 +566,9 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            UNLOCK_FDPID_MUTEX;
            (void)SvUPGRADE(sv, SVt_IV);
            SvIVX(sv) = pid;
-           if (!was_fdopen)
+           if (!was_fdopen) {
                PerlIO_close(fp);
+           }
        }
        fp = saveifp;
        PerlIO_clearerr(fp);
@@ -2100,7 +2112,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp)
 
 Function called by C<do_readline> to spawn a glob (or do the glob inside
 perl on VMS). This code used to be inline, but now perl uses C<File::Glob>
-this glob starter is only used by miniperl during the build proccess.
+this glob starter is only used by miniperl during the build process.
 Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up.
 
 =cut