Change 18555 by jhi@kosh on 2003/01/22 12:57:20
Integrate from perlio:
[ 18539]
Try the invalidate_fileno() idea for non-leaky stdio sockets.
[ 18540]
stdio does NOT set errno==EBADF on invalidated fileno
[ 18547]
Tweak APItest for new semantics of printf.
Now printf() is always real printf() and not #define'd to
PerlIO_stdoutf() so PerlIO_flush() when STDOUT is redirected
back to original file does not affect stdout unless we are
using :stdio as implementation. So things printf()ed XS side
are not written to file (and turn up at end of test).
So add an XS function which does fflush(stdout), modify .pm
file to export it and .t file to call it.
[ 18548]
Add defined(__osf__) case to invalidate_fileno (for Tru64).
[ 18549]
Report layer name (without arg) on fail, and attempt to
autoload layer name. (Fix for [perl #20460]).
[ 18550]
#if defined(__irix__) (for stdio invalidate) from Jarkko.
Affected files ...
... //depot/perl/ext/XS/APItest/APItest.pm#3 integrate
... //depot/perl/ext/XS/APItest/APItest.xs#5 integrate
... //depot/perl/ext/XS/APItest/t/printf.t#7 integrate
... //depot/perl/lib/open.pm#42 integrate
... //depot/perl/perlio.c#199 integrate
Differences ...
==== //depot/perl/ext/XS/APItest/APItest.pm#3 (text) ====
Index: perl/ext/XS/APItest/APItest.pm
--- perl/ext/XS/APItest/APItest.pm#2~17189~ Tue Jun 11 06:55:12 2002
+++ perl/ext/XS/APItest/APItest.pm Wed Jan 22 04:57:20 2003
@@ -13,10 +13,10 @@
# Export everything since these functions are only used by a test script
our @EXPORT = qw( print_double print_int print_long
- print_float print_long_double have_long_double
+ print_float print_long_double have_long_double print_flush
);
-our $VERSION = '0.01';
+our $VERSION = '0.02';
bootstrap XS::APItest $VERSION;
==== //depot/perl/ext/XS/APItest/APItest.xs#5 (text) ====
Index: perl/ext/XS/APItest/APItest.xs
--- perl/ext/XS/APItest/APItest.xs#4~17212~ Thu Jun 13 02:29:13 2002
+++ perl/ext/XS/APItest/APItest.xs Wed Jan 22 04:57:20 2003
@@ -53,3 +53,8 @@
float val
CODE:
printf("%5.3f\n",val);
+
+void
+print_flush()
+ CODE:
+ fflush(stdout);
==== //depot/perl/ext/XS/APItest/t/printf.t#7 (text) ====
Index: perl/ext/XS/APItest/t/printf.t
--- perl/ext/XS/APItest/t/printf.t#6~17216~ Thu Jun 13 03:08:38 2002
+++ perl/ext/XS/APItest/t/printf.t Wed Jan 22 04:57:20 2003
@@ -33,10 +33,12 @@
print_float(4);
print_long_double() if $ldok; # val=7 hardwired
+print_flush();
+
# Now redirect STDOUT and read from the file
ok open(STDOUT, ">&", $oldout), "restore STDOUT";
ok open(my $foo, "<foo.out"), "open foo.out";
-print "# Test output by reading from file\n";
+#print "# Test output by reading from file\n";
# now test the output
my @output = map { chomp; $_ } <$foo>;
close $foo;
==== //depot/perl/lib/open.pm#42 (text) ====
Index: perl/lib/open.pm
--- perl/lib/open.pm#41~18217~ Fri Nov 29 04:11:28 2002
+++ perl/lib/open.pm Wed Jan 22 04:57:20 2003
@@ -95,8 +95,8 @@
my $target = $layer; # the layer name itself
$target =~ s/^(\w+)\(.+\)$/$1/; # strip parameters
- unless(PerlIO::Layer::->find($target)) {
- warnings::warnif("layer", "Unknown PerlIO layer '$layer'");
+ unless(PerlIO::Layer::->find($target,1)) {
+ warnings::warnif("layer", "Unknown PerlIO layer '$target'");
}
}
push(@val,":$layer");
==== //depot/perl/perlio.c#199 (text) ====
Index: perl/perlio.c
--- perl/perlio.c#198~18521~ Mon Jan 20 09:37:35 2003
+++ perl/perlio.c Wed Jan 22 04:57:20 2003
@@ -2684,13 +2684,91 @@
return f;
}
+static int
+PerlIOStdio_invalidate_fileno(pTHX_ FILE *f)
+{
+ /* XXX this could use PerlIO_canset_fileno() and
+ * PerlIO_set_fileno() support from Configure
+ */
+# if defined(__GLIBC__)
+ /* There may be a better way for GLIBC:
+ - libio.h defines a flag to not close() on cleanup
+ */
+ f->_fileno = -1;
+ return 1;
+# elif defined(__sun__)
+# if defined(_LP64)
+ /* On solaris, if _LP64 is defined, the FILE structure is this:
+ *
+ * struct FILE {
+ * long __pad[16];
+ * };
+ *
+ * It turns out that the fd is stored in the top 32 bits of
+ * file->__pad[4]. The lower 32 bits contain flags. file->pad[5] appears
+ * to contain a pointer or offset into another structure. All the
+ * remaining fields are zero.
+ *
+ * We set the top bits to -1 (0xFFFFFFFF).
+ */
+ f->__pad[4] |= 0xffffffff00000000L;
+ assert(fileno(f) == 0xffffffff);
+# else /* !defined(_LP64) */
+ /* _file is just a unsigned char :-(
+ Not clear why we dup() rather than using -1
+ even if that would be treated as 0xFF - so will
+ a dup fail ...
+ */
+ f->_file = PerlLIO_dup(fd);
+# endif /* defined(_LP64) */
+ return 1;
+# elif defined(__hpux)
+ f->__fileH = 0xff;
+ f->__fileL = 0xff;
+ return 1;
+ /* Next one ->_file seems to be a reasonable fallback, i.e. if
+ your platform does not have special entry try this one.
+ [For OSF only have confirmation for Tru64 (alpha)
+ but assume other OSFs will be similar.]
+ */
+# elif defined(_AIX) || defined(__osf__) || defined(__irix__)
+ f->_file = -1;
+ return 1;
+# elif defined(__FreeBSD__)
+ /* There may be a better way on FreeBSD:
+ - we could insert a dummy func in the _close function entry
+ f->_close = (int (*)(void *)) dummy_close;
+ */
+ f->_file = -1;
+ return 1;
+# elif defined(__CYGWIN__)
+ /* There may be a better way on CYGWIN:
+ - we could insert a dummy func in the _close function entry
+ f->_close = (int (*)(void *)) dummy_close;
+ */
+ f->_file = -1;
+ return 1;
+# elif defined(WIN32)
+# if defined(__BORLANDC__)
+ f->fd = PerlLIO_dup(fileno(f));
+# else
+ f->_file = -1;
+# endif
+ return 1;
+# else
+#if 0
+ /* Sarathy's code did this - we fall back to a dup/dup2 hack
+ (which isn't thread safe) instead
+ */
+# error "Don't know how to set FILE.fileno on your platform"
+#endif
+ return 0;
+# endif
+}
+
IV
PerlIOStdio_close(pTHX_ PerlIO *f)
{
-#ifdef SOCKS5_VERSION_NAME
- int optval;
- Sock_size_t optlen = sizeof(int);
-#endif
FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
if (!stdio) {
errno = EBADF;
@@ -2698,42 +2776,67 @@
}
else {
int fd = fileno(stdio);
- int dupfd = -1;
+ int socksfd = 0;
+ int invalidate = 0;
IV result;
+ int saveerr = 0;
+ int dupfd = 0;
+#ifdef SOCKS5_VERSION_NAME
+ /* Socks lib overrides close() but stdio isn't linked to
+ that library (though we are) - so we must call close()
+ on sockets on stdio's behalf.
+ */
+ int optval;
+ Sock_size_t optlen = sizeof(int);
+ if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) {
+ socksfd = 1;
+ invalidate = 1;
+ }
+#endif
if (PerlIOUnix_refcnt_dec(fd) > 0) {
/* File descriptor still in use */
- if (fd < 3) {
- /* For STD* handles don't close the stdio at all */
+ invalidate = 1;
+ socksfd = 0;
+ }
+ if (invalidate) {
+ /* For STD* handles don't close the stdio at all
+ this is because we have shared the FILE * too
+ */
+ if (stdio == stdin) {
+ /* Some stdios are buggy fflush-ing inputs */
+ return 0;
+ }
+ else if (stdio == stdout || stdio == stderr) {
return PerlIO_flush(f);
}
- else {
- /* Tricky - must fclose(stdio) to free memory but not close(fd) */
+ /* Tricky - must fclose(stdio) to free memory but not close(fd)
+ Use Sarathy's trick from maint-5.6 to invalidate the
+ fileno slot of the FILE *
+ */
+ saveerr = errno;
+ if (!(invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio))) {
dupfd = PerlLIO_dup(fd);
}
- }
- result = (
-#ifdef SOCKS5_VERSION_NAME
- (getsockopt
- (PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *) &optval,
- &optlen) <
- 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f))
-#else
- PerlSIO_fclose(stdio)
-#endif
- );
- if (dupfd >= 0) {
- /* We need to restore fd from the saved copy */
- if (PerlLIO_dup2(dupfd,fd) != fd)
- result = -1;
- if (PerlLIO_close(dupfd) != 0)
- result = -1;
+ }
+ result = PerlSIO_fclose(stdio);
+ /* We treat error from stdio as success if we invalidated
+ errno may NOT be expected EBADF
+ */
+ if (invalidate && result != 0) {
+ errno = saveerr;
+ result = 0;
+ }
+ if (socksfd) {
+ /* in SOCKS case let close() determine return value */
+ result = close(fd);
+ }
+ if (dupfd) {
+ PerlLIO_dup2(dupfd,fd);
+ close(dupfd);
}
return result;
}
-
}
-
-
SSize_t
PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
End of Patch.
