Tests are good

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

diff --git a/doio.c b/doio.c
index 47a5af6..d005a4e 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;
@@ -305,7 +308,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                            goto say_false;
                        }
                        if (IoIFP(thatio)) {
-                           PerlIO *fp = IoIFP(thatio);
+                           that_fp = IoIFP(thatio);
                            /* Flush stdio buffer before dup. --mjd
                             * Unfortunately SEEK_CURing 0 seems to
                             * be optimized away on most platforms;
@@ -315,15 +318,15 @@ 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()
@@ -339,15 +342,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 +541,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 +567,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 +2113,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