diff options
| -rw-r--r-- | ext/XS/APItest/APItest.pm | 4 | ||||
| -rw-r--r-- | ext/XS/APItest/APItest.xs | 5 | ||||
| -rw-r--r-- | ext/XS/APItest/t/printf.t | 4 | ||||
| -rw-r--r-- | lib/open.pm | 4 | ||||
| -rw-r--r-- | perlio.c | 161 |
5 files changed, 144 insertions, 34 deletions
diff --git a/ext/XS/APItest/APItest.pm b/ext/XS/APItest/APItest.pm index bd8463bd80..581fa38240 100644 --- a/ext/XS/APItest/APItest.pm +++ b/ext/XS/APItest/APItest.pm @@ -13,10 +13,10 @@ use base qw/ DynaLoader Exporter /; # 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; diff --git a/ext/XS/APItest/APItest.xs b/ext/XS/APItest/APItest.xs index d5c6b5271c..b141252bd7 100644 --- a/ext/XS/APItest/APItest.xs +++ b/ext/XS/APItest/APItest.xs @@ -53,3 +53,8 @@ print_float(val) float val CODE: printf("%5.3f\n",val); + +void +print_flush() + CODE: + fflush(stdout); diff --git a/ext/XS/APItest/t/printf.t b/ext/XS/APItest/t/printf.t index 91f328cd5c..ef2769e8fa 100644 --- a/ext/XS/APItest/t/printf.t +++ b/ext/XS/APItest/t/printf.t @@ -33,10 +33,12 @@ print_long(4); 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; diff --git a/lib/open.pm b/lib/open.pm index d771fcb0bb..c2940931b7 100644 --- a/lib/open.pm +++ b/lib/open.pm @@ -95,8 +95,8 @@ sub import { 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"); @@ -2684,13 +2684,91 @@ PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) 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,43 +2776,68 @@ PerlIOStdio_close(pTHX_ PerlIO *f) } 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) { |