int mkstemp(char*);
#endif
+#define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags)
+
/* Call the callback or PerlIOBase, and return failure. */
#define Perl_PerlIO_or_Base(f, callback, base, failure, args) \
if (PerlIOValid(f)) { \
last = (PerlIOl **) (f);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
if (!((++f)->next)) {
- f->flags = 0;
+ f->flags = 0; /* lockcnt */
f->tab = NULL;
f->head = f;
return (PerlIO *)f;
return NULL;
}
*last = (PerlIOl*) f++;
- f->flags = 0;
+ f->flags = 0; /* lockcnt */
f->tab = NULL;
f->head = f;
return (PerlIO*) f;
if ((*l->tab->Popped) (aTHX_ f) != 0)
return;
}
- *f = l->next;
- Safefree(l);
+ if (PerlIO_lockcnt(f)) {
+ /* we're in use; defer freeing the structure */
+ PerlIOBase(f)->flags = PERLIO_F_CLEARED;
+ PerlIOBase(f)->tab = NULL;
+ }
+ else {
+ *f = l->next;
+ Safefree(l);
+ }
+
}
}
const int code = PerlIO__close(aTHX_ f);
while (PerlIOValid(f)) {
PerlIO_pop(aTHX_ f);
+ if (PerlIO_lockcnt(f))
+ /* we're in use; the 'pop' deferred freeing the structure */
+ f = PerlIONext(f);
}
return code;
}
int oflags; /* open/fcntl flags */
} PerlIOUnix;
+static void
+S_lockcnt_dec(pTHX_ const void* f)
+{
+ PerlIO_lockcnt((PerlIO*)f)--;
+}
+
+
+/* call the signal handler, and if that handler happens to clear
+ * this handle, free what we can and return true */
+
+static bool
+S_perlio_async_run(pTHX_ PerlIO* f) {
+ ENTER;
+ SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f);
+ PerlIO_lockcnt(f)++;
+ PERL_ASYNC_CHECK();
+ if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) )
+ return 0;
+ /* we've just run some perl-level code that could have done
+ * anything, including closing the file or clearing this layer.
+ * If so, free any lower layers that have already been
+ * cleared, then return an error. */
+ while (PerlIOValid(f) &&
+ (PerlIOBase(f)->flags & PERLIO_F_CLEARED))
+ {
+ const PerlIOl *l = *f;
+ *f = l->next;
+ Safefree(l);
+ }
+ return 1;
+}
+
int
PerlIOUnix_oflags(const char *mode)
{
PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
dVAR;
- const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
+ int fd;
+ if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+ return -1;
+ fd = PerlIOSelf(f, PerlIOUnix)->fd;
#ifdef PERLIO_STD_SPECIAL
if (fd == 0)
return PERLIO_STD_IN(fd, vbuf, count);
}
return len;
}
- PERL_ASYNC_CHECK();
+ /* EINTR */
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
}
/*NOTREACHED*/
}
PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
dVAR;
- const int fd = PerlIOSelf(f, PerlIOUnix)->fd;
+ int fd;
+ if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+ return -1;
+ fd = PerlIOSelf(f, PerlIOUnix)->fd;
#ifdef PERLIO_STD_SPECIAL
if (fd == 1 || fd == 2)
return PERLIO_STD_OUT(fd, vbuf, count);
}
return len;
}
- PERL_ASYNC_CHECK();
+ /* EINTR */
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
}
/*NOTREACHED*/
}
code = -1;
break;
}
- PERL_ASYNC_CHECK();
+ /* EINTR */
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
}
if (code == 0) {
PerlIOBase(f)->flags &= ~PERLIO_F_OPEN;
PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
{
dVAR;
- FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio;
+ FILE * s;
SSize_t got = 0;
+ if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+ return -1;
+ s = PerlIOSelf(f, PerlIOStdio)->stdio;
for (;;) {
if (count == 1) {
STDCHAR *buf = (STDCHAR *) vbuf;
got = -1;
if (got >= 0 || errno != EINTR)
break;
- PERL_ASYNC_CHECK();
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
SETERRNO(0,0); /* just in case */
}
return got;
{
dVAR;
SSize_t got;
+ if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+ return -1;
for (;;) {
got = PerlSIO_fwrite(vbuf, 1, count,
PerlIOSelf(f, PerlIOStdio)->stdio);
if (got >= 0 || errno != EINTR)
break;
- PERL_ASYNC_CHECK();
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
SETERRNO(0,0); /* just in case */
}
return got;
IV
PerlIOStdio_fill(pTHX_ PerlIO *f)
{
- FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
+ FILE * stdio;
int c;
PERL_UNUSED_CONTEXT;
+ if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */
+ return -1;
+ stdio = PerlIOSelf(f, PerlIOStdio)->stdio;
/*
* fflush()ing read-only streams can cause trouble on some stdio-s
break;
if (! PerlSIO_ferror(stdio) || errno != EINTR)
return EOF;
- PERL_ASYNC_CHECK();
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
SETERRNO(0,0);
}
PerlIO_flush(f);
}
if (b->ptr >= (b->buf + b->bufsiz))
- PerlIO_flush(f);
+ if (PerlIO_flush(f) == -1)
+ return -1;
}
if (PerlIOBase(f)->flags & PERLIO_F_UNBUF)
PerlIO_flush(f);
--- /dev/null
+#!./perl
+
+# If a read or write is interrupted by a signal, Perl will call the
+# signal handler and then attempt to restart the call. If the handler does
+# something nasty like close the handle or pop layers, make sure that the
+# read/write handles this gracefully (for some definition of 'graceful':
+# principally, don't segfault).
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use warnings;
+use strict;
+use Config;
+
+require './test.pl';
+
+my $piped;
+eval {
+ pipe my $in, my $out;
+ $piped = 1;
+};
+if (!$piped) {
+ skip_all('pipe not implemented');
+ exit 0;
+}
+unless (exists $Config{'d_alarm'}) {
+ skip_all('alarm not implemented');
+ exit 0;
+}
+
+# XXX for some reason the stdio layer doesn't seem to interrupt
+# write system call when the alarm triggers. This makes the tests
+# hang.
+
+if (exists $ENV{PERLIO} && $ENV{PERLIO} =~ /stdio/ ) {
+ skip_all('stdio not supported for this script');
+ exit 0;
+}
+
+my ($in, $out, $st, $sigst, $buf);
+
+plan(tests => 10);
+
+
+# make two handles that will always block
+
+sub fresh_io {
+ undef $in; undef $out; # use fresh handles each time
+ pipe $in, $out;
+ $sigst = "";
+}
+
+$SIG{PIPE} = 'IGNORE';
+
+# close during read
+
+fresh_io;
+$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
+alarm(1);
+$st = read($in, $buf, 1);
+alarm(0);
+is($sigst, 'ok', 'read/close: sig handler close status');
+ok(!$st, 'read/close: read status');
+ok(!close($in), 'read/close: close status');
+
+# die during read
+
+fresh_io;
+$SIG{ALRM} = sub { die };
+alarm(1);
+$st = eval { read($in, $buf, 1) };
+alarm(0);
+ok(!$st, 'read/die: read status');
+ok(close($in), 'read/die: close status');
+
+# close during print
+
+fresh_io;
+$SIG{ALRM} = sub { $sigst = close($out) ? "ok" : "nok" };
+$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
+select $out; $| = 1; select STDOUT;
+alarm(1);
+$st = print $out $buf;
+alarm(0);
+is($sigst, 'nok', 'print/close: sig handler close status');
+ok(!$st, 'print/close: print status');
+ok(!close($out), 'print/close: close status');
+
+# die during print
+
+fresh_io;
+$SIG{ALRM} = sub { die };
+$buf = "a" x 1_000_000 . "\n"; # bigger than any pipe buffer hopefully
+select $out; $| = 1; select STDOUT;
+alarm(1);
+$st = eval { print $out $buf };
+alarm(0);
+ok(!$st, 'print/die: print status');
+# the close will hang since there's data to flush, so use alarm
+alarm(1);
+ok(!eval {close($out)}, 'print/die: close status');
+alarm(0);
+
+# close during close
+
+# Apparently there's nothing in standard Linux that can cause an
+# EINTR in close(2); but run the code below just in case it does on some
+# platform, just to see if it segfaults.
+fresh_io;
+$SIG{ALRM} = sub { $sigst = close($in) ? "ok" : "nok" };
+alarm(1);
+close $in;
+alarm(0);
+
+# die during close
+
+fresh_io;
+$SIG{ALRM} = sub { die };
+alarm(1);
+eval { close $in };
+alarm(0);
+
+# vim: ts=4 sts=4 sw=4: