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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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,