From: Gurusamy Sarathy <gsar@cpan.org>
Date: Mon, 26 Jul 1999 02:11:31 +0000 (+0000)
Subject: ensure implicitly closed handles don't set $? or $!
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f2b5be74500fffd3dc232fca7cb3c51bc3b9abf9;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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;