X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=9f12be62735db4bc0c470dedcbac7e9828675adb;hb=918426be7f3660c63cebe082bf8eac82a38bf756;hp=1c8f65d179d32a117374998e96164293aac23b8a;hpb=847a5fae45dac396d0f9e1bb61d5b4ff9d94cdcd;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perlio.c b/perlio.c
index 1c8f65d..9f12be6 100644
--- a/perlio.c
+++ b/perlio.c
@@ -1,6 +1,6 @@
 /*    perlio.c
  *
- *    Copyright (c) 1996-2000, Nick Ing-Simmons
+ *    Copyright (c) 1996-2001, Nick Ing-Simmons
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -283,7 +283,8 @@ PerlIO_pop(PerlIO *f)
  if (l)
   {
    PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name);
-   (*l->tab->Popped)(f);
+   if (l->tab->Popped)
+    (*l->tab->Popped)(f);
    *f = l->next;
    PerlMemShared_free(l);
   }
@@ -416,6 +417,10 @@ PerlIO_define_layer(PerlIO_funcs *tab)
  dTHX;
  HV *stash = gv_stashpv("perlio::Layer", TRUE);
  SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
+ if (!PerlIO_layer_hv)
+  {
+   PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
+  }
  hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
  PerlIO_debug("define %s %p\n",tab->name,tab);
 }
@@ -437,7 +442,6 @@ PerlIO_default_buffer(pTHX)
   }
  PerlIO_debug("Pushing %s\n",tab->name);
  av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(tab->name,0)));
-
 }
 
 
@@ -449,16 +453,15 @@ PerlIO_default_layer(I32 n)
  SV *layer;
  PerlIO_funcs *tab = &PerlIO_stdio;
  int len;
- if (!PerlIO_layer_hv)
+ if (!PerlIO_layer_av)
   {
    const char *s  = PerlEnv_getenv("PERLIO");
+   PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
    newXS("perlio::import",XS_perlio_import,__FILE__);
    newXS("perlio::unimport",XS_perlio_unimport,__FILE__);
 #if 0
    newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
 #endif
-   PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI);
-   PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI);
    PerlIO_define_layer(&PerlIO_raw);
    PerlIO_define_layer(&PerlIO_unix);
    PerlIO_define_layer(&PerlIO_perlio);
@@ -468,6 +471,7 @@ PerlIO_default_layer(I32 n)
    PerlIO_define_layer(&PerlIO_mmap);
 #endif
    PerlIO_define_layer(&PerlIO_utf8);
+   PerlIO_define_layer(&PerlIO_byte);
    av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
    if (s)
     {
@@ -549,7 +553,8 @@ PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN
    l->next = *f;
    l->tab  = tab;
    *f      = l;
-   PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
+   PerlIO_debug("PerlIO_push f=%p %s %s '%.*s'\n",
+                 f,tab->name,(mode) ? mode : "(Null)",(int) len,arg);
    if ((*l->tab->Pushed)(f,mode,arg,len) != 0)
     {
      PerlIO_pop(f);
@@ -560,12 +565,13 @@ PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN
 }
 
 IV
-PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
+PerlIOPop_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
 {
- if (PerlIONext(f))
+ PerlIO_pop(f);
+ if (*f)
   {
+   PerlIO_flush(f);
    PerlIO_pop(f);
-   PerlIOBase(f)->flags |= PERLIO_F_UTF8;
    return 0;
   }
  return -1;
@@ -574,14 +580,30 @@ PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
 IV
 PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
 {
+ /* Remove the dummy layer */
+ PerlIO_pop(f);
  /* Pop back to bottom layer */
- if (PerlIONext(f))
+ if (f && *f)
   {
+   int code = 0;
    PerlIO_flush(f);
-   while (PerlIONext(f))
+   while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW))
     {
-     PerlIO_pop(f);
+     if (*PerlIONext(f))
+      {
+       PerlIO_pop(f);
+      }
+     else
+      {
+       /* Nothing bellow - push unix on top then remove it */
+       if (PerlIO_push(f,PerlIO_default_btm(),mode,arg,len))
+        {
+         PerlIO_pop(PerlIONext(f));
+        }
+       break;
+      }
     }
+   PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name);
    return 0;
   }
  return -1;
@@ -595,70 +617,77 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
    const char *s = names;
    while (*s)
     {
-     while (isSPACE(*s))
-      s++;
-     if (*s == ':')
+     while (isSPACE(*s) || *s == ':')
       s++;
      if (*s)
       {
+       STRLEN llen = 0;
        const char *e = s;
        const char *as = Nullch;
-       const char *ae = Nullch;
-       int count = 0;
-       while (*e && *e != ':' && !isSPACE(*e))
+       STRLEN alen = 0;
+       if (!isIDFIRST(*s))
         {
-         if (*e == '(')
-          {
-           if (!as)
-            as = e;
-           count++;
-          }
-         else if (*e == ')')
-          {
-           if (as && --count == 0)
-            ae = e;
-          }
-         e++;
+         /* Message is consistent with how attribute lists are passed.
+            Even though this means "foo : : bar" is seen as an invalid separator
+            character.  */
+         char q = ((*s == '\'') ? '"' : '\'');
+         Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q);
+         return -1;
         }
-       if (e > s)
+       do
+        {
+         e++;
+        } while (isALNUM(*e));
+       llen = e-s;
+       if (*e == '(')
         {
-         if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
+         int nesting = 1;
+         as = ++e;
+         while (nesting)
           {
-           /* Pop back to bottom layer */
-           if (PerlIONext(f))
+           switch (*e++)
             {
-             PerlIO_flush(f);
-             while (PerlIONext(f))
-              {
-               PerlIO_pop(f);
-              }
+             case ')':
+              if (--nesting == 0)
+               alen = (e-1)-as;
+              break;
+             case '(':
+              ++nesting;
+              break;
+             case '\\':
+              /* It's a nul terminated string, not allowed to \ the terminating null.
+                 Anything other character is passed over.  */
+              if (*e++)
+               {
+                break;
+               }
+              /* Drop through */
+             case '\0':
+              e--;
+              Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s);
+              return -1;
+             default:
+              /* boring.  */
+              break;
             }
           }
-         else if ((e - s) == 4 && strncmp(s,"utf8",4) == 0)
-          {
-           PerlIOBase(f)->flags |= PERLIO_F_UTF8;
-          }
-         else if ((e - s) == 5 && strncmp(s,"bytes",5) == 0)
-          {
-           PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
-          }
-         else
+        }
+       if (e > s)
+        {
+         SV *layer = PerlIO_find_layer(s,llen);
+         if (layer)
           {
-           STRLEN len = ((as) ? as : e)-s;
-           SV *layer = PerlIO_find_layer(s,len);
-           if (layer)
+           PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
+           if (tab)
             {
-             PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
-             if (tab)
-              {
-               len = (as) ? (ae-(as++)-1) : 0;
-               if (!PerlIO_push(f,tab,mode,as,len))
-                return -1;
-              }
+             if (!PerlIO_push(f,tab,mode,as,alen))
+              return -1;
             }
-           else
-            Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)len,s);
           }
+         else {
+          Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s);
+	  return -1;
+	 }
         }
        s = e;
       }
@@ -817,7 +846,17 @@ PerlIO_flush(PerlIO *f)
 {
  if (f)
   {
-   return (*PerlIOBase(f)->tab->Flush)(f);
+   PerlIO_funcs *tab = PerlIOBase(f)->tab;
+   if (tab && tab->Flush)
+    {
+     return (*tab->Flush)(f);
+    }
+   else
+    {
+     PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name);
+     errno = EINVAL;
+     return -1;
+    }
   }
  else
   {
@@ -985,6 +1024,22 @@ PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 /*--------------------------------------------------------------------------------------*/
 /* utf8 and raw dummy layers */
 
+IV
+PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
+{
+ if (PerlIONext(f))
+  {
+   PerlIO_funcs *tab = PerlIOBase(f)->tab;
+   PerlIO_pop(f);
+   if (tab->kind & PERLIO_K_UTF8)
+    PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+   else
+    PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
+   return 0;
+  }
+ return -1;
+}
+
 PerlIO *
 PerlIOUtf8_fdopen(PerlIO_funcs *self, int fd,const char *mode)
 {
@@ -992,8 +1047,12 @@ PerlIOUtf8_fdopen(PerlIO_funcs *self, int fd,const char *mode)
  PerlIO *f = (*tab->Fdopen)(tab,fd,mode);
  if (f)
   {
-   PerlIOBase(f)->flags |= PERLIO_F_UTF8;
-  }
+   PerlIOl *l = PerlIOBase(f);
+   if (tab->kind & PERLIO_K_UTF8)
+    l->flags |= PERLIO_F_UTF8;
+   else
+    l->flags &= ~PERLIO_F_UTF8;
+ }
  return f;
 }
 
@@ -1004,7 +1063,11 @@ PerlIOUtf8_open(PerlIO_funcs *self, const char *path,const char *mode)
  PerlIO *f = (*tab->Open)(tab,path,mode);
  if (f)
   {
-   PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+   PerlIOl *l = PerlIOBase(f);
+   if (tab->kind & PERLIO_K_UTF8)
+    l->flags |= PERLIO_F_UTF8;
+   else
+    l->flags &= ~PERLIO_F_UTF8;
   }
  return f;
 }
@@ -1012,7 +1075,36 @@ PerlIOUtf8_open(PerlIO_funcs *self, const char *path,const char *mode)
 PerlIO_funcs PerlIO_utf8 = {
  "utf8",
  sizeof(PerlIOl),
- PERLIO_K_DUMMY|PERLIO_K_BUFFERED,
+ PERLIO_K_DUMMY|PERLIO_F_UTF8,
+ NULL,
+ PerlIOUtf8_fdopen,
+ PerlIOUtf8_open,
+ NULL,
+ PerlIOUtf8_pushed,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL, /* flush */
+ NULL, /* fill */
+ NULL,
+ NULL,
+ NULL,
+ NULL,
+ NULL, /* get_base */
+ NULL, /* get_bufsiz */
+ NULL, /* get_ptr */
+ NULL, /* get_cnt */
+ NULL, /* set_ptrcnt */
+};
+
+PerlIO_funcs PerlIO_byte = {
+ "bytes",
+ sizeof(PerlIOl),
+ PERLIO_K_DUMMY,
  NULL,
  PerlIOUtf8_fdopen,
  PerlIOUtf8_open,
@@ -1041,27 +1133,27 @@ PerlIO_funcs PerlIO_utf8 = {
 PerlIO *
 PerlIORaw_fdopen(PerlIO_funcs *self, int fd,const char *mode)
 {
- PerlIO_funcs *tab = PerlIO_default_layer(0);
+ PerlIO_funcs *tab = PerlIO_default_btm();
  return (*tab->Fdopen)(tab,fd,mode);
 }
 
 PerlIO *
 PerlIORaw_open(PerlIO_funcs *self, const char *path,const char *mode)
 {
- PerlIO_funcs *tab = PerlIO_default_layer(0);
+ PerlIO_funcs *tab = PerlIO_default_btm();
  return (*tab->Open)(tab,path,mode);
 }
 
 PerlIO_funcs PerlIO_raw = {
  "raw",
  sizeof(PerlIOl),
- PERLIO_K_DUMMY|PERLIO_K_RAW,
+ PERLIO_K_DUMMY,
  NULL,
  PerlIORaw_fdopen,
  PerlIORaw_open,
  NULL,
  PerlIORaw_pushed,
- NULL,
+ PerlIOBase_popped,
  NULL,
  NULL,
  NULL,
@@ -1343,6 +1435,20 @@ PerlIOUnix_fileno(PerlIO *f)
  return PerlIOSelf(f,PerlIOUnix)->fd;
 }
 
+IV
+PerlIOUnix_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
+{
+ IV code = PerlIOBase_pushed(f,mode,arg,len);
+ if (*PerlIONext(f))
+  {
+   PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix);
+   s->fd     = PerlIO_fileno(PerlIONext(f));
+   s->oflags = PerlIOUnix_oflags(mode);
+  }
+ PerlIOBase(f)->flags |= PERLIO_F_OPEN;
+ return code;
+}
+
 PerlIO *
 PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
 {
@@ -1358,7 +1464,6 @@ PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
      PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix);
      s->fd     = fd;
      s->oflags = oflags;
-     PerlIOBase(f)->flags |= PERLIO_F_OPEN;
     }
   }
  return f;
@@ -1493,7 +1598,7 @@ PerlIO_funcs PerlIO_unix = {
  PerlIOUnix_fdopen,
  PerlIOUnix_open,
  PerlIOUnix_reopen,
- PerlIOBase_pushed,
+ PerlIOUnix_pushed,
  PerlIOBase_noop_ok,
  PerlIOUnix_read,
  PerlIOBase_unread,
@@ -1589,6 +1694,24 @@ PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
  return f;
 }
 
+/* This isn't used yet ... */
+IV
+PerlIOStdio_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
+{
+ dTHX;
+ if (*PerlIONext(f))
+  {
+   PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio);
+   char tmode[8];
+   FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode));
+   if (stdio)
+    s->stdio = stdio;
+   else
+    return -1;
+  }
+ return PerlIOBase_pushed(f,mode,arg,len);
+}
+
 #undef PerlIO_importFILE
 PerlIO *
 PerlIO_importFILE(FILE *stdio, int fl)
@@ -2028,11 +2151,10 @@ PerlIOBuf_flush(PerlIO *f)
    /* write() the buffer */
    STDCHAR *buf = b->buf;
    STDCHAR *p = buf;
-   int count;
    PerlIO *n = PerlIONext(f);
    while (p < b->ptr)
     {
-     count = PerlIO_write(n,p,b->ptr - p);
+     SSize_t count = PerlIO_write(n,p,b->ptr - p);
      if (count > 0)
       {
        p += count;