ensure implicitly closed handles don't set $? or $!

p4raw-id: //depot/perl@3752

diff --git a/doio.c b/doio.c
index d55acb1..880997c 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -675,7 +675,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
        }
        return FALSE;
     }
-    retval = io_close(io);
+    retval = io_close(io, not_implicit);
     if (not_implicit) {
        IoLINES(io) = 0;
        IoPAGE(io) = 0;
@@ -686,7 +686,7 @@ Perl_do_close(pTHX_ GV *gv, bool not_implicit)
 }
 
 bool
-Perl_io_close(pTHX_ IO *io)
+Perl_io_close(pTHX_ IO *io, bool not_implicit)
 {
     bool retval = FALSE;
     int status;
@@ -694,8 +694,13 @@ Perl_io_close(pTHX_ IO *io)
     if (IoIFP(io)) {
        if (IoTYPE(io) == '|') {
            status = PerlProc_pclose(IoIFP(io));
-           STATUS_NATIVE_SET(status);
-           retval = (STATUS_POSIX == 0);
+           if (not_implicit) {
+               STATUS_NATIVE_SET(status);
+               retval = (STATUS_POSIX == 0);
+           }
+           else {
+               retval = (status != -1);
+           }
        }
        else if (IoTYPE(io) == '-')
            retval = TRUE;
@@ -709,7 +714,7 @@ Perl_io_close(pTHX_ IO *io)
        }
        IoOFP(io) = IoIFP(io) = Nullfp;
     }
-    else {
+    else if (not_implicit) {
        SETERRNO(EBADF,SS$_IVCHAN);
     }
 

diff --git a/embed.h b/embed.h
index f2b0bfa..1c49a76 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1531,7 +1531,7 @@
 #define init_stacks()          Perl_init_stacks(aTHX)
 #define intro_my()             Perl_intro_my(aTHX)
 #define instr(a,b)             Perl_instr(aTHX_ a,b)
-#define io_close(a)            Perl_io_close(aTHX_ a)
+#define io_close(a,b)          Perl_io_close(aTHX_ a,b)
 #define invert(a)              Perl_invert(aTHX_ a)
 #define is_uni_alnum(a)                Perl_is_uni_alnum(aTHX_ a)
 #define is_uni_alnumc(a)       Perl_is_uni_alnumc(aTHX_ a)

diff --git a/embed.pl b/embed.pl
index cca15c4..c311f9a 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1196,7 +1196,7 @@ p |void   |init_debugger
 p      |void   |init_stacks
 p      |U32    |intro_my
 p      |char*  |instr          |const char* big|const char* little
-p      |bool   |io_close       |IO* io
+p      |bool   |io_close       |IO* io|bool not_implicit
 p      |OP*    |invert         |OP* cmd
 p      |bool   |is_uni_alnum   |U32 c
 p      |bool   |is_uni_alnumc  |U32 c

diff --git a/perlapi.c b/perlapi.c
index a7934fb..78d1bce 100755 (executable)
--- a/perlapi.c
+++ b/perlapi.c
@@ -1379,9 +1379,9 @@ Perl_instr(pTHXo_ const char* big, const char* little)
 
 #undef  Perl_io_close
 bool
-Perl_io_close(pTHXo_ IO* io)
+Perl_io_close(pTHXo_ IO* io, bool not_implicit)
 {
-    return ((CPerlObj*)pPerl)->Perl_io_close(io);
+    return ((CPerlObj*)pPerl)->Perl_io_close(io, not_implicit);
 }
 
 #undef  Perl_invert

diff --git a/proto.h b/proto.h
index 291989d..6464f5f 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -202,7 +202,7 @@ VIRTUAL void        Perl_init_debugger(pTHX);
 VIRTUAL void   Perl_init_stacks(pTHX);
 VIRTUAL U32    Perl_intro_my(pTHX);
 VIRTUAL char*  Perl_instr(pTHX_ const char* big, const char* little);
-VIRTUAL bool   Perl_io_close(pTHX_ IO* io);
+VIRTUAL bool   Perl_io_close(pTHX_ IO* io, bool not_implicit);
 VIRTUAL OP*    Perl_invert(pTHX_ OP* cmd);
 VIRTUAL bool   Perl_is_uni_alnum(pTHX_ U32 c);
 VIRTUAL bool   Perl_is_uni_alnumc(pTHX_ U32 c);

diff --git a/sv.c b/sv.c
index 8550332..0c48260 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2979,7 +2979,7 @@ Perl_sv_clear(pTHX_ register SV *sv)
            IoIFP(sv) != PerlIO_stdout() &&
            IoIFP(sv) != PerlIO_stderr())
        {
-         io_close((IO*)sv);
+           io_close((IO*)sv, FALSE);
        }
        if (IoDIRP(sv)) {
            PerlDir_close(IoDIRP(sv));

diff --git a/t/io/pipe.t b/t/io/pipe.t
index 37949c4..826cf74 100755 (executable)
--- a/t/io/pipe.t
+++ b/t/io/pipe.t
@@ -1,7 +1,5 @@
 #!./perl
 
-# $RCSfile: pipe.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:31 $
-
 BEGIN {
     chdir 't' if -d 't';
     unshift @INC, '../lib';
@@ -13,7 +11,7 @@ BEGIN {
 }
 
 $| = 1;
-print "1..14\n";
+print "1..15\n";
 
 # External program 'tr' assumed.
 open(PIPE, "|-") || (exec 'tr', 'YX', 'ko');
@@ -158,3 +156,16 @@ if ($? == 37*256 && $wait == $zombie && ! $!) {
   print (((open P, "|    " ) ? "not " : ""), "ok 13\n");
   print (((open P, "     |" ) ? "not " : ""), "ok 14\n");
 }
+
+# check that status is unaffected by implicit close
+{
+    local(*NIL);
+    open NIL, '|exit 23;' or die "fork failed: $!";
+    $? = 42;
+    # NIL implicitly closed here
+}
+if ($? != 42) {
+    print "# status $?, expected 42\nnot ";
+}
+print "ok 15\n";
+$? = 0;