mirror/perl
1
0
Fork 0
mirror of https://github.com/Perl/perl5.git synced 2026-01-26 08:38:23 +00:00
Code Issues Packages Projects Releases Wiki Activity

Fix fd leak on Via(bogus).

Browse Source 
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
This commit is contained in:
Nick Ing-Simmons 2002-04-27 10:12:00 +00:00
parent 5f228b1d3f
commit d9dac8cda3
5 changed files with 110 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
ext/PerlIO/Via/Via.xs
View File

@ -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,

22
ext/PerlIO/t/via.t
View File

@ -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;

6
makedef.pl
View File

@ -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

38
perlio.c
View File

@ -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) {
/*

7
perliol.h
View File

@ -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,