Dave Mitchell
2010-11-26 16:05:36 UTC
In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/abf9167d3fff002ddaed53abb44d638387bca978?hp=507a68aa3c321b422f95b772611c878ce13952df>
- Log -----------------------------------------------------------------
commit abf9167d3fff002ddaed53abb44d638387bca978
Author: David Mitchell <***@iabyn.com>
Date: Mon Nov 22 19:18:49 2010 +0000
Make PerlIO marginally reentrant
Currently if an operation on a file handle is interrupted, and if
the signal handler accesses that same file handle (e.g. closes it),
then perl will crash. See [perl #75556].
This commit provides some basic infrastructure to avoid segfaults.
Basically it adds a lock count field to each handle (by re-purposing the
unused flags field in the PL_perlio array), then each time a signal
handler is called, the count is incremented. Then various parts of PerlIO
use a positive count to change behaviour. Most importantly, when layers
are popped, the PerlIOl structure is cleared, but not freed, and is left
in the chain of layers. This means that callers still holding pointers to
the various layers won't access freed structures. It does however mean
that PerlIOl structs may be leaked, and possibly slots in PL_perlio. But
this is better than crashing.
Not much has been done to give sensible behaviour on re-entrancy; for
example, a buffer that has already been written once might get written
again. Fixing this sort of thing would require a large-scale audit of
perlio.c.
M MANIFEST
M perl.h
M perlio.c
M perliol.h
M pod/perlipc.pod
A t/io/eintr.t
commit cc6623a84b782d30463b9046c2916f35064a7e3f
Author: David Mitchell <***@iabyn.com>
Date: Fri Nov 19 17:23:17 2010 +0000
perlio: always guard against null function table
In some places it already checks for a null tab field; extend that
coverage. This is in preparation for a commit which may leave active
layers with a null tab field.
M perlio.c
commit 8995e67d43b457d0463f0581e10b390bc378c894
Author: David Mitchell <***@iabyn.com>
Date: Wed Nov 17 16:29:04 2010 +0000
add PerlIO_init_table() to initialise PL_perio
Previously, the PL_perio table was initialised by calling PerlIO_allocate,
and throwing away the result. Since a slot with a null ->next was regarded
as freed, the next call to PerlIO_allocate would reuse that slot, which is
important, as STDIN etc are expected to occupy slots 1,2,3.
Once reference counting of the slots is introduced, however, the first
slot will leak, and STDIN etc will be assigned to the wrong slots. So do it
properly now.
M perlio.c
commit 16865ff7e97c2532fd2001d68cf18909acb0d838
Author: David Mitchell <***@iabyn.com>
Date: Tue Nov 16 22:44:34 2010 +0000
add 'head' field to PerlIOl struct
This allows any layer to find the top of the layer stack,
or more specifically, the entry in PL_perlio that points to
the top.
Needed for the next commit, which will implement a reference counting
scheme.
There's currently a bug in MakeMaker which causes several extensions to
miss the dependency on perliol.h having changed, so this commit includes
a gratuitous whitespace change to perl.h to hopefully force recompilation.
M perl.h
M perlio.c
M perliol.h
commit 303f2dc3d5bda8ee962db318dd53acb167c07485
Author: David Mitchell <***@iabyn.com>
Date: Mon Nov 15 17:06:37 2010 +0000
make PL_perlio an array of PerlIOl, not PerlIO *
Layers in PerlIO are implemented as a linked list of PerlIOl structs;
eaxch one has a 'next' field pointing to the next layer. Now here's the
clever bit: When PerlIO* pointers are passed around to refer to a
particular handle, these are actually pointers to the 'next' field of the
*parent* layer (so to access the flags field say of a PerlIOl, you have to
double-defref it, e.g. (*f)->flags). The big advantage of this is that
it's easy for a layer to pop itself; when you call PerlIO_pop(f), f is a
pointer to the parent's 'next' field, so pop(f) can just do
*f = (*f)->next.
This means that there has to be a fake 'next' field above the topmost
layer. This is where PL_perlio comes in: it's a pointer to an arena of
arrays of pointers, each one capable of pointing to a PerlIOl structure.
When a new handle is created, a spare arena slot is grabbed, and the
address of that slot is returned. This also allows for a handle with no
layers.
What this commit does is change PL_perlio from being an array of
PerlIO* into an array of PerlIOl structures - i.e. each element in the
array goes from being a single pointer, to having several fields. These
will be made used of in follow-up commits.
M intrpvar.h
M perlio.c
M perliol.h
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
intrpvar.h | 2 +-
perlio.c | 253 ++++++++++++++++++++++++++++++++++++++++--------------
perliol.h | 4 +-
pod/perlipc.pod | 6 ++
t/io/eintr.t | 126 +++++++++++++++++++++++++++
6 files changed, 324 insertions(+), 68 deletions(-)
create mode 100644 t/io/eintr.t
diff --git a/MANIFEST b/MANIFEST
index 8a72a8a..63bf429 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4481,6 +4481,7 @@ t/io/crlf.t See if :crlf works
t/io/crlf_through.t See if pipe passes data intact with :crlf
t/io/defout.t See if PL_defoutgv works
t/io/dup.t See if >& works right
+t/io/eintr.t See if code called during EINTR is safe
t/io/errnosig.t Test case for restoration $! when leaving signal handlers
t/io/errno.t See if $! is correctly set
t/io/fflush.t See if auto-flush on fork/exec/system/qx works
diff --git a/intrpvar.h b/intrpvar.h
index d10feec..0c90a9f 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -658,7 +658,7 @@ PERLVAR(Icustom_op_names, HV*) /* Names of user defined ops */
PERLVAR(Icustom_op_descs, HV*) /* Descriptions of user defined ops */
#ifdef PERLIO_LAYERS
-PERLVARI(Iperlio, PerlIO *,NULL)
+PERLVARI(Iperlio, PerlIOl *,NULL)
PERLVARI(Iknown_layers, PerlIO_list_t *,NULL)
PERLVARI(Idef_layerlist, PerlIO_list_t *,NULL)
#endif
diff --git a/perlio.c b/perlio.c
index 4620ecd..cd58448 100644
--- a/perlio.c
+++ b/perlio.c
@@ -70,6 +70,8 @@
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)) { \
@@ -527,11 +529,47 @@ PerlIO_debug(const char *fmt, ...)
* Inner level routines
*/
+/* check that the head field of each layer points back to the head */
+
+#ifdef DEBUGGING
+# define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
+static void
+PerlIO_verify_head(pTHX_ PerlIO *f)
+{
+ PerlIOl *head, *p;
+ int seen = 0;
+ if (!PerlIOValid(f))
+ return;
+ p = head = PerlIOBase(f)->head;
+ assert(p);
+ do {
+ assert(p->head == head);
+ if (p == (PerlIOl*)f)
+ seen = 1;
+ p = p->next;
+ } while (p);
+ assert(seen);
+}
+#else
+# define VERIFY_HEAD(f)
+#endif
+
+
/*
* Table of pointers to the PerlIO structs (malloc'ed)
*/
#define PERLIO_TABLE_SIZE 64
+static void
+PerlIO_init_table(pTHX)
+{
+ if (PL_perlio)
+ return;
+ Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
+}
+
+
+
PerlIO *
PerlIO_allocate(pTHX)
{
@@ -539,24 +577,30 @@ PerlIO_allocate(pTHX)
/*
* Find a free slot in the table, allocating new table as necessary
*/
- PerlIO **last;
- PerlIO *f;
+ PerlIOl **last;
+ PerlIOl *f;
last = &PL_perlio;
while ((f = *last)) {
int i;
- last = (PerlIO **) (f);
+ last = (PerlIOl **) (f);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- if (!*++f) {
- return f;
+ if (!((++f)->next)) {
+ f->flags = 0; /* lockcnt */
+ f->tab = NULL;
+ f->head = f;
+ return (PerlIO *)f;
}
}
}
- Newxz(f,PERLIO_TABLE_SIZE,PerlIO);
+ Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
if (!f) {
return NULL;
}
- *last = f;
- return f + 1;
+ *last = (PerlIOl*) f++;
+ f->flags = 0; /* lockcnt */
+ f->tab = NULL;
+ f->head = f;
+ return (PerlIO*) f;
}
#undef PerlIO_fdupopen
@@ -579,16 +623,16 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
}
void
-PerlIO_cleantable(pTHX_ PerlIO **tablep)
+PerlIO_cleantable(pTHX_ PerlIOl **tablep)
{
- PerlIO * const table = *tablep;
+ PerlIOl * const table = *tablep;
if (table) {
int i;
- PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
+ PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
- PerlIO * const f = table + i;
- if (*f) {
- PerlIO_close(f);
+ PerlIOl * const f = table + i;
+ if (f->next) {
+ PerlIO_close(&(f->next));
}
}
Safefree(table);
@@ -669,19 +713,19 @@ void
PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
{
#ifdef USE_ITHREADS
- PerlIO **table = &proto->Iperlio;
- PerlIO *f;
+ PerlIOl **table = &proto->Iperlio;
+ PerlIOl *f;
PL_perlio = NULL;
PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
- PerlIO_allocate(aTHX); /* root slot is never used */
+ PerlIO_init_table(aTHX);
PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
while ((f = *table)) {
int i;
- table = (PerlIO **) (f++);
+ table = (PerlIOl **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- if (*f) {
- (void) fp_dup(f, 0, param);
+ if (f->next) {
+ (void) fp_dup(&(f->next), 0, param);
}
f++;
}
@@ -697,19 +741,19 @@ void
PerlIO_destruct(pTHX)
{
dVAR;
- PerlIO **table = &PL_perlio;
- PerlIO *f;
+ PerlIOl **table = &PL_perlio;
+ PerlIOl *f;
#ifdef USE_ITHREADS
PerlIO_debug("Destruct %p\n",(void*)aTHX);
#endif
while ((f = *table)) {
int i;
- table = (PerlIO **) (f++);
+ table = (PerlIOl **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- PerlIO *x = f;
+ PerlIO *x = &(f->next);
const PerlIOl *l;
while ((l = *x)) {
- if (l->tab->kind & PERLIO_K_DESTRUCT) {
+ if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
PerlIO_debug("Destruct popping %s\n", l->tab->name);
PerlIO_flush(x);
PerlIO_pop(aTHX_ x);
@@ -727,9 +771,11 @@ void
PerlIO_pop(pTHX_ PerlIO *f)
{
const PerlIOl *l = *f;
+ VERIFY_HEAD(f);
if (l) {
- PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
- if (l->tab->Popped) {
+ PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
+ l->tab ? l->tab->name : "(Null)");
+ if (l->tab && l->tab->Popped) {
/*
* If popped returns non-zero do not free its layer structure
* it has either done so itself, or it is shared and still in
@@ -738,8 +784,16 @@ PerlIO_pop(pTHX_ 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);
+ }
+
}
}
@@ -1200,7 +1254,7 @@ PerlIO_stdstreams(pTHX)
{
dVAR;
if (!PL_perlio) {
- PerlIO_allocate(aTHX);
+ PerlIO_init_table(aTHX);
PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
@@ -1210,6 +1264,7 @@ PerlIO_stdstreams(pTHX)
PerlIO *
PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
{
+ VERIFY_HEAD(f);
if (tab->fsize != sizeof(PerlIO_funcs)) {
Perl_croak( aTHX_
"%s (%d) does not match %s (%d)",
@@ -1232,6 +1287,7 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
if (l) {
l->next = *f;
l->tab = (PerlIO_funcs*) tab;
+ l->head = ((PerlIOl*)f)->head;
*f = l;
PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
(void*)f, tab->name,
@@ -1264,7 +1320,7 @@ PerlIOBase_binmode(pTHX_ PerlIO *f)
{
if (PerlIOValid(f)) {
/* Is layer suitable for raw stream ? */
- if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
+ if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
/* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
}
@@ -1293,7 +1349,7 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
*/
t = f;
while (t && (l = *t)) {
- if (l->tab->Binmode) {
+ if (l->tab && l->tab->Binmode) {
/* Has a handler - normal case */
if ((*l->tab->Binmode)(aTHX_ t) == 0) {
if (*t == l) {
@@ -1311,7 +1367,8 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
}
}
if (PerlIOValid(f)) {
- PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
+ PerlIO_debug(":raw f=%p :%s\n", (void*)f,
+ PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
return 0;
}
}
@@ -1364,7 +1421,8 @@ int
PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
{
PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
- (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
+ (PerlIOBase(f) && PerlIOBase(f)->tab) ?
+ PerlIOBase(f)->tab->name : "(Null)",
iotype, mode, (names) ? names : "(Null)");
if (names) {
@@ -1391,7 +1449,9 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
/* Perhaps we should turn on bottom-most aware layer
e.g. Ilya's idea that UNIX TTY could serve
*/
- if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
+ if (PerlIOBase(f)->tab &&
+ PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
+ {
if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
/* Not in text mode - flush any pending stuff and flip it */
PerlIO_flush(f);
@@ -1438,6 +1498,9 @@ Perl_PerlIO_close(pTHX_ PerlIO *f)
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;
}
@@ -1563,7 +1626,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
layera = PerlIO_list_alloc(aTHX);
while (l) {
SV *arg = NULL;
- if (l->tab->Getarg)
+ if (l->tab && l->tab->Getarg)
arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
PerlIO_list_push(aTHX_ layera, l->tab,
(arg) ? arg : &PL_sv_undef);
@@ -1689,15 +1752,16 @@ Perl_PerlIO_flush(pTHX_ PerlIO *f)
* things on fflush(NULL), but should we be bound by their design
* decisions? --jhi
*/
- PerlIO **table = &PL_perlio;
+ PerlIOl **table = &PL_perlio;
+ PerlIOl *ff;
int code = 0;
- while ((f = *table)) {
+ while ((ff = *table)) {
int i;
- table = (PerlIO **) (f++);
+ table = (PerlIOl **) (ff++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- if (*f && PerlIO_flush(f) != 0)
+ if (ff->next && PerlIO_flush(&(ff->next)) != 0)
code = -1;
- f++;
+ ff++;
}
}
return code;
@@ -1708,17 +1772,17 @@ void
PerlIOBase_flush_linebuf(pTHX)
{
dVAR;
- PerlIO **table = &PL_perlio;
- PerlIO *f;
+ PerlIOl **table = &PL_perlio;
+ PerlIOl *f;
while ((f = *table)) {
int i;
- table = (PerlIO **) (f++);
+ table = (PerlIOl **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- if (*f
- && (PerlIOBase(f)->
+ if (f->next
+ && (PerlIOBase(&(f->next))->
flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
== (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
- PerlIO_flush(f);
+ PerlIO_flush(&(f->next));
f++;
}
}
@@ -1868,7 +1932,7 @@ PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
PERL_UNUSED_ARG(mode);
PERL_UNUSED_ARG(arg);
if (PerlIOValid(f)) {
- if (tab->kind & PERLIO_K_UTF8)
+ if (tab && tab->kind & PERLIO_K_UTF8)
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
else
PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
@@ -2037,7 +2101,7 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
- if (tab->Set_ptrcnt != NULL)
+ if (tab && tab->Set_ptrcnt != NULL)
l->flags |= PERLIO_F_FASTGETS;
if (mode) {
if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
@@ -2266,8 +2330,9 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
SV *arg = NULL;
char buf[8];
PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
- self->name, (void*)f, (void*)o, (void*)param);
- if (self->Getarg)
+ self ? self->name : "(Null)",
+ (void*)f, (void*)o, (void*)param);
+ if (self && self->Getarg)
arg = (*self->Getarg)(aTHX_ o, param, flags);
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
@@ -2466,6 +2531,38 @@ typedef struct {
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)
{
@@ -2598,7 +2695,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
int perm, PerlIO *f, int narg, SV **args)
{
if (PerlIOValid(f)) {
- if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
+ if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
(*PerlIOBase(f)->tab->Close)(aTHX_ f);
}
if (narg > 0) {
@@ -2669,7 +2766,10 @@ SSize_t
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);
@@ -2692,7 +2792,9 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
}
return len;
}
- PERL_ASYNC_CHECK();
+ /* EINTR */
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
}
/*NOTREACHED*/
}
@@ -2701,7 +2803,10 @@ SSize_t
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);
@@ -2716,7 +2821,9 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
}
return len;
}
- PERL_ASYNC_CHECK();
+ /* EINTR */
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
}
/*NOTREACHED*/
}
@@ -2751,7 +2858,9 @@ PerlIOUnix_close(pTHX_ PerlIO *f)
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;
@@ -3224,8 +3333,11 @@ SSize_t
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;
@@ -3245,7 +3357,8 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
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;
@@ -3314,12 +3427,15 @@ PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
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;
@@ -3481,9 +3597,12 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
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
@@ -3498,7 +3617,8 @@ PerlIOStdio_fill(pTHX_ PerlIO *f)
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);
}
@@ -4030,7 +4150,8 @@ PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
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);
@@ -4988,7 +5109,7 @@ Perl_PerlIO_stdin(pTHX)
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
- return &PL_perlio[1];
+ return (PerlIO*)&PL_perlio[1];
}
PerlIO *
@@ -4998,7 +5119,7 @@ Perl_PerlIO_stdout(pTHX)
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
- return &PL_perlio[2];
+ return (PerlIO*)&PL_perlio[2];
}
PerlIO *
@@ -5008,7 +5129,7 @@ Perl_PerlIO_stderr(pTHX)
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
- return &PL_perlio[3];
+ return (PerlIO*)&PL_perlio[3];
}
/*--------------------------------------------------------------------------------------*/
diff --git a/perliol.h b/perliol.h
index 6b714bb..019fa8c 100644
--- a/perliol.h
+++ b/perliol.h
@@ -67,6 +67,7 @@ struct _PerlIO {
PerlIOl *next; /* Lower layer */
PerlIO_funcs *tab; /* Functions for this layer */
U32 flags; /* Various flags for state */
+ PerlIOl *head; /* our ultimate parent pointer */
};
/*--------------------------------------------------------------------------------------*/
@@ -89,6 +90,7 @@ struct _PerlIO {
#define PERLIO_F_FASTGETS 0x00400000
#define PERLIO_F_TTY 0x00800000
#define PERLIO_F_NOTREG 0x01000000
+#define PERLIO_F_CLEARED 0x02000000 /* layer cleared but not freed */
#define PerlIOBase(f) (*(f))
#define PerlIOSelf(f,type) ((type *)PerlIOBase(f))
@@ -150,7 +152,7 @@ PERL_EXPORT_C PerlIO_funcs *PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, Pe
PERL_EXPORT_C SV *PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param);
-PERL_EXPORT_C void PerlIO_cleantable(pTHX_ PerlIO **tablep);
+PERL_EXPORT_C void PerlIO_cleantable(pTHX_ PerlIOl **tablep);
PERL_EXPORT_C SV * PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab);
PERL_EXPORT_C void PerlIO_default_buffer(pTHX_ PerlIO_list_t *av);
PERL_EXPORT_C void PerlIO_stdstreams(pTHX);
diff --git a/pod/perlipc.pod b/pod/perlipc.pod
index 8aa5005..5e9f408 100644
--- a/pod/perlipc.pod
+++ b/pod/perlipc.pod
@@ -408,6 +408,12 @@ operation.)
The default in Perl 5.7.3 and later is to automatically use
the C<:perlio> layer.
+Note that it is not advisable to access a file handle within a signal
+handler where that signal has interrupted an I/O operation on that same
+handle. While perl will at least try hard not to crash, there are no
+guarantees of data integrity; for example, some data might get dropped or
+written twice.
+
Some networking library functions like gethostbyname() are known to have
their own implementations of timeouts which may conflict with your
timeouts. If you have problems with such functions, try using the POSIX
diff --git a/t/io/eintr.t b/t/io/eintr.t
new file mode 100644
index 0000000..3b6b0a4
--- /dev/null
+++ b/t/io/eintr.t
@@ -0,0 +1,126 @@
+#!./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:
--
Perl5 Master Repository
<http://perl5.git.perl.org/perl.git/commitdiff/abf9167d3fff002ddaed53abb44d638387bca978?hp=507a68aa3c321b422f95b772611c878ce13952df>
- Log -----------------------------------------------------------------
commit abf9167d3fff002ddaed53abb44d638387bca978
Author: David Mitchell <***@iabyn.com>
Date: Mon Nov 22 19:18:49 2010 +0000
Make PerlIO marginally reentrant
Currently if an operation on a file handle is interrupted, and if
the signal handler accesses that same file handle (e.g. closes it),
then perl will crash. See [perl #75556].
This commit provides some basic infrastructure to avoid segfaults.
Basically it adds a lock count field to each handle (by re-purposing the
unused flags field in the PL_perlio array), then each time a signal
handler is called, the count is incremented. Then various parts of PerlIO
use a positive count to change behaviour. Most importantly, when layers
are popped, the PerlIOl structure is cleared, but not freed, and is left
in the chain of layers. This means that callers still holding pointers to
the various layers won't access freed structures. It does however mean
that PerlIOl structs may be leaked, and possibly slots in PL_perlio. But
this is better than crashing.
Not much has been done to give sensible behaviour on re-entrancy; for
example, a buffer that has already been written once might get written
again. Fixing this sort of thing would require a large-scale audit of
perlio.c.
M MANIFEST
M perl.h
M perlio.c
M perliol.h
M pod/perlipc.pod
A t/io/eintr.t
commit cc6623a84b782d30463b9046c2916f35064a7e3f
Author: David Mitchell <***@iabyn.com>
Date: Fri Nov 19 17:23:17 2010 +0000
perlio: always guard against null function table
In some places it already checks for a null tab field; extend that
coverage. This is in preparation for a commit which may leave active
layers with a null tab field.
M perlio.c
commit 8995e67d43b457d0463f0581e10b390bc378c894
Author: David Mitchell <***@iabyn.com>
Date: Wed Nov 17 16:29:04 2010 +0000
add PerlIO_init_table() to initialise PL_perio
Previously, the PL_perio table was initialised by calling PerlIO_allocate,
and throwing away the result. Since a slot with a null ->next was regarded
as freed, the next call to PerlIO_allocate would reuse that slot, which is
important, as STDIN etc are expected to occupy slots 1,2,3.
Once reference counting of the slots is introduced, however, the first
slot will leak, and STDIN etc will be assigned to the wrong slots. So do it
properly now.
M perlio.c
commit 16865ff7e97c2532fd2001d68cf18909acb0d838
Author: David Mitchell <***@iabyn.com>
Date: Tue Nov 16 22:44:34 2010 +0000
add 'head' field to PerlIOl struct
This allows any layer to find the top of the layer stack,
or more specifically, the entry in PL_perlio that points to
the top.
Needed for the next commit, which will implement a reference counting
scheme.
There's currently a bug in MakeMaker which causes several extensions to
miss the dependency on perliol.h having changed, so this commit includes
a gratuitous whitespace change to perl.h to hopefully force recompilation.
M perl.h
M perlio.c
M perliol.h
commit 303f2dc3d5bda8ee962db318dd53acb167c07485
Author: David Mitchell <***@iabyn.com>
Date: Mon Nov 15 17:06:37 2010 +0000
make PL_perlio an array of PerlIOl, not PerlIO *
Layers in PerlIO are implemented as a linked list of PerlIOl structs;
eaxch one has a 'next' field pointing to the next layer. Now here's the
clever bit: When PerlIO* pointers are passed around to refer to a
particular handle, these are actually pointers to the 'next' field of the
*parent* layer (so to access the flags field say of a PerlIOl, you have to
double-defref it, e.g. (*f)->flags). The big advantage of this is that
it's easy for a layer to pop itself; when you call PerlIO_pop(f), f is a
pointer to the parent's 'next' field, so pop(f) can just do
*f = (*f)->next.
This means that there has to be a fake 'next' field above the topmost
layer. This is where PL_perlio comes in: it's a pointer to an arena of
arrays of pointers, each one capable of pointing to a PerlIOl structure.
When a new handle is created, a spare arena slot is grabbed, and the
address of that slot is returned. This also allows for a handle with no
layers.
What this commit does is change PL_perlio from being an array of
PerlIO* into an array of PerlIOl structures - i.e. each element in the
array goes from being a single pointer, to having several fields. These
will be made used of in follow-up commits.
M intrpvar.h
M perlio.c
M perliol.h
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
intrpvar.h | 2 +-
perlio.c | 253 ++++++++++++++++++++++++++++++++++++++++--------------
perliol.h | 4 +-
pod/perlipc.pod | 6 ++
t/io/eintr.t | 126 +++++++++++++++++++++++++++
6 files changed, 324 insertions(+), 68 deletions(-)
create mode 100644 t/io/eintr.t
diff --git a/MANIFEST b/MANIFEST
index 8a72a8a..63bf429 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4481,6 +4481,7 @@ t/io/crlf.t See if :crlf works
t/io/crlf_through.t See if pipe passes data intact with :crlf
t/io/defout.t See if PL_defoutgv works
t/io/dup.t See if >& works right
+t/io/eintr.t See if code called during EINTR is safe
t/io/errnosig.t Test case for restoration $! when leaving signal handlers
t/io/errno.t See if $! is correctly set
t/io/fflush.t See if auto-flush on fork/exec/system/qx works
diff --git a/intrpvar.h b/intrpvar.h
index d10feec..0c90a9f 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -658,7 +658,7 @@ PERLVAR(Icustom_op_names, HV*) /* Names of user defined ops */
PERLVAR(Icustom_op_descs, HV*) /* Descriptions of user defined ops */
#ifdef PERLIO_LAYERS
-PERLVARI(Iperlio, PerlIO *,NULL)
+PERLVARI(Iperlio, PerlIOl *,NULL)
PERLVARI(Iknown_layers, PerlIO_list_t *,NULL)
PERLVARI(Idef_layerlist, PerlIO_list_t *,NULL)
#endif
diff --git a/perlio.c b/perlio.c
index 4620ecd..cd58448 100644
--- a/perlio.c
+++ b/perlio.c
@@ -70,6 +70,8 @@
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)) { \
@@ -527,11 +529,47 @@ PerlIO_debug(const char *fmt, ...)
* Inner level routines
*/
+/* check that the head field of each layer points back to the head */
+
+#ifdef DEBUGGING
+# define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f)
+static void
+PerlIO_verify_head(pTHX_ PerlIO *f)
+{
+ PerlIOl *head, *p;
+ int seen = 0;
+ if (!PerlIOValid(f))
+ return;
+ p = head = PerlIOBase(f)->head;
+ assert(p);
+ do {
+ assert(p->head == head);
+ if (p == (PerlIOl*)f)
+ seen = 1;
+ p = p->next;
+ } while (p);
+ assert(seen);
+}
+#else
+# define VERIFY_HEAD(f)
+#endif
+
+
/*
* Table of pointers to the PerlIO structs (malloc'ed)
*/
#define PERLIO_TABLE_SIZE 64
+static void
+PerlIO_init_table(pTHX)
+{
+ if (PL_perlio)
+ return;
+ Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl);
+}
+
+
+
PerlIO *
PerlIO_allocate(pTHX)
{
@@ -539,24 +577,30 @@ PerlIO_allocate(pTHX)
/*
* Find a free slot in the table, allocating new table as necessary
*/
- PerlIO **last;
- PerlIO *f;
+ PerlIOl **last;
+ PerlIOl *f;
last = &PL_perlio;
while ((f = *last)) {
int i;
- last = (PerlIO **) (f);
+ last = (PerlIOl **) (f);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- if (!*++f) {
- return f;
+ if (!((++f)->next)) {
+ f->flags = 0; /* lockcnt */
+ f->tab = NULL;
+ f->head = f;
+ return (PerlIO *)f;
}
}
}
- Newxz(f,PERLIO_TABLE_SIZE,PerlIO);
+ Newxz(f,PERLIO_TABLE_SIZE,PerlIOl);
if (!f) {
return NULL;
}
- *last = f;
- return f + 1;
+ *last = (PerlIOl*) f++;
+ f->flags = 0; /* lockcnt */
+ f->tab = NULL;
+ f->head = f;
+ return (PerlIO*) f;
}
#undef PerlIO_fdupopen
@@ -579,16 +623,16 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
}
void
-PerlIO_cleantable(pTHX_ PerlIO **tablep)
+PerlIO_cleantable(pTHX_ PerlIOl **tablep)
{
- PerlIO * const table = *tablep;
+ PerlIOl * const table = *tablep;
if (table) {
int i;
- PerlIO_cleantable(aTHX_(PerlIO **) & (table[0]));
+ PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0]));
for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) {
- PerlIO * const f = table + i;
- if (*f) {
- PerlIO_close(f);
+ PerlIOl * const f = table + i;
+ if (f->next) {
+ PerlIO_close(&(f->next));
}
}
Safefree(table);
@@ -669,19 +713,19 @@ void
PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param)
{
#ifdef USE_ITHREADS
- PerlIO **table = &proto->Iperlio;
- PerlIO *f;
+ PerlIOl **table = &proto->Iperlio;
+ PerlIOl *f;
PL_perlio = NULL;
PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param);
PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param);
- PerlIO_allocate(aTHX); /* root slot is never used */
+ PerlIO_init_table(aTHX);
PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto);
while ((f = *table)) {
int i;
- table = (PerlIO **) (f++);
+ table = (PerlIOl **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- if (*f) {
- (void) fp_dup(f, 0, param);
+ if (f->next) {
+ (void) fp_dup(&(f->next), 0, param);
}
f++;
}
@@ -697,19 +741,19 @@ void
PerlIO_destruct(pTHX)
{
dVAR;
- PerlIO **table = &PL_perlio;
- PerlIO *f;
+ PerlIOl **table = &PL_perlio;
+ PerlIOl *f;
#ifdef USE_ITHREADS
PerlIO_debug("Destruct %p\n",(void*)aTHX);
#endif
while ((f = *table)) {
int i;
- table = (PerlIO **) (f++);
+ table = (PerlIOl **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- PerlIO *x = f;
+ PerlIO *x = &(f->next);
const PerlIOl *l;
while ((l = *x)) {
- if (l->tab->kind & PERLIO_K_DESTRUCT) {
+ if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) {
PerlIO_debug("Destruct popping %s\n", l->tab->name);
PerlIO_flush(x);
PerlIO_pop(aTHX_ x);
@@ -727,9 +771,11 @@ void
PerlIO_pop(pTHX_ PerlIO *f)
{
const PerlIOl *l = *f;
+ VERIFY_HEAD(f);
if (l) {
- PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name);
- if (l->tab->Popped) {
+ PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f,
+ l->tab ? l->tab->name : "(Null)");
+ if (l->tab && l->tab->Popped) {
/*
* If popped returns non-zero do not free its layer structure
* it has either done so itself, or it is shared and still in
@@ -738,8 +784,16 @@ PerlIO_pop(pTHX_ 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);
+ }
+
}
}
@@ -1200,7 +1254,7 @@ PerlIO_stdstreams(pTHX)
{
dVAR;
if (!PL_perlio) {
- PerlIO_allocate(aTHX);
+ PerlIO_init_table(aTHX);
PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT);
PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT);
PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT);
@@ -1210,6 +1264,7 @@ PerlIO_stdstreams(pTHX)
PerlIO *
PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
{
+ VERIFY_HEAD(f);
if (tab->fsize != sizeof(PerlIO_funcs)) {
Perl_croak( aTHX_
"%s (%d) does not match %s (%d)",
@@ -1232,6 +1287,7 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg)
if (l) {
l->next = *f;
l->tab = (PerlIO_funcs*) tab;
+ l->head = ((PerlIOl*)f)->head;
*f = l;
PerlIO_debug("PerlIO_push f=%p %s %s %p\n",
(void*)f, tab->name,
@@ -1264,7 +1320,7 @@ PerlIOBase_binmode(pTHX_ PerlIO *f)
{
if (PerlIOValid(f)) {
/* Is layer suitable for raw stream ? */
- if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
+ if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
/* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
}
@@ -1293,7 +1349,7 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
*/
t = f;
while (t && (l = *t)) {
- if (l->tab->Binmode) {
+ if (l->tab && l->tab->Binmode) {
/* Has a handler - normal case */
if ((*l->tab->Binmode)(aTHX_ t) == 0) {
if (*t == l) {
@@ -1311,7 +1367,8 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
}
}
if (PerlIOValid(f)) {
- PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
+ PerlIO_debug(":raw f=%p :%s\n", (void*)f,
+ PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)");
return 0;
}
}
@@ -1364,7 +1421,8 @@ int
PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
{
PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f,
- (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)",
+ (PerlIOBase(f) && PerlIOBase(f)->tab) ?
+ PerlIOBase(f)->tab->name : "(Null)",
iotype, mode, (names) ? names : "(Null)");
if (names) {
@@ -1391,7 +1449,9 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
/* Perhaps we should turn on bottom-most aware layer
e.g. Ilya's idea that UNIX TTY could serve
*/
- if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
+ if (PerlIOBase(f)->tab &&
+ PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF)
+ {
if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
/* Not in text mode - flush any pending stuff and flip it */
PerlIO_flush(f);
@@ -1438,6 +1498,9 @@ Perl_PerlIO_close(pTHX_ PerlIO *f)
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;
}
@@ -1563,7 +1626,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
layera = PerlIO_list_alloc(aTHX);
while (l) {
SV *arg = NULL;
- if (l->tab->Getarg)
+ if (l->tab && l->tab->Getarg)
arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0);
PerlIO_list_push(aTHX_ layera, l->tab,
(arg) ? arg : &PL_sv_undef);
@@ -1689,15 +1752,16 @@ Perl_PerlIO_flush(pTHX_ PerlIO *f)
* things on fflush(NULL), but should we be bound by their design
* decisions? --jhi
*/
- PerlIO **table = &PL_perlio;
+ PerlIOl **table = &PL_perlio;
+ PerlIOl *ff;
int code = 0;
- while ((f = *table)) {
+ while ((ff = *table)) {
int i;
- table = (PerlIO **) (f++);
+ table = (PerlIOl **) (ff++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- if (*f && PerlIO_flush(f) != 0)
+ if (ff->next && PerlIO_flush(&(ff->next)) != 0)
code = -1;
- f++;
+ ff++;
}
}
return code;
@@ -1708,17 +1772,17 @@ void
PerlIOBase_flush_linebuf(pTHX)
{
dVAR;
- PerlIO **table = &PL_perlio;
- PerlIO *f;
+ PerlIOl **table = &PL_perlio;
+ PerlIOl *f;
while ((f = *table)) {
int i;
- table = (PerlIO **) (f++);
+ table = (PerlIOl **) (f++);
for (i = 1; i < PERLIO_TABLE_SIZE; i++) {
- if (*f
- && (PerlIOBase(f)->
+ if (f->next
+ && (PerlIOBase(&(f->next))->
flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
== (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE))
- PerlIO_flush(f);
+ PerlIO_flush(&(f->next));
f++;
}
}
@@ -1868,7 +1932,7 @@ PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
PERL_UNUSED_ARG(mode);
PERL_UNUSED_ARG(arg);
if (PerlIOValid(f)) {
- if (tab->kind & PERLIO_K_UTF8)
+ if (tab && tab->kind & PERLIO_K_UTF8)
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
else
PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
@@ -2037,7 +2101,7 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
- if (tab->Set_ptrcnt != NULL)
+ if (tab && tab->Set_ptrcnt != NULL)
l->flags |= PERLIO_F_FASTGETS;
if (mode) {
if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT)
@@ -2266,8 +2330,9 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
SV *arg = NULL;
char buf[8];
PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n",
- self->name, (void*)f, (void*)o, (void*)param);
- if (self->Getarg)
+ self ? self->name : "(Null)",
+ (void*)f, (void*)o, (void*)param);
+ if (self && self->Getarg)
arg = (*self->Getarg)(aTHX_ o, param, flags);
f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg);
if (PerlIOBase(o)->flags & PERLIO_F_UTF8)
@@ -2466,6 +2531,38 @@ typedef struct {
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)
{
@@ -2598,7 +2695,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
int perm, PerlIO *f, int narg, SV **args)
{
if (PerlIOValid(f)) {
- if (PerlIOBase(f)->flags & PERLIO_F_OPEN)
+ if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN)
(*PerlIOBase(f)->tab->Close)(aTHX_ f);
}
if (narg > 0) {
@@ -2669,7 +2766,10 @@ SSize_t
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);
@@ -2692,7 +2792,9 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
}
return len;
}
- PERL_ASYNC_CHECK();
+ /* EINTR */
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
}
/*NOTREACHED*/
}
@@ -2701,7 +2803,10 @@ SSize_t
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);
@@ -2716,7 +2821,9 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
}
return len;
}
- PERL_ASYNC_CHECK();
+ /* EINTR */
+ if (PL_sig_pending && S_perlio_async_run(aTHX_ f))
+ return -1;
}
/*NOTREACHED*/
}
@@ -2751,7 +2858,9 @@ PerlIOUnix_close(pTHX_ PerlIO *f)
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;
@@ -3224,8 +3333,11 @@ SSize_t
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;
@@ -3245,7 +3357,8 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
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;
@@ -3314,12 +3427,15 @@ PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
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;
@@ -3481,9 +3597,12 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
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
@@ -3498,7 +3617,8 @@ PerlIOStdio_fill(pTHX_ PerlIO *f)
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);
}
@@ -4030,7 +4150,8 @@ PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
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);
@@ -4988,7 +5109,7 @@ Perl_PerlIO_stdin(pTHX)
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
- return &PL_perlio[1];
+ return (PerlIO*)&PL_perlio[1];
}
PerlIO *
@@ -4998,7 +5119,7 @@ Perl_PerlIO_stdout(pTHX)
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
- return &PL_perlio[2];
+ return (PerlIO*)&PL_perlio[2];
}
PerlIO *
@@ -5008,7 +5129,7 @@ Perl_PerlIO_stderr(pTHX)
if (!PL_perlio) {
PerlIO_stdstreams(aTHX);
}
- return &PL_perlio[3];
+ return (PerlIO*)&PL_perlio[3];
}
/*--------------------------------------------------------------------------------------*/
diff --git a/perliol.h b/perliol.h
index 6b714bb..019fa8c 100644
--- a/perliol.h
+++ b/perliol.h
@@ -67,6 +67,7 @@ struct _PerlIO {
PerlIOl *next; /* Lower layer */
PerlIO_funcs *tab; /* Functions for this layer */
U32 flags; /* Various flags for state */
+ PerlIOl *head; /* our ultimate parent pointer */
};
/*--------------------------------------------------------------------------------------*/
@@ -89,6 +90,7 @@ struct _PerlIO {
#define PERLIO_F_FASTGETS 0x00400000
#define PERLIO_F_TTY 0x00800000
#define PERLIO_F_NOTREG 0x01000000
+#define PERLIO_F_CLEARED 0x02000000 /* layer cleared but not freed */
#define PerlIOBase(f) (*(f))
#define PerlIOSelf(f,type) ((type *)PerlIOBase(f))
@@ -150,7 +152,7 @@ PERL_EXPORT_C PerlIO_funcs *PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, Pe
PERL_EXPORT_C SV *PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param);
-PERL_EXPORT_C void PerlIO_cleantable(pTHX_ PerlIO **tablep);
+PERL_EXPORT_C void PerlIO_cleantable(pTHX_ PerlIOl **tablep);
PERL_EXPORT_C SV * PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab);
PERL_EXPORT_C void PerlIO_default_buffer(pTHX_ PerlIO_list_t *av);
PERL_EXPORT_C void PerlIO_stdstreams(pTHX);
diff --git a/pod/perlipc.pod b/pod/perlipc.pod
index 8aa5005..5e9f408 100644
--- a/pod/perlipc.pod
+++ b/pod/perlipc.pod
@@ -408,6 +408,12 @@ operation.)
The default in Perl 5.7.3 and later is to automatically use
the C<:perlio> layer.
+Note that it is not advisable to access a file handle within a signal
+handler where that signal has interrupted an I/O operation on that same
+handle. While perl will at least try hard not to crash, there are no
+guarantees of data integrity; for example, some data might get dropped or
+written twice.
+
Some networking library functions like gethostbyname() are known to have
their own implementations of timeouts which may conflict with your
timeouts. If you have problems with such functions, try using the POSIX
diff --git a/t/io/eintr.t b/t/io/eintr.t
new file mode 100644
index 0000000..3b6b0a4
--- /dev/null
+++ b/t/io/eintr.t
@@ -0,0 +1,126 @@
+#!./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:
--
Perl5 Master Repository