PerlIO Layer implementation future proofing.

 - Inspired by Nick C's suggestion add size of function table to the table
   as a validation check.
 - also optimize pseudo-layer code to avoid malloc/link of something
   destined to be immediately popped & freed.
 - Minor addition to pod/perliol.pod

p4raw-id: //depot/perlio@17330

diff --git a/ext/PerlIO/Scalar/Scalar.xs b/ext/PerlIO/Scalar/Scalar.xs
index 314c0f3..5bbc119 100644 (file)
--- a/ext/PerlIO/Scalar/Scalar.xs
+++ b/ext/PerlIO/Scalar/Scalar.xs
@@ -14,7 +14,7 @@ typedef struct
 } PerlIOScalar;
 
 IV
-PerlIOScalar_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOScalar_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
  IV code;
  PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar);
@@ -38,7 +38,7 @@ PerlIOScalar_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
    s->var = newSVpvn("",0);
   }
  sv_upgrade(s->var,SVt_PV);
- code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv);
+ code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv,tab);
  if ((PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
    SvCUR(s->var) = 0;
  if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
@@ -263,6 +263,7 @@ PerlIOScalar_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 }
 
 PerlIO_funcs PerlIO_scalar = {
+ sizeof(PerlIO_funcs),
  "Scalar",
  sizeof(PerlIOScalar),
  PERLIO_K_BUFFERED|PERLIO_K_RAW,

diff --git a/ext/PerlIO/Via/Via.xs b/ext/PerlIO/Via/Via.xs
index d1ebab2..04c4d48 100644 (file)
--- a/ext/PerlIO/Via/Via.xs
+++ b/ext/PerlIO/Via/Via.xs
@@ -123,9 +123,9 @@ PerlIOVia_method(pTHX_ PerlIO *f,char *method,CV **save,int flags,...)
 }
 
 IV
-PerlIOVia_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOVia_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
- IV code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv);
+ IV code = PerlIOBase_pushed(aTHX_ f,mode,Nullsv,tab);
  if (code == 0)
   {
    PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
@@ -559,6 +559,7 @@ PerlIOVia_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 }
 
 PerlIO_funcs PerlIO_object = {
+ sizeof(PerlIO_funcs),
  "Via",
  sizeof(PerlIOVia),
  PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,

diff --git a/ext/PerlIO/encoding/encoding.xs b/ext/PerlIO/encoding/encoding.xs
index df911ed..a714a3d 100644 (file)
--- a/ext/PerlIO/encoding/encoding.xs
+++ b/ext/PerlIO/encoding/encoding.xs
@@ -80,11 +80,11 @@ PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
 }
 
 IV
-PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg)
+PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs *tab)
 {
     PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
     dSP;
-    IV  code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv);
+    IV  code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab);
     SV *result = Nullsv;
 
     PUSHSTACKi(PERLSI_MAGIC);
@@ -584,6 +584,7 @@ PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 }
 
 PerlIO_funcs PerlIO_encode = {
+    sizeof(PerlIO_funcs),
     "encoding",
     sizeof(PerlIOEncode),
     PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT,

diff --git a/perlio.c b/perlio.c
index edfdf17..f8d6517 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -990,17 +990,33 @@ PerlIO_stdstreams(pTHX)
 PerlIO *
 PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg)
 {
-    PerlIOl *l = NULL;
-    Newc('L',l,tab->size,char,PerlIOl);
-    if (l && f) {
-       Zero(l, tab->size, char);
-       l->next = *f;
-       l->tab = tab;
-       *f = l;
-       PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
-                    (mode) ? mode : "(Null)", (void*)arg);
-       if ((*l->tab->Pushed) (aTHX_ f, mode, arg) != 0) {
-           PerlIO_pop(aTHX_ f);
+    if (tab->fsize != sizeof(PerlIO_funcs)) {
+      mismatch:
+       Perl_croak(aTHX_ "Layer does not match this perl");
+    }
+    if (tab->size) {
+       PerlIOl *l = NULL;
+       if (tab->size < sizeof(PerlIOl)) {
+           goto mismatch;
+       }
+       /* Real layer with a data area */
+       Newc('L',l,tab->size,char,PerlIOl);
+       if (l && f) {
+           Zero(l, tab->size, char);
+           l->next = *f;
+           l->tab = tab;
+           *f = l;
+           PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name,
+                       (mode) ? mode : "(Null)", (void*)arg);
+           if ((*l->tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) {
+               PerlIO_pop(aTHX_ f);
+               return NULL;
+           }
+       }
+    }
+    else if (f) {
+       /* Pseudo-layer where push does its own stack adjust */
+       if ((*tab->Pushed) (aTHX_ f, mode, arg, tab) != 0) {
            return NULL;
        }
     }
@@ -1008,7 +1024,7 @@ PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg)
 }
 
 IV
-PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
     PerlIO_pop(aTHX_ f);
     if (*f) {
@@ -1038,13 +1054,12 @@ PerlIOBase_binmode(pTHX_ PerlIO *f)
 }
 
 IV
-PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
 
     if (PerlIOValid(f)) {
        PerlIO *t;
        PerlIOl *l;
-       PerlIO_pop(aTHX_ f);     /* Remove the dummy layer */
        PerlIO_flush(f);
        /*
         * Strip all layers that are not suitable for a raw stream
@@ -1680,11 +1695,9 @@ Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt)
  */
 
 IV
-PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
     if (*PerlIONext(f)) {
-       PerlIO_funcs *tab = PerlIOBase(f)->tab;
-       PerlIO_pop(aTHX_ f);
        if (tab->kind & PERLIO_K_UTF8)
            PerlIOBase(f)->flags |= PERLIO_F_UTF8;
        else
@@ -1695,8 +1708,9 @@ PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
 }
 
 PerlIO_funcs PerlIO_utf8 = {
+    sizeof(PerlIO_funcs),
     "utf8",
-    sizeof(PerlIOl),
+    0,
     PERLIO_K_DUMMY | PERLIO_K_UTF8,
     PerlIOUtf8_pushed,
     NULL,
@@ -1723,8 +1737,9 @@ PerlIO_funcs PerlIO_utf8 = {
 };
 
 PerlIO_funcs PerlIO_byte = {
+    sizeof(PerlIO_funcs),
     "bytes",
-    sizeof(PerlIOl),
+    0,
     PERLIO_K_DUMMY,
     PerlIOUtf8_pushed,
     NULL,
@@ -1761,8 +1776,9 @@ PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 }
 
 PerlIO_funcs PerlIO_raw = {
+    sizeof(PerlIO_funcs),
     "raw",
-    sizeof(PerlIOl),
+    0,
     PERLIO_K_DUMMY,
     PerlIORaw_pushed,
     PerlIOBase_popped,
@@ -1830,14 +1846,13 @@ PerlIO_modestr(PerlIO *f, char *buf)
 }
 
 IV
-PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
     PerlIOl *l = PerlIOBase(f);
 #if 0
     const char *omode = mode;
     char temp[8];
 #endif
-    PerlIO_funcs *tab = PerlIOBase(f)->tab;
     l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE |
                  PERLIO_F_TRUNCATE | PERLIO_F_APPEND);
     if (tab->Set_ptrcnt != NULL)
@@ -2195,9 +2210,9 @@ PerlIOUnix_fileno(pTHX_ PerlIO *f)
 }
 
 IV
-PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
-    IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
+    IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
     PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix);
     if (*PerlIONext(f)) {
        /* We never call down so do any pending stuff now */
@@ -2365,6 +2380,7 @@ PerlIOUnix_close(pTHX_ PerlIO *f)
 }
 
 PerlIO_funcs PerlIO_unix = {
+    sizeof(PerlIO_funcs),
     "unix",
     sizeof(PerlIOUnix),
     PERLIO_K_RAW,
@@ -2436,7 +2452,7 @@ PerlIOStdio_mode(const char *mode, char *tmode)
  * This isn't used yet ...
  */
 IV
-PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
     if (*PerlIONext(f)) {
        PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio);
@@ -2452,7 +2468,7 @@ PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
        else
            return -1;
     }
-    return PerlIOBase_pushed(aTHX_ f, mode, arg);
+    return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
 }
 
 
@@ -2923,6 +2939,7 @@ PerlIOStdio_fill(pTHX_ PerlIO *f)
 
 
 PerlIO_funcs PerlIO_stdio = {
+    sizeof(PerlIO_funcs),
     "stdio",
     sizeof(PerlIOStdio),
     PERLIO_K_BUFFERED|PERLIO_K_RAW,
@@ -3026,7 +3043,7 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f)
  */
 
 IV
-PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
     PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf);
     int fd = PerlIO_fileno(f);
@@ -3039,7 +3056,7 @@ PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
            b->posn = posn;
        }
     }
-    return PerlIOBase_pushed(aTHX_ f, mode, arg);
+    return PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
 }
 
 PerlIO *
@@ -3052,7 +3069,7 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
        PerlIO_funcs *tab =  PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab);
        next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm,
                          next, narg, args);
-       if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg) != 0) {
+       if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) {
            return NULL;
        }
     }
@@ -3474,6 +3491,7 @@ PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 
 
 PerlIO_funcs PerlIO_perlio = {
+    sizeof(PerlIO_funcs),
     "perlio",
     sizeof(PerlIOBuf),
     PERLIO_K_BUFFERED|PERLIO_K_RAW,
@@ -3563,9 +3581,9 @@ PerlIOPending_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt)
 }
 
 IV
-PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOPending_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
-    IV code = PerlIOBase_pushed(aTHX_ f, mode, arg);
+    IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab);
     PerlIOl *l = PerlIOBase(f);
     /*
      * Our PerlIO_fast_gets must match what we are pushed on, or sv_gets()
@@ -3596,6 +3614,7 @@ PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 }
 
 PerlIO_funcs PerlIO_pending = {
+    sizeof(PerlIO_funcs),
     "pending",
     sizeof(PerlIOBuf),
     PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
@@ -3641,11 +3660,11 @@ typedef struct {
 } PerlIOCrlf;
 
 IV
-PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
     IV code;
     PerlIOBase(f)->flags |= PERLIO_F_CRLF;
-    code = PerlIOBuf_pushed(aTHX_ f, mode, arg);
+    code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab);
 #if 0
     PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n",
                 f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)",
@@ -3906,6 +3925,7 @@ PerlIOCrlf_binmode(pTHX_ PerlIO *f)
 }
 
 PerlIO_funcs PerlIO_crlf = {
+    sizeof(PerlIO_funcs),
     "crlf",
     sizeof(PerlIOCrlf),
     PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
@@ -4222,6 +4242,7 @@ PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 
 
 PerlIO_funcs PerlIO_mmap = {
+    sizeof(PerlIO_funcs),
     "mmap",
     sizeof(PerlIOMmap),
     PERLIO_K_BUFFERED|PERLIO_K_RAW,

diff --git a/perliol.h b/perliol.h
index 76d74a7..fa399e6 100644 (file)
--- a/perliol.h
+++ b/perliol.h
@@ -14,10 +14,11 @@ struct PerlIO_list_s {
 };
 
 struct _PerlIO_funcs {
+    Size_t fsize;
     char *name;
     Size_t size;
     U32 kind;
-    IV (*Pushed) (pTHX_ PerlIO *f, const char *mode, SV *arg);
+    IV (*Pushed) (pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
     IV (*Popped) (pTHX_ PerlIO *f);
     PerlIO *(*Open) (pTHX_ PerlIO_funcs *tab,
                     PerlIO_list_t *layers, IV n,
@@ -124,7 +125,7 @@ extern SV *PerlIO_arg_fetch(PerlIO_list_t *av, IV n);
 
 extern IV PerlIOBase_fileno(pTHX_ PerlIO *f);
 extern PerlIO *PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
-extern IV PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg);
+extern IV PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
 extern IV PerlIOBase_popped(pTHX_ PerlIO *f);
 extern IV PerlIOBase_binmode(pTHX_ PerlIO *f);
 extern SSize_t PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count);
@@ -168,7 +169,7 @@ extern PerlIO *PerlIOBuf_open(pTHX_ PerlIO_funcs *self,
                              PerlIO_list_t *layers, IV n,
                              const char *mode, int fd, int imode,
                              int perm, PerlIO *old, int narg, SV **args);
-extern IV PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg);
+extern IV PerlIOBuf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab);
 extern IV PerlIOBuf_popped(pTHX_ PerlIO *f);
 extern PerlIO *PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
 extern SSize_t PerlIOBuf_read(pTHX_ PerlIO *f, void *vbuf, Size_t count);

diff --git a/pod/perliol.pod b/pod/perliol.pod
index 81cbab1..da4abe7 100644 (file)
--- a/pod/perliol.pod
+++ b/pod/perliol.pod
@@ -87,10 +87,11 @@ same as the public C<PerlIO_xxxxx> functions:
 
   struct _PerlIO_funcs
   {
+   Size_t              fsize;
    char *              name;
    Size_t              size;
    IV          kind;
-   IV          (*Pushed)(pTHX_ PerlIO *f,const char *mode,SV *arg);
+   IV          (*Pushed)(pTHX_ PerlIO *f,const char *mode,SV *arg, PerlIO_funcs *tab);
    IV          (*Popped)(pTHX_ PerlIO *f);
    PerlIO *    (*Open)(pTHX_ PerlIO_funcs *tab,
                        AV *layers, IV n,
@@ -124,9 +125,9 @@ same as the public C<PerlIO_xxxxx> functions:
    void                (*Set_ptrcnt)(pTHX_ PerlIO *f,STDCHAR *ptr,SSize_t cnt);
   };
 
-The first few members of the struct give a "name" for the layer, the
-size to C<malloc> for the per-instance data, and some flags which are
-attributes of the class as whole (such as whether it is a buffering
+The first few members of the struct give a function table size for
+compatibility check "name" for the layer, the  size to C<malloc> for the per-instance data,
+and some flags which are attributes of the class as whole (such as whether it is a buffering
 layer), then follow the functions which fall into four basic groups:
 
 =over 4
@@ -323,6 +324,14 @@ to change during one "get".)
 
 =over 4
 
+=item size
+
+       Size_t fsize;
+
+Size of the function table. This is compared against the value PerlIO code "knows"
+as a compatibility check. Future versions I<may> be able to tolerate layers
+compiled against an old version of the headers.
+
 =item name
 
        char * name;
@@ -343,6 +352,14 @@ The size of the per-instance data structure, e.g.:
 
   sizeof(PerlIOAPR)
 
+If this field is zero then C<PerlIO_pushed> does not malloc anything and assumes
+layer's Pushed function will do any required layer stack manipulation - used
+to avoid malloc/free overhead for dummy layers.
+If the field is non-zero it must be at least the size of C<PerlIOl>,
+C<PerlIO_pushed> will allocate memory for the layer's data structures
+and link new layer onto the stream's stack. (If the layer's Pushed
+method returns an error indication the layer is popped again.)
+
 =item kind
 
        IV kind;
@@ -492,18 +509,18 @@ Returns the Unix/Posix numeric file descriptor for the handle. Normally
 C<PerlIOBase_fileno()> (which just asks next layer down) will suffice
 for this.
 
-Returns -1 if the layer cannot provide such a file descriptor, or in
-the case of the error.
-
-XXX: two possible results end up in -1, one is an error the other is
-not.
+Returns -1 on error, which is considered to include the case where the layer cannot
+provide such a file descriptor.
 
 =item Dup
 
        PerlIO * (*Dup)(pTHX_ PerlIO *f, PerlIO *o,
                        CLONE_PARAMS *param, int flags);
 
-XXX: not documented
+XXX: Needs more docs.
+
+Used as part of the "clone" process when a thread is spawned (in which case
+param will be non-NULL) and when a stream is being duplicated via '&' in the C<open>.
 
 Similar to C<Open>, returns PerlIO* on success, C<NULL> on failure.
 

diff --git a/win32/win32io.c b/win32/win32io.c
index 7997658..f0f71e7 100644 (file)
--- a/win32/win32io.c
+++ b/win32/win32io.c
@@ -52,9 +52,9 @@ PerlIOWin32_fileno(pTHX_ PerlIO *f)
 }
 
 IV
-PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
+PerlIOWin32_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab)
 {
- IV code = PerlIOBase_pushed(aTHX_ f,mode,arg);
+ IV code = PerlIOBase_pushed(aTHX_ f,mode,arg,tab);
  if (*PerlIONext(f))
   {
    PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
@@ -341,6 +341,7 @@ PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
 }
 
 PerlIO_funcs PerlIO_win32 = {
+ sizeof(PerlIO_funcs),
  "win32",
  sizeof(PerlIOWin32),
  PERLIO_K_RAW,