Die on n-arg open(...,"",xxx,yyy,...)

 - redirect pipe cases to PerlProc_popen_list() (which just croaks for now)
 - die on read/write cases so we can decide what it means later.

p4raw-id: //depot/perlio@9294

diff --git a/doio.c b/doio.c
index 3ed517b..67fa665 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -132,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;
@@ -234,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;
@@ -254,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");
@@ -276,15 +285,17 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
            if (*type == '&') {
                name = type;
              duplicity:
-               if (num_svs)
-                   goto unknown_desr;
                dodup = 1;
                name++;
                if (*name == '=') {
                    dodup = 0;
                    name++;
                }
+               if (num_svs) {
+                   goto unknown_desr;
+               }
                if (!*name && supplied_fp)
+                   /* "<+&" etc. is used by typemaps */
                    fp = supplied_fp;
                else {
                    /*SUPPRESS 530*/
@@ -347,6 +358,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] == ':')) {
@@ -361,6 +375,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';
@@ -396,7 +413,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;
@@ -410,7 +428,13 @@ 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 {

diff --git a/embed.pl b/embed.pl
index cb2b4a7..7867892 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1772,6 +1772,7 @@ Anp       |void*  |my_memset      |char* loc|I32 ch|I32 len
 #if !defined(PERL_OBJECT)
 Ap     |I32    |my_pclose      |PerlIO* ptr
 Ap     |PerlIO*|my_popen       |char* cmd|char* mode
+Ap     |PerlIO*|my_popen_list  |char* mode|int n|SV ** args
 #endif
 Ap     |void   |my_setenv      |char* nam|char* val
 Ap     |I32    |my_stat

diff --git a/iperlsys.h b/iperlsys.h
index fdbd12a..8a628cd 100644 (file)
--- a/iperlsys.h
+++ b/iperlsys.h
@@ -253,7 +253,7 @@ struct IPerlStdIOInfo
 #define PerlSIO_printf         Perl_fprintf_nocontext
 #define PerlSIO_stdoutf                Perl_printf_nocontext
 #define PerlSIO_vprintf(f,fmt,a)                                               \
-       (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a)          
+       (*PL_StdIO->pVprintf)(PL_StdIO, (f),(fmt),a)
 #define PerlSIO_ftell(f)                                                       \
        (*PL_StdIO->pTell)(PL_StdIO, (f))
 #define PerlSIO_fseek(f,o,w)                                           \
@@ -982,6 +982,8 @@ struct IPerlProcInfo
        (*PL_Proc->pPauseProc)(PL_Proc)
 #define PerlProc_popen(c, m)                                           \
        (*PL_Proc->pPopen)(PL_Proc, (c), (m))
+#define PerlProc_popen_list(m, n, a)                                   \
+       (*PL_Proc->pPopenList)(PL_Proc, (m), (n), (a))
 #define PerlProc_pclose(f)                                             \
        (*PL_Proc->pPclose)(PL_Proc, (f))
 #define PerlProc_pipe(fd)                                              \
@@ -1043,6 +1045,7 @@ struct IPerlProcInfo
 #define PerlProc_killpg(i, a)  killpg((i), (a))
 #define PerlProc_pause()       Pause()
 #define PerlProc_popen(c, m)   my_popen((c), (m))
+#define PerlProc_popen_list(m,n,a)     my_popen_list((m),(n),(a))
 #define PerlProc_pclose(f)     my_pclose((f))
 #define PerlProc_pipe(fd)      pipe((fd))
 #define PerlProc_setuid(u)     setuid((u))

diff --git a/util.c b/util.c
index e24a81d..25286ac 100644 (file)
--- a/util.c
+++ b/util.c
@@ -2309,6 +2309,13 @@ VTOH(vtohs,short)
 VTOH(vtohl,long)
 #endif
 
+PerlIO *
+Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
+{
+    Perl_croak(aTHX_ "List form of piped open not implemented");
+    return (PerlIO *) NULL;
+}
+
     /* VMS' my_popen() is in VMS.c, same with OS/2. */
 #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
 PerlIO *
@@ -3969,14 +3976,14 @@ Perl_ebcdic_control(pTHX_ int ch)
 {
        if (ch > 'a') {
                char *ctlp;
- 
+
               if (islower(ch))
                      ch = toupper(ch);
- 
+
               if ((ctlp = strchr(controllablechars, ch)) == 0) {
                      Perl_die(aTHX_ "unrecognised control character '%c'\n", ch);
               }
- 
+
                if (ctlp == controllablechars)
                       return('\177'); /* DEL */
                else