This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
applied suggested patch; added missing prototype changes to
authorIlya Zakharevich <ilya@math.berkeley.edu>
Thu, 17 Jun 1999 00:39:34 +0000 (20:39 -0400)
committerGurusamy Sarathy <gsar@cpan.org>
Tue, 27 Jul 1999 06:30:09 +0000 (06:30 +0000)
opcode.pl along with documentation typos (feature still needs
to be described in perlopentut.pod and summarized in
perldelta.pod)
Message-Id: <199906170439.AAA18154@monk.mps.ohio-state.edu>
Subject: [PATCH 5.00557] 3-arg open

p4raw-id: //depot/perl@3786

14 files changed:
doio.c
embed.h
embed.pl
global.sym
objXSUB.h
opcode.h
opcode.pl
perlapi.c
pod/perldiag.pod
pod/perlfunc.pod
pp_sys.c
proto.h
t/comp/proto.t
t/io/open.t

diff --git a/doio.c b/doio.c
index 880997c..32c3a04 100644 (file)
--- a/doio.c
+++ b/doio.c
 #endif
 
 bool
-Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp)
+Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
+            int rawmode, int rawperm, PerlIO *supplied_fp)
+{
+    return do_open9(gv, name, len, as_raw, rawmode, rawperm,
+                   supplied_fp, Nullsv, 0);
+}
+
+bool
+Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw,
+             int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
+             I32 num_svs)
 {
     register IO *io = GvIOn(gv);
     PerlIO *saveifp = Nullfp;
@@ -116,7 +126,7 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
        else if (IoIFP(io) != IoOFP(io)) {
            if (IoOFP(io)) {
                result = PerlIO_close(IoOFP(io));
-               PerlIO_close(IoIFP(io));        /* clear stdio, fd already closed */
+               PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
            }
            else
                result = PerlIO_close(IoIFP(io));
@@ -124,8 +134,9 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
        else
            result = PerlIO_close(IoIFP(io));
        if (result == EOF && fd > PL_maxsysfd)
-           PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n",
-             GvENAME(gv));
+           PerlIO_printf(PerlIO_stderr(),
+                         "Warning: unable to close filehandle %s properly.\n",
+                         GvENAME(gv));
        IoOFP(io) = IoIFP(io) = Nullfp;
     }
 
@@ -173,26 +184,44 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
     }
     else {
        char *myname;
+       char *type = name;
+       char *otype = name;
+       STRLEN tlen;
+       STRLEN otlen = len;
        char mode[3];           /* stdio file mode ("r\0" or "r+\0") */
        int dodup;
 
+       if (num_svs) {
+           type = name;
+           name = SvPV(svs, tlen) ;
+           len = (I32)tlen;
+       }
+
+       tlen = otlen;
        myname = savepvn(name, len);
        SAVEFREEPV(myname);
        name = myname;
-       while (len && isSPACE(name[len-1]))
-           name[--len] = '\0';
+       if (!num_svs)
+           while (tlen && isSPACE(type[tlen-1]))
+               type[--tlen] = '\0';
 
        mode[0] = mode[1] = mode[2] = '\0';
-       IoTYPE(io) = *name;
-       if (*name == '+' && len > 1 && name[len-1] != '|') { /* scary */
-           mode[1] = *name++;
-           --len;
+       IoTYPE(io) = *type;
+       if (*type == '+' && tlen > 1 && type[tlen-1] != '|') { /* scary */
+           mode[1] = *type++;
+           --tlen;
            writing = 1;
        }
 
-       if (*name == '|') {
+       if (*type == '|') {
+           if (num_svs && (tlen != 2 || type[1] != '-')) {
+             unknown_desr:
+               Perl_croak(aTHX_ "Unknown open() mode '%.*s'", otlen, otype);
+           }
            /*SUPPRESS 530*/
-           for (name++; isSPACE(*name); name++) ;
+           for (type++; isSPACE(*type); type++) ;
+           if (!num_svs)
+               name = type;
            if (*name == '\0') { /* command is missing 19990114 */
                dTHR;
                if (ckWARN(WARN_PIPE))
@@ -200,7 +229,7 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
                errno = EPIPE;
                goto say_false;
            }
-           if (strNE(name,"-"))
+           if (strNE(name,"-") || num_svs)
                TAINT_ENV();
            TAINT_PROPER("piped open");
            if (name[strlen(name)-1] == '|') {
@@ -212,18 +241,22 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
            fp = PerlProc_popen(name,"w");
            writing = 1;
        }
-       else if (*name == '>') {
+       else if (*type == '>') {
            TAINT_PROPER("open");
-           name++;
-           if (*name == '>') {
+           type++;
+           if (*type == '>') {
                mode[0] = IoTYPE(io) = 'a';
-               name++;
+               type++;
+               tlen--;
            }
            else
                mode[0] = 'w';
            writing = 1;
 
-           if (*name == '&') {
+           if (num_svs && tlen != 1)
+               goto unknown_desr;
+           if (*type == '&') {
+               name = type;
              duplicity:
                dodup = 1;
                name++;
@@ -268,35 +301,46 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
            }
            else {
                /*SUPPRESS 530*/
-               for (; isSPACE(*name); name++) ;
-               if (strEQ(name,"-")) {
+               for (; isSPACE(*type); type++) ;
+               if (strEQ(type,"-")) {
                    fp = PerlIO_stdout();
                    IoTYPE(io) = '-';
                }
                else  {
-                   fp = PerlIO_open(name,mode);
+                   fp = PerlIO_open((num_svs ? name : type), mode);
                }
            }
        }
-       else if (*name == '<') {
+       else if (*type == '<') {
+           if (num_svs && tlen != 1)
+               goto unknown_desr;
            /*SUPPRESS 530*/
-           for (name++; isSPACE(*name); name++) ;
+           for (type++; isSPACE(*type); type++) ;
            mode[0] = 'r';
-           if (*name == '&')
+           if (*type == '&') {
+               name = type;
                goto duplicity;
-           if (strEQ(name,"-")) {
+           }
+           if (strEQ(type,"-")) {
                fp = PerlIO_stdin();
                IoTYPE(io) = '-';
            }
            else
-               fp = PerlIO_open(name,mode);
+               fp = PerlIO_open((num_svs ? name : type), mode);
        }
-       else if (len > 1 && name[len-1] == '|') {
-           name[--len] = '\0';
-           while (len && isSPACE(name[len-1]))
-               name[--len] = '\0';
-           /*SUPPRESS 530*/
-           for (; isSPACE(*name); name++) ;
+       else if (tlen > 1 && type[tlen-1] == '|') {
+           if (num_svs) {
+               if (tlen != 2 || type[0] != '-')
+                   goto unknown_desr;
+           }
+           else {
+               type[--tlen] = '\0';
+               while (tlen && isSPACE(type[tlen-1]))
+                   type[--tlen] = '\0';
+               /*SUPPRESS 530*/
+               for (; isSPACE(*type); type++) ;
+               name = type;
+           }
            if (*name == '\0') { /* command is missing 19990114 */
                dTHR;
                if (ckWARN(WARN_PIPE))
@@ -304,13 +348,16 @@ Perl_do_open(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode
                errno = EPIPE;
                goto say_false;
            }
-           if (strNE(name,"-"))
+           if (strNE(name,"-") || num_svs)
                TAINT_ENV();
            TAINT_PROPER("piped open");
            fp = PerlProc_popen(name,"r");
            IoTYPE(io) = '|';
        }
        else {
+           if (num_svs)
+               goto unknown_desr;
+           name = type;
            IoTYPE(io) = '<';
            /*SUPPRESS 530*/
            for (; isSPACE(*name); name++) ;
diff --git a/embed.h b/embed.h
index 5cddd1b..849956f 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define do_join                        Perl_do_join
 #define do_kv                  Perl_do_kv
 #define do_open                        Perl_do_open
+#define do_open9               Perl_do_open9
 #define do_pipe                        Perl_do_pipe
 #define do_print               Perl_do_print
 #define do_readline            Perl_do_readline
 #define do_join(a,b,c,d)       Perl_do_join(aTHX_ a,b,c,d)
 #define do_kv()                        Perl_do_kv(aTHX)
 #define do_open(a,b,c,d,e,f,g) Perl_do_open(aTHX_ a,b,c,d,e,f,g)
+#define do_open9(a,b,c,d,e,f,g,h,i)    Perl_do_open9(aTHX_ a,b,c,d,e,f,g,h,i)
 #define do_pipe(a,b,c)         Perl_do_pipe(aTHX_ a,b,c)
 #define do_print(a,b)          Perl_do_print(aTHX_ a,b)
 #define do_readline()          Perl_do_readline(aTHX)
 #define do_kv                  Perl_do_kv
 #define Perl_do_open           CPerlObj::Perl_do_open
 #define do_open                        Perl_do_open
+#define Perl_do_open9          CPerlObj::Perl_do_open9
+#define do_open9               Perl_do_open9
 #define Perl_do_pipe           CPerlObj::Perl_do_pipe
 #define do_pipe                        Perl_do_pipe
 #define Perl_do_print          CPerlObj::Perl_do_print
index 726554e..6ea3e02 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1102,6 +1102,9 @@ p |void   |do_join        |SV* sv|SV* del|SV** mark|SV** sp
 p      |OP*    |do_kv
 p      |bool   |do_open        |GV* gv|char* name|I32 len|int as_raw \
                                |int rawmode|int rawperm|PerlIO* supplied_fp
+p      |bool   |do_open9       |GV *gv|char *name|I32 len|int as_raw \
+                               |int rawmode|int rawperm|PerlIO *supplied_fp \
+                               |SV *svs|I32 num
 p      |void   |do_pipe        |SV* sv|GV* rgv|GV* wgv
 p      |bool   |do_print       |SV* sv|PerlIO* fp
 p      |OP*    |do_readline
index fa28854..3b034e8 100644 (file)
@@ -102,6 +102,7 @@ Perl_do_shmio
 Perl_do_join
 Perl_do_kv
 Perl_do_open
+Perl_do_open9
 Perl_do_pipe
 Perl_do_print
 Perl_do_readline
index 7246cb6..7ae62f3 100644 (file)
--- a/objXSUB.h
+++ b/objXSUB.h
 #define Perl_do_open           pPerl->Perl_do_open
 #undef  do_open
 #define do_open                        Perl_do_open
+#undef  Perl_do_open9
+#define Perl_do_open9          pPerl->Perl_do_open9
+#undef  do_open9
+#define do_open9               Perl_do_open9
 #undef  Perl_do_pipe
 #define Perl_do_pipe           pPerl->Perl_do_pipe
 #undef  do_pipe
index 58d86ea..7d9bd81 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -1994,7 +1994,7 @@ EXT U32 PL_opargs[] = {
        0x00001a44,     /* dump */
        0x00001a44,     /* goto */
        0x00013644,     /* exit */
-       0x0012c81c,     /* open */
+       0x0132c81c,     /* open */
        0x0001d614,     /* close */
        0x000cc814,     /* pipe_op */
        0x0000d61c,     /* fileno */
index c26dab8..62683d7 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -568,7 +568,7 @@ exit                exit                    ck_fun          ds%     S?
 
 # I/O.
 
-open           open                    ck_fun          ist@    F S?
+open           open                    ck_fun          ist@    F S? S?
 close          close                   ck_fun          is%     F?
 pipe_op                pipe                    ck_fun          is@     F F
 
index ff5c859..192428b 100755 (executable)
--- a/perlapi.c
+++ b/perlapi.c
@@ -798,6 +798,13 @@ Perl_do_open(pTHXo_ GV* gv, char* name, I32 len, int as_raw, int rawmode, int ra
     return ((CPerlObj*)pPerl)->Perl_do_open(gv, name, len, as_raw, rawmode, rawperm, supplied_fp);
 }
 
+#undef  Perl_do_open9
+bool
+Perl_do_open9(pTHXo_ GV *gv, char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs, I32 num)
+{
+    return ((CPerlObj*)pPerl)->Perl_do_open9(gv, name, len, as_raw, rawmode, rawperm, supplied_fp, svs, num);
+}
+
 #undef  Perl_do_pipe
 void
 Perl_do_pipe(pTHXo_ SV* sv, GV* rgv, GV* wgv)
index e86bfbf..646355f 100644 (file)
@@ -2890,6 +2890,12 @@ representative, who probably put it there in the first place.
 
 (F) There are no byte-swapping functions for a machine with this byte order.
 
+=item Unknown open() mode '%s'
+
+(F) The second argument of 3-arguments open is not one from the list
+of C<L<lt>>, C<L<gt>>, C<E<gt>E<gt>>, C<+L<lt>>, C<+L<gt>>,
+C<+E<gt>E<gt>>, C<-|>, C<|-> of possible open() modes.
+
 =item Unknown process %x sent message to prime_env_iter: %s
 
 (P) An error peculiar to VMS.  Perl was reading values for %ENV before
index f9d498c..2ced382 100644 (file)
@@ -2419,6 +2419,8 @@ to be converted into a file mode, for example. (Although perl will
 automatically convert strings into numbers as needed, this automatic
 conversion assumes base 10.)
 
+=item open FILEHANDLE,MODE,EXPR
+
 =item open FILEHANDLE,EXPR
 
 =item open FILEHANDLE
@@ -2432,9 +2434,9 @@ for this purpose; so if you're using C<my>, specify EXPR in your call
 to open.)  See L<perlopentut> for a kinder, gentler explanation of opening
 files.
 
-If the filename begins with C<'E<lt>'> or nothing, the file is opened for input.
-If the filename begins with C<'E<gt>'>, the file is truncated and opened for
-output, being created if necessary.  If the filename begins with C<'E<gt>E<gt>'>,
+If MODE is C<'E<lt>'> or nothing, the file is opened for input.
+If MODE is C<'E<gt>'>, the file is truncated and opened for
+output, being created if necessary.  If MODE is C<'E<gt>E<gt>'>,
 the file is opened for appending, again being created if necessary. 
 You can put a C<'+'> in front of the C<'E<gt>'> or C<'E<lt>'> to indicate that
 you want both read and write access to the file; thus C<'+E<lt>'> is almost
@@ -2444,10 +2446,13 @@ textfiles, since they have variable length records.  See the B<-i>
 switch in L<perlrun> for a better approach.  The file is created with
 permissions of C<0666> modified by the process' C<umask> value.
 
-The prefix and the filename may be separated with spaces.
 These various prefixes correspond to the fopen(3) modes of C<'r'>, C<'r+'>, C<'w'>,
 C<'w+'>, C<'a'>, and C<'a+'>.
 
+In the 2-arguments (and 1-argument) form of the call the mode and
+filename should be concatenated (in this order), possibly separated by
+spaces.  It is possible to omit the mode if the mode is C<'E<lt>'>.
+
 If the filename begins with C<'|'>, the filename is interpreted as a
 command to which output is to be piped, and if the filename ends with a
 C<'|'>, the filename is interpreted as a command which pipes output to
@@ -2456,7 +2461,19 @@ for more examples of this.  (You are not allowed to C<open> to a command
 that pipes both in I<and> out, but see L<IPC::Open2>, L<IPC::Open3>,
 and L<perlipc/"Bidirectional Communication"> for alternatives.)
 
-Opening C<'-'> opens STDIN and opening C<'E<gt>-'> opens STDOUT.  Open returns
+If MODE is C<'|-'>, the filename is interpreted as a
+command to which output is to be piped, and if MODE is
+C<'-|'>, the filename is interpreted as a command which pipes output to
+us.  In the 2-arguments (and 1-argument) form one should replace dash
+(C<'-'>) with the command.  See L<perlipc/"Using open() for IPC">
+for more examples of this.  (You are not allowed to C<open> to a command
+that pipes both in I<and> out, but see L<IPC::Open2>, L<IPC::Open3>,
+and L<perlipc/"Bidirectional Communication"> for alternatives.)
+
+In the 2-arguments (and 1-argument) form opening C<'-'> opens STDIN
+and opening C<'E<gt>-'> opens STDOUT.  
+
+Open returns
 nonzero upon success, the undefined value otherwise.  If the C<open>
 involved a pipe, the return value happens to be the pid of the
 subprocess.
@@ -2483,16 +2500,22 @@ Examples:
     open ARTICLE or die "Can't find article $ARTICLE: $!\n";
     while (<ARTICLE>) {...
 
-    open(LOG, '>>/usr/spool/news/twitlog'); # (log is reserved)
+    open(LOG, '>>/usr/spool/news/twitlog');    # (log is reserved)
     # if the open fails, output is discarded
 
-    open(DBASE, '+<dbase.mine')                    # open for update
+    open(DBASE, '+<', 'dbase.mine')            # open for update
        or die "Can't open 'dbase.mine' for update: $!";
 
-    open(ARTICLE, "caesar <$article |")     # decrypt article
+    open(DBASE, '+<dbase.mine')                        # ditto
+       or die "Can't open 'dbase.mine' for update: $!";
+
+    open(ARTICLE, '-|', "caesar <$article")     # decrypt article
        or die "Can't start caesar: $!";
 
-    open(EXTRACT, "|sort >/tmp/Tmp$$")      # $$ is our process id
+    open(ARTICLE, "caesar <$article |")                # ditto
+       or die "Can't start caesar: $!";
+
+    open(EXTRACT, "|sort >/tmp/Tmp$$")         # $$ is our process id
        or die "Can't start sort: $!";
 
     # process argument list of files along with any includes
@@ -2522,11 +2545,13 @@ Examples:
 You may also, in the Bourne shell tradition, specify an EXPR beginning
 with C<'E<gt>&'>, in which case the rest of the string is interpreted as the
 name of a filehandle (or file descriptor, if numeric) to be
-duped and opened.  You may use C<&> after C<E<gt>>, C<E<gt>E<gt>>, C<E<lt>>, C<+E<gt>>,
-C<+E<gt>E<gt>>, and C<+E<lt>>.  The
+duped and opened.  You may use C<&> after C<E<gt>>, C<E<gt>E<gt>>,
+C<E<lt>>, C<+E<gt>>, C<+E<gt>E<gt>>, and C<+E<lt>>.  The
 mode you specify should match the mode of the original filehandle.
 (Duping a filehandle does not take into account any existing contents of
-stdio buffers.)
+stdio buffers.)  Duping file handles is not yet supported for 3-argument
+open().
+
 Here is a script that saves, redirects, and restores STDOUT and
 STDERR:
 
@@ -2534,8 +2559,8 @@ STDERR:
     open(OLDOUT, ">&STDOUT");
     open(OLDERR, ">&STDERR");
 
-    open(STDOUT, ">foo.out") || die "Can't redirect stdout";
-    open(STDERR, ">&STDOUT") || die "Can't dup stdout";
+    open(STDOUT, '>', "foo.out") || die "Can't redirect stdout";
+    open(STDERR, ">&STDOUT")     || die "Can't dup stdout";
 
     select(STDERR); $| = 1;    # make unbuffered
     select(STDOUT); $| = 1;    # make unbuffered
@@ -2558,7 +2583,8 @@ parsimonious of file descriptors.  For example:
 
     open(FILEHANDLE, "<&=$fd")
 
-If you open a pipe on the command C<'-'>, i.e., either C<'|-'> or C<'-|'>, then
+If you open a pipe on the command C<'-'>, i.e., either C<'|-'> or C<'-|'>
+with 2-arguments (or 1-argument) form of open(), then
 there is an implicit fork done, and the return value of open is the pid
 of the child within the parent process, and C<0> within the child
 process.  (Use C<defined($pid)> to determine whether the open was successful.)
@@ -2569,13 +2595,15 @@ the new STDOUT or STDIN.  Typically this is used like the normal
 piped open when you want to exercise more control over just how the
 pipe command gets executed, such as when you are running setuid, and
 don't want to have to scan shell commands for metacharacters.
-The following pairs are more or less equivalent:
+The following triples are more or less equivalent:
 
     open(FOO, "|tr '[a-z]' '[A-Z]'");
-    open(FOO, "|-") || exec 'tr', '[a-z]', '[A-Z]';
+    open(FOO, '|-', "tr '[a-z]' '[A-Z]'");
+    open(FOO, '|-') || exec 'tr', '[a-z]', '[A-Z]';
 
     open(FOO, "cat -n '$file'|");
-    open(FOO, "-|") || exec 'cat', '-n', $file;
+    open(FOO, '-|', "cat -n '$file'");
+    open(FOO, '-|') || exec 'cat', '-n', $file;
 
 See L<perlipc/"Safe Pipe Opens"> for more examples of this.
 
@@ -2587,7 +2615,8 @@ file descriptor as determined by the value of $^F.  See L<perlvar/$^F>.
 Closing any piped filehandle causes the parent process to wait for the
 child to finish, and returns the status value in C<$?>.
 
-The filename passed to open will have leading and trailing
+The filename passed to 2-argument (or 1-argument) form of open()
+will have leading and trailing
 whitespace deleted, and the normal redirection characters
 honored.  This property, known as "magic open", 
 can often be used to good effect.  A user could specify a filename of
@@ -2596,14 +2625,32 @@ F<"rsh cat file |">, or you could change certain filenames as needed:
     $filename =~ s/(.*\.gz)\s*$/gzip -dc < $1|/;
     open(FH, $filename) or die "Can't open $filename: $!";
 
-However, to open a file with arbitrary weird characters in it, it's
-necessary to protect any leading and trailing whitespace:
+Use 3-argument form to open a file with arbitrary weird characters in it,
+
+    open(FOO, '<', $file);
+
+otherwise it's necessary to protect any leading and trailing whitespace:
 
     $file =~ s#^(\s)#./$1#;
     open(FOO, "< $file\0");
 
+(this may not work on some bizzare filesystems).  One should
+conscientiously choose between the the I<magic> and 3-arguments form
+of open():
+
+    open IN, $ARGV[0];
+
+will allow the user to specify an argument of the form C<"rsh cat file |">,
+but will not work on a filename which happens to have a trailing space, while
+
+    open IN, '<', $ARGV[0];
+
+will have exactly the opposite restrictions.
+
 If you want a "real" C C<open> (see L<open(2)> on your system), then you
-should use the C<sysopen> function, which involves no such magic.  This is
+should use the C<sysopen> function, which involves no such magic (but
+may use subtly different filemodes than Perl open(), which is mapped
+to C fopen()).  This is
 another way to protect your filenames from interpretation.  For example:
 
     use IO::Handle;
index cbd5764..a849dbb 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -501,10 +501,16 @@ PP(pp_open)
     djSP; dTARGET;
     GV *gv;
     SV *sv;
+    SV *name;
+    I32 have_name = 0;
     char *tmps;
     STRLEN len;
     MAGIC *mg;
 
+    if (MAXARG > 2) {
+       name = POPs;
+       have_name = 1;
+    }
     if (MAXARG > 1)
        sv = POPs;
     if (!isGV(TOPs))
@@ -537,6 +543,8 @@ PP(pp_open)
        PUSHMARK(SP);
        XPUSHs(SvTIED_obj((SV*)gv, mg));
        XPUSHs(sv);
+       if (have_name)
+           XPUSHs(name);
        PUTBACK;
        ENTER;
        call_method("OPEN", G_SCALAR);
@@ -546,7 +554,7 @@ PP(pp_open)
     }
 
     tmps = SvPV(sv, len);
-    if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
+    if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
        PUSHi( (I32)PL_forkprocess );
     else if (PL_forkprocess == 0)              /* we are a new child */
        PUSHi(0);
diff --git a/proto.h b/proto.h
index b41868e..7bed4c7 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -115,6 +115,7 @@ VIRTUAL I32 Perl_do_shmio(pTHX_ I32 optype, SV** mark, SV** sp);
 VIRTUAL void   Perl_do_join(pTHX_ SV* sv, SV* del, SV** mark, SV** sp);
 VIRTUAL OP*    Perl_do_kv(pTHX);
 VIRTUAL bool   Perl_do_open(pTHX_ GV* gv, char* name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp);
+VIRTUAL bool   Perl_do_open9(pTHX_ GV *gv, char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs, I32 num);
 VIRTUAL void   Perl_do_pipe(pTHX_ SV* sv, GV* rgv, GV* wgv);
 VIRTUAL bool   Perl_do_print(pTHX_ SV* sv, PerlIO* fp);
 VIRTUAL OP*    Perl_do_readline(pTHX);
index ecfbec6..6381fac 100755 (executable)
@@ -384,7 +384,7 @@ print "ok ", $i++, "\n";
 print "not " if defined prototype('CORE::system');
 print "ok ", $i++, "\n";
 
-print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$';
+print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$;$';
 print "ok ", $i++, "\n";
 
 print "# CORE:Foo => ($p), \$@ => `$@'\nnot " 
index 63079c8..0154b8f 100755 (executable)
@@ -4,10 +4,11 @@
 $|  = 1;
 $^W = 1;
 
-print "1..9\n";   
+print "1..32\n";
 
 # my $file tests
 
+{
 unlink("afile") if -f "afile";     
 print "$!\nnot " unless open(my $f,"+>afile");
 print "ok 1\n";
@@ -32,4 +33,79 @@ print "ok 8\n";
 print "not " unless close($f);
 print "ok 9\n";
 unlink("afile");     
+}
+{
+print "# \$!='$!'\nnot " unless open(my $f,'>', 'afile');
+print "ok 10\n";
+print $f "a row\n";
+print "not " unless close($f);
+print "ok 11\n";
+print "not " unless -s 'afile' < 10;
+print "ok 12\n";
+}
+{
+print "# \$!='$!'\nnot " unless open(my $f,'>>', 'afile');
+print "ok 13\n";
+print $f "a row\n";
+print "not " unless close($f);
+print "ok 14\n";
+print "not " unless -s 'afile' > 10;
+print "ok 15\n";
+}
+{
+print "# \$!='$!'\nnot " unless open(my $f, '<', 'afile');
+print "ok 16\n";
+@rows = <$f>;
+print "not " unless @rows == 2;
+print "ok 17\n";
+print "not " unless close($f);
+print "ok 18\n";
+}
+{
+print "not " unless -s 'afile' < 20;
+print "ok 19\n";
+print "# \$!='$!'\nnot " unless open(my $f, '+<', 'afile');
+print "ok 20\n";
+@rows = <$f>;
+print "not " unless @rows == 2;
+print "ok 21\n";
+seek $f, 0, 1;
+print $f "yet another row\n";
+print "not " unless close($f);
+print "ok 22\n";
+print "not " unless -s 'afile' > 20;
+print "ok 23\n";
+
+unlink("afile");     
+}
+{
+print "# \$!='$!'\nnot " unless open(my $f, '-|', <<'EOC');
+perl -e "print qq(a row\n); print qq(another row\n)"
+EOC
+print "ok 24\n";
+@rows = <$f>;
+print "not " unless @rows == 2;
+print "ok 25\n";
+print "not " unless close($f);
+print "ok 26\n";
+}
+{
+print "# \$!='$!'\nnot " unless open(my $f, '|-', <<'EOC');
+perl -pe "s/^not //"
+EOC
+print "ok 27\n";
+@rows = <$f>;
+print $f "not ok 28\n";
+print $f "not ok 29\n";
+print "#\nnot " unless close($f);
+sleep 1;
+print "ok 30\n";
+}
 
+eval <<'EOE' and print "not ";
+open my $f, '<&', 'afile';
+1;
+EOE
+print "ok 31\n";
+$@ =~ /Unknown open\(\) mode \'<&\'/ or print "not ";
+print "ok 32\n";