Give a meaning to '&' in n-arg open case:

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

diff --git a/doio.c b/doio.c
index a1d0e46..a32604e 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -84,7 +84,6 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
     bool was_fdopen = FALSE;
     bool in_raw = 0, in_crlf = 0, out_raw = 0, out_crlf = 0;
     char *type  = NULL;
-    char *deftype = NULL;
     char mode[4];              /* stdio file mode ("r\0", "rb\0", "r+b\0" etc.) */
     SV *svs = (num_svs) ? *svp : Nullsv;
 
@@ -133,6 +132,9 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
 
     if (as_raw) {
         /* sysopen style args, i.e. integer mode and permissions */
+       if (num_svs != 0) {
+            Perl_croak(aTHX_ "panic:sysopen with multiple args");
+       }
 
 #if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE)
        rawmode |= O_LARGEFILE;
@@ -216,7 +218,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            len  = tend-type;
        }
        IoTYPE(io) = *type;
-       if (*type == IoTYPE_RDWR && (!num_svs || tend > type+1 && tend[-1] != IoTYPE_PIPE)) { /* scary */
+       if ((*type == IoTYPE_RDWR) && ((!num_svs || tend > type+1 && tend[-1] != IoTYPE_PIPE))) { /* scary */
            mode[1] = *type++;
            writing = 1;
        }
@@ -235,7 +237,8 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                name = type;
                len = tend-type;
            }
-           if (*name == '\0') { /* command is missing 19990114 */
+           if (*name == '\0') {
+               /* command is missing 19990114 */
                if (ckWARN(WARN_PIPE))
                    Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
                errno = EPIPE;
@@ -255,7 +258,12 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                strcat(mode, "b");
            else if (out_crlf)
                strcat(mode, "t");
-           fp = PerlProc_popen(name,mode);
+           if (num_svs > 1) {
+               fp = PerlProc_popen_list(mode, num_svs, svp);
+           }
+           else {
+               fp = PerlProc_popen(name,mode);
+           }
        }
        else if (*type == IoTYPE_WRONLY) {
            TAINT_PROPER("open");
@@ -275,27 +283,39 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                strcat(mode, "t");
 
            if (*type == '&') {
-               name = type;
              duplicity:
-               if (num_svs)
-                   goto unknown_desr;
                dodup = 1;
-               name++;
-               if (*name == '=') {
+               type++;
+               if (*type == '=') {
                    dodup = 0;
-                   name++;
+                   type++;
                }
-               if (!*name && supplied_fp)
+               if (!num_svs && !*type && supplied_fp)
+                   /* "<+&" etc. is used by typemaps */
                    fp = supplied_fp;
                else {
-                   /*SUPPRESS 530*/
-                   for (; isSPACE(*name); name++) ;
-                   if (isDIGIT(*name))
-                       fd = atoi(name);
+                   if (num_svs > 1) {
+                       Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io));
+                   }
+                   if (num_svs && SvIOK(*svp))
+                       fd = SvUV(*svp);
+                   else if (isDIGIT(*type)) {
+                       /*SUPPRESS 530*/
+                       for (; isSPACE(*type); type++) ;
+                       fd = atoi(type);
+                   }
                    else {
                        IO* thatio;
-                       gv = gv_fetchpv(name,FALSE,SVt_PVIO);
-                       thatio = GvIO(gv);
+                       if (num_svs) {
+                           thatio = sv_2io(*svp);
+                       }
+                       else {
+                           GV *thatgv;
+                           /*SUPPRESS 530*/
+                           for (; isSPACE(*type); type++) ;
+                           thatgv = gv_fetchpv(type,FALSE,SVt_PVIO);
+                           thatio = GvIO(thatgv);
+                       }
                        if (!thatio) {
 #ifdef EINVAL
                            SETERRNO(EINVAL,SS$_IVCHAN);
@@ -348,6 +368,9 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                }
            }
            else {
+               if (num_svs > 1) {
+                   Perl_croak(aTHX_ "More than one argument to '>' open");
+               }
                /*SUPPRESS 530*/
                for (; isSPACE(*type); type++) ;
                if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
@@ -362,6 +385,9 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            }
        }
        else if (*type == IoTYPE_RDONLY) {
+           if (num_svs > 1) {
+               Perl_croak(aTHX_ "More than one argument to '<' open");
+           }
            /*SUPPRESS 530*/
            for (type++; isSPACE(*type); type++) ;
            mode[0] = 'r';
@@ -371,7 +397,6 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                strcat(mode, "t");
 
            if (*type == '&') {
-               name = type;
                goto duplicity;
            }
            if (*type == IoTYPE_STD && (!type[1] || isSPACE(type[1]) || type[1] == ':')) {
@@ -397,7 +422,8 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                name = type;
                len  = tend-type;
            }
-           if (*name == '\0') { /* command is missing 19990114 */
+           if (*name == '\0') {
+               /* command is missing 19990114 */
                if (ckWARN(WARN_PIPE))
                    Perl_warner(aTHX_ WARN_PIPE, "Missing command in piped open");
                errno = EPIPE;
@@ -411,7 +437,12 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
                strcat(mode, "b");
            else if (in_crlf)
                strcat(mode, "t");
-           fp = PerlProc_popen(name,mode);
+           if (num_svs > 1) {
+               fp = PerlProc_popen_list(mode,num_svs,svp);
+           }
+           else {
+               fp = PerlProc_popen(name,mode);
+           }
            IoTYPE(io) = IoTYPE_PIPE;
        }
        else {
@@ -440,6 +471,18 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
        goto say_false;
     }
+
+    if (ckWARN(WARN_IO)) {
+       if ((IoTYPE(io) == IoTYPE_RDONLY) &&
+           (fp == PerlIO_stdout() || fp == PerlIO_stderr())) {
+               Perl_warner(aTHX_ WARN_IO, "'std%s' opened only for input",
+                               (fp == PerlIO_stdout()) ? "out" : "err");
+       }
+       else if ((IoTYPE(io) == IoTYPE_WRONLY) && fp == PerlIO_stdout()) {
+               Perl_warner(aTHX_ WARN_IO, "'stdin' opened only for output");
+       }
+    }
+
     if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) {
        if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) {
            (void)PerlIO_close(fp);
@@ -915,9 +958,7 @@ Perl_do_eof(pTHX_ GV *gv)
 
     if (!io)
        return TRUE;
-    else if (ckWARN(WARN_IO)
-            && (IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout()
-                || IoIFP(io) == PerlIO_stderr()))
+    else if (ckWARN(WARN_IO) && (IoTYPE(io) == IoTYPE_WRONLY))
     {
        /* integrate to report_evil_fh()? */
         char *name = NULL;
@@ -1191,7 +1232,7 @@ Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
 I32
 Perl_my_stat(pTHX)
 {
-    djSP;
+    dSP;
     IO *io;
     GV* gv;
 
@@ -1244,7 +1285,7 @@ Perl_my_stat(pTHX)
 I32
 Perl_my_lstat(pTHX)
 {
-    djSP;
+    dSP;
     SV *sv;
     STRLEN n_a;
     if (PL_op->op_flags & OPf_REF) {
@@ -1295,15 +1336,18 @@ Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp,
                *a++ = "";
        }
        *a = Nullch;
-       if (*PL_Argv[0] != '/') /* will execvp use PATH? */
+       if (really)
+           tmps = SvPV(really, n_a);
+       if ((!really && *PL_Argv[0] != '/') ||
+           (really && *tmps != '/'))           /* will execvp use PATH? */
            TAINT_ENV();                /* testing IFS here is overkill, probably */
-       if (really && *(tmps = SvPV(really, n_a)))
+       if (really && *tmps)
            PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv));
        else
            PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv));
        if (ckWARN(WARN_EXEC))
            Perl_warner(aTHX_ WARN_EXEC, "Can't exec \"%s\": %s",
-               PL_Argv[0], Strerror(errno));
+               (really ? tmps : PL_Argv[0]), Strerror(errno));
        if (do_report) {
            int e = errno;