From: Nick Ing-Simmons Date: Sat, 27 Apr 2002 10:12:00 +0000 (+0000) Subject: Fix fd leak on Via(bogus). X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d9dac8cda3a8128f09ab4445f683196e1392e4fa;p=p5sagit%2Fp5-mst-13.2.git Fix fd leak on Via(bogus). Finish implementing PerlIOVia_open(). Export more guts of PerlIO_* so Via_open() can work. Fix various PerlIO_allocate() features exposed by above. p4raw-id: //depot/perlio@16207 --- diff --git a/ext/PerlIO/Via/Via.xs b/ext/PerlIO/Via/Via.xs index af5f5ea..494ddf9 100644 --- a/ext/PerlIO/Via/Via.xs +++ b/ext/PerlIO/Via/Via.xs @@ -55,6 +55,14 @@ PerlIOVia_fetchmethod(pTHX_ PerlIOVia *s,char *method,CV **save) } } +/* + * Try and call method, possibly via cached lookup. + * If method does not exist return Nullsv (caller may fallback to another approach + * If method does exist call it with flags passing variable number of args + * Last arg is a "filehandle" to layer below (if present) + * Returns scalar returned by method (if any) otherwise sv_undef + */ + SV * PerlIOVia_method(pTHX_ PerlIO *f,char *method,CV **save,int flags,...) { @@ -88,6 +96,10 @@ PerlIOVia_method(pTHX_ PerlIO *f,char *method,CV **save,int flags,...) IoOFP(s->io) = PerlIONext(f); XPUSHs(s->fh); } + else + { + PerlIO_debug("No next\n"); + } PUTBACK; count = call_sv((SV *)cv,flags); if (count) @@ -117,6 +129,7 @@ PerlIOVia_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg) { if (ckWARN(WARN_LAYER)) Perl_warner(aTHX_ packWARN(WARN_LAYER), "No package specified"); + errno = EINVAL; code = -1; } else @@ -163,7 +176,9 @@ PerlIOVia_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg) } PerlIO * -PerlIOVia_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) +PerlIOVia_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, + const char *mode, int fd, int imode, int perm, + PerlIO *f, int narg, SV **args) { if (!f) { @@ -171,6 +186,7 @@ PerlIOVia_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char } else { + /* Reopen */ if (!PerlIO_push(aTHX_ f,self,mode,PerlIOArg)) return NULL; } @@ -206,7 +222,44 @@ PerlIOVia_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char } } else - return NULL; + { + /* Required open method not present */ + PerlIO_funcs *tab = NULL; + IV m = n-1; + while (m >= 0) { + PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layers, m, NULL); + if (t && t->Open) { + tab = t; + break; + } + n--; + } + if (tab) { + if ((*tab->Open) (aTHX_ tab, layers, m, mode, fd, imode, perm, + PerlIONext(f), narg, args)) { + PerlIO_debug("Opened with %s => %p->%p\n",tab->name,PerlIONext(f),*PerlIONext(f)); + if (m + 1 < n) { + /* + * More layers above the one that we used to open - + * apply them now + */ + if (PerlIO_apply_layera(aTHX_ PerlIONext(f), mode, layers, m+1, n) != 0) { + /* If pushing layers fails close the file */ + PerlIO_close(f); + f = NULL; + } + } + return f; + } + else { + /* Sub-layer open failed */ + } + } + else { + /* Nothing to do the open */ + } + return NULL; + } } return f; } @@ -494,7 +547,7 @@ PerlIO_funcs PerlIO_object = { PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT, PerlIOVia_pushed, PerlIOVia_popped, - NULL, /* PerlIOVia_open, */ + PerlIOVia_open, /* NULL, */ PerlIOVia_getarg, PerlIOVia_fileno, PerlIOVia_dup, diff --git a/ext/PerlIO/t/via.t b/ext/PerlIO/t/via.t index 89a1e13..43ea3c5 100644 --- a/ext/PerlIO/t/via.t +++ b/ext/PerlIO/t/via.t @@ -14,7 +14,7 @@ BEGIN { my $tmp = "via$$"; -use Test::More tests => 11; +use Test::More tests => 13; my $fh; my $a = join("", map { chr } 0..255) x 10; @@ -38,14 +38,32 @@ is($a, $b, 'compare original data with filtered version'); local $SIG{__WARN__} = sub { $warnings = join '', @_ }; use warnings 'layer'; + + # Find fd number we should be using + my $fd = open($fh,">$tmp") && fileno($fh); + print $fh "Hello\n"; + close($fh); + ok( ! open($fh,">Via(Unknown::Module)", $tmp), 'open Via Unknown::Module will fail'); like( $warnings, qr/^Cannot find package 'Unknown::Module'/, 'warn about unknown package' ); + # Now open normally again to see if we get right fileno + my $fd2 = open($fh,"<$tmp") && fileno($fh); + is($fd2,$fd,"Wrong fd number after failed open"); + + my $data = <$fh>; + + is($data,"Hello\n","File clobbered by failed open"); + + close($fh); + + + $warnings = ''; no warnings 'layer'; ok( ! open($fh,">Via(Unknown::Module)", $tmp), 'open Via Unknown::Module will fail'); is( $warnings, "", "don't warn about unknown package" ); -} +} END { 1 while unlink $tmp; diff --git a/makedef.pl b/makedef.pl index 4ee99f3..9bc22c5 100644 --- a/makedef.pl +++ b/makedef.pl @@ -713,7 +713,11 @@ my @layer_syms = qw( PerlIO_allocate PerlIO_arg_fetch PerlIO_define_layer - PerlIO_modestr + PerlIO_modestr + PerlIO_parse_layers + PerlIO_layer_fetch + PerlIO_list_free + PerlIO_apply_layera PerlIO_pending PerlIO_push PerlIO_sv_dup diff --git a/perlio.c b/perlio.c index 6e41997..ac35527 100644 --- a/perlio.c +++ b/perlio.c @@ -1040,9 +1040,8 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg) int PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, - PerlIO_list_t *layers, IV n) + PerlIO_list_t *layers, IV n, IV max) { - IV max = layers->cur; int code = 0; while (n < max) { PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n, NULL); @@ -1065,7 +1064,7 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) PerlIO_list_t *layers = PerlIO_list_alloc(aTHX); code = PerlIO_parse_layers(aTHX_ layers, names); if (code == 0) { - code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0); + code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0, layers->cur); } PerlIO_list_free(aTHX_ layers); } @@ -1356,8 +1355,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, * More layers above the one that we used to open - * apply them now */ - if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1) - != 0) { + if (PerlIO_apply_layera(aTHX_ f, mode, layera, n + 1, layera->cur) != 0) { + /* If pushing layers fails close the file */ + PerlIO_close(f); f = NULL; } } @@ -2182,7 +2182,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { - if (f) { + if (PerlIOValid(f)) { if (PerlIOBase(f)->flags & PERLIO_F_OPEN) (*PerlIOBase(f)->tab->Close)(aTHX_ f); } @@ -2204,11 +2204,14 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, mode++; if (!f) { f = PerlIO_allocate(aTHX); + } + if (!PerlIOValid(f)) { s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg), PerlIOUnix); } - else + else { s = PerlIOSelf(f, PerlIOUnix); + } s->fd = fd; s->oflags = imode; PerlIOBase(f)->flags |= PERLIO_F_OPEN; @@ -2428,7 +2431,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, int perm, PerlIO *f, int narg, SV **args) { char tmode[8]; - if (f) { + if (PerlIOValid(f)) { char *path = SvPV_nolen(*args); PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio); FILE *stdio; @@ -2451,9 +2454,11 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, else { FILE *stdio = PerlSIO_fopen(path, mode); if (stdio) { - PerlIOStdio *s = - PerlIOSelf(PerlIO_push - (aTHX_(f = PerlIO_allocate(aTHX)), self, + PerlIOStdio *s; + if (!f) { + f = PerlIO_allocate(aTHX); + } + s = PerlIOSelf(PerlIO_push(aTHX_ f, self, (mode = PerlIOStdio_mode(mode, tmode)), PerlIOArg), PerlIOStdio); @@ -2488,10 +2493,11 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, PerlIOStdio_mode(mode, tmode)); } if (stdio) { - PerlIOStdio *s = - PerlIOSelf(PerlIO_push - (aTHX_(f = PerlIO_allocate(aTHX)), self, - mode, PerlIOArg), PerlIOStdio); + PerlIOStdio *s; + if (!f) { + f = PerlIO_allocate(aTHX); + } + s = PerlIOSelf(PerlIO_push(aTHX_ f, self, mode, PerlIOArg), PerlIOStdio); s->stdio = stdio; PerlIOUnix_refcnt_inc(fileno(s->stdio)); return f; @@ -2880,7 +2886,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, */ } f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm, - NULL, narg, args); + f, narg, args); if (f) { if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) { /* diff --git a/perliol.h b/perliol.h index 331cb95..f7bd359 100644 --- a/perliol.h +++ b/perliol.h @@ -154,6 +154,13 @@ typedef struct { IV oneword; /* Emergency buffer */ } PerlIOBuf; +extern int PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, + PerlIO_list_t *layers, IV n, IV max); +extern int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names); +extern void PerlIO_list_free(pTHX_ PerlIO_list_t *list); +extern PerlIO_funcs *PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def); + + extern SV *PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param); extern PerlIO *PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n,