Not merge worthy...

Allow arg to layers e.g. open($fh,"<:encode(iso8859-15)",$name)
syntax is modelled on attributes.
Untested fix for io/utf8 on Win32 etc.
Very clumsy start to the encode layer.

p4raw-id: //depot/perlio@8076

4 files changed, 286 insertions, 34 deletions

diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs
index 9dea8d0bf5..3bdc3f7a92 100644
--- a/ext/Encode/Encode.xs
+++ b/ext/Encode/Encode.xs
@@ -9,6 +9,232 @@
 UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
 UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
 
+#ifdef USE_PERLIO
+#include "perliol.h"
+
+typedef struct
+{
+ PerlIOBuf	base;         /* PerlIOBuf stuff */
+ SV *		bufsv;
+ SV *		enc;
+} PerlIOEncode;
+
+
+IV
+PerlIOEncode_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
+{
+ PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
+ dTHX;
+ dSP;
+ IV code;
+ code = PerlIOBuf_pushed(f,mode,Nullch,0);
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+ XPUSHs(sv_2mortal(newSVpv("Encode",0)));
+ XPUSHs(sv_2mortal(newSVpvn(arg,len)));
+ PUTBACK;
+ if (perl_call_method("getEncoding",G_SCALAR) != 1)
+  return -1;
+ SPAGAIN;
+ e->enc = POPs;
+ PUTBACK;
+ if (!SvROK(e->enc))
+  return -1;
+ SvREFCNT_inc(e->enc);
+ FREETMPS;
+ LEAVE;
+ PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+ return code;
+}
+
+IV
+PerlIOEncode_popped(PerlIO *f)
+{
+ PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
+ dTHX;
+ if (e->enc)
+  {
+   SvREFCNT_dec(e->enc);
+   e->enc = Nullsv;
+  }
+ if (e->bufsv)
+  {
+   SvREFCNT_dec(e->bufsv);
+   e->bufsv = Nullsv;
+  }
+ return 0;
+}
+
+STDCHAR *
+PerlIOEncode_get_base(PerlIO *f)
+{
+ PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
+ dTHX;
+ if (!e->base.bufsiz)
+  e->base.bufsiz = 1024;
+ if (!e->bufsv)
+  {
+   e->bufsv = newSV(e->base.bufsiz);
+   sv_setpvn(e->bufsv,"",0);
+  }
+ e->base.buf = SvPVX(e->bufsv);
+ if (!e->base.ptr)
+  e->base.ptr = e->base.buf;
+ if (!e->base.end)
+  e->base.end = e->base.buf;
+ if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv))
+  {
+   Perl_warn(aTHX_ " ptr %p(%p)%p",
+             e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv));
+   abort();
+  }
+ if (SvLEN(e->bufsv) < e->base.bufsiz)
+  {
+   SSize_t poff = e->base.ptr - e->base.buf;
+   SSize_t eoff = e->base.end - e->base.buf;
+   e->base.buf  = SvGROW(e->bufsv,e->base.bufsiz);
+   e->base.ptr  = e->base.buf + poff;
+   e->base.end  = e->base.buf + eoff;
+  }
+ if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv))
+  {
+   Perl_warn(aTHX_ " ptr %p(%p)%p",
+             e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv));
+   abort();
+  }
+ return e->base.buf;
+}
+
+static void
+Break(void)
+{
+
+}
+
+IV
+PerlIOEncode_fill(PerlIO *f)
+{
+ PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
+ dTHX;
+ dSP;
+ IV code;
+ Break();
+ code = PerlIOBuf_fill(f);
+ if (code == 0)
+  {
+   SV *uni;
+   SvCUR_set(e->bufsv, e->base.end - e->base.buf);
+   SvUTF8_off(e->bufsv);
+   ENTER;
+   SAVETMPS;
+   PUSHMARK(sp);
+   XPUSHs(e->enc);
+   XPUSHs(e->bufsv);
+   XPUSHs(&PL_sv_yes);
+   PUTBACK;
+   if (perl_call_method("toUnicode",G_SCALAR) != 1)
+    code = -1;
+   SPAGAIN;
+   uni = POPs;
+   PUTBACK;
+   sv_setsv(e->bufsv,uni);
+   sv_utf8_upgrade(e->bufsv);
+   e->base.buf    = SvPVX(e->bufsv);
+   e->base.end    = e->base.buf+SvCUR(e->bufsv);
+   e->base.ptr    = e->base.buf;
+   FREETMPS;
+   LEAVE;
+  }
+ return code;
+}
+
+IV
+PerlIOEncode_flush(PerlIO *f)
+{
+ PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
+ IV code = 0;
+ dTHX;
+ if (e->bufsv && (PerlIOBase(f)->flags & (PERLIO_F_RDBUF|PERLIO_F_WRBUF)))
+  {
+   dSP;
+   SV *str;
+   char *s;
+   STRLEN len;
+   ENTER;
+   SAVETMPS;
+   PUSHMARK(sp);
+   XPUSHs(e->enc);
+   SvCUR_set(e->bufsv, e->base.end - e->base.buf);
+   SvUTF8_on(e->bufsv);
+   XPUSHs(e->bufsv);
+   XPUSHs(&PL_sv_yes);
+   PUTBACK;
+   if (perl_call_method("fromUnicode",G_SCALAR) != 1)
+    code = -1;
+   SPAGAIN;
+   str = POPs;
+   PUTBACK;
+   sv_setsv(e->bufsv,str);
+   SvUTF8_off(e->bufsv);
+   e->base.buf = SvPVX(e->bufsv);
+   e->base.ptr = e->base.buf+SvCUR(e->bufsv);
+   FREETMPS;
+   LEAVE;
+   if (PerlIOBuf_flush(f) != 0)
+    code = -1;
+  }
+ return code;
+}
+
+IV
+PerlIOEncode_close(PerlIO *f)
+{
+ PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
+ IV code = PerlIOBase_close(f);
+ dTHX;
+ if (e->bufsv)
+  {
+   SvREFCNT_dec(e->bufsv);
+   e->bufsv = Nullsv;
+  }
+ e->base.buf = NULL;
+ e->base.ptr = NULL;
+ e->base.end = NULL;
+ PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
+ return code;
+}
+
+PerlIO_funcs PerlIO_encode = {
+ "encode",
+ sizeof(PerlIOEncode),
+ PERLIO_K_BUFFERED,
+ PerlIOBase_fileno,
+ PerlIOBuf_fdopen,
+ PerlIOBuf_open,
+ PerlIOBuf_reopen,
+ PerlIOEncode_pushed,
+ PerlIOEncode_popped,
+ PerlIOBuf_read,
+ PerlIOBuf_unread,
+ PerlIOBuf_write,
+ PerlIOBuf_seek,
+ PerlIOBuf_tell,
+ PerlIOEncode_close,
+ PerlIOEncode_flush,
+ PerlIOEncode_fill,
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBuf_setlinebuf,
+ PerlIOEncode_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOBuf_get_cnt,
+ PerlIOBuf_set_ptrcnt,
+};
+#endif
+
 void call_failure (SV *routine, U8* done, U8* dest, U8* orig) {}
 
 MODULE = Encode         PACKAGE = Encode
@@ -239,3 +465,9 @@ _utf_to_utf(sv, from, to, ...)
       OUTPUT:
 	RETVAL
 
+BOOT:
+{
+#ifdef USE_PERLIO
+ PerlIO_define_layer(&PerlIO_encode);
+#endif
+}
diff --git a/perlio.c b/perlio.c
index 278dde1991..f4a86d8967 100644
--- a/perlio.c
+++ b/perlio.c
@@ -520,7 +520,7 @@ PerlIO_stdstreams()
 }
 
 PerlIO *
-PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
+PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len)
 {
  dTHX;
  PerlIOl *l = NULL;
@@ -532,7 +532,7 @@ PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
    l->tab  = tab;
    *f      = l;
    PerlIO_debug("PerlIO_push f=%p %s %s\n",f,tab->name,(mode) ? mode : "(Null)");
-   if ((*l->tab->Pushed)(f,mode) != 0)
+   if ((*l->tab->Pushed)(f,mode,arg,len) != 0)
     {
      PerlIO_pop(f);
      return NULL;
@@ -556,8 +556,24 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
      if (*s)
       {
        const char *e = s;
+       const char *as = Nullch;
+       const char *ae = Nullch;
+       int count = 0;
        while (*e && *e != ':' && !isSPACE(*e))
-        e++;
+        {
+         if (*e == '(')
+          {
+           if (!as)
+            as = e;
+           count++;
+          }
+         else if (*e == ')')
+          {
+           if (as && --count == 0)
+            ae = e;
+          }
+         e++;
+        }
        if (e > s)
         {
          if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
@@ -582,19 +598,20 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
           }
          else
           {
-           SV *layer = PerlIO_find_layer(s,e-s);
+           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 *new = PerlIO_push(f,tab,mode);
-               if (!new)
+               len = (as) ? (ae-(as++)-1) : 0;
+               if (!PerlIO_push(f,tab,mode,as,len))
                 return -1;
               }
             }
            else
-            Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
+            Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)len,s);
           }
         }
        s = e;
@@ -614,7 +631,7 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
 {
  PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n",
               f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
- if (!names || (O_TEXT != O_BINARY && (mode & O_BINARY)))
+ if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY)))
   {
    PerlIO *top = f;
    PerlIOl *l;
@@ -704,7 +721,7 @@ PerlIO_reopen(const char *path, const char *mode, PerlIO *f)
    PerlIO_flush(f);
    if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0)
     {
-     if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0)
+     if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0)
       return f;
     }
    return NULL;
@@ -964,7 +981,7 @@ PerlIO_modestr(PerlIO *f,char *buf)
 }
 
 IV
-PerlIOBase_pushed(PerlIO *f, const char *mode)
+PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
 {
  PerlIOl *l = PerlIOBase(f);
  const char *omode = mode;
@@ -1049,7 +1066,7 @@ PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
    return 0;
   }
 #else
- PerlIO_push(f,&PerlIO_pending,"r");
+ PerlIO_push(f,&PerlIO_pending,"r",Nullch,0);
  return PerlIOBuf_unread(f,vbuf,count);
 #endif
 }
@@ -1204,7 +1221,7 @@ PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode)
    int oflags = PerlIOUnix_oflags(mode);
    if (oflags != -1)
     {
-     PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
+     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;
@@ -1224,7 +1241,7 @@ PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode)
    int fd = PerlLIO_open3(path,oflags,0666);
    if (fd >= 0)
     {
-     PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOUnix);
+     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;
@@ -1428,7 +1445,7 @@ PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode)
     }
    if (stdio)
     {
-     PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode),PerlIOStdio);
+     PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio);
      s->stdio  = stdio;
     }
   }
@@ -1443,7 +1460,7 @@ PerlIO_importFILE(FILE *stdio, int fl)
  PerlIO *f = NULL;
  if (stdio)
   {
-   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+"),PerlIOStdio);
+   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio);
    s->stdio  = stdio;
   }
  return f;
@@ -1459,7 +1476,7 @@ PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
   {
    char tmode[8];
    PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self,
-                               (mode = PerlIOStdio_mode(mode,tmode))),
+                               (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0),
                                PerlIOStdio);
    s->stdio  = stdio;
   }
@@ -1783,11 +1800,11 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f)
 /* perlio buffer layer */
 
 IV
-PerlIOBuf_pushed(PerlIO *f, const char *mode)
+PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
 {
  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
  b->posn = PerlIO_tell(PerlIONext(f));
- return PerlIOBase_pushed(f,mode);
+ return PerlIOBase_pushed(f,mode,arg,len);
 }
 
 PerlIO *
@@ -1809,7 +1826,7 @@ PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
  f = (*tab->Fdopen)(tab,fd,mode);
  if (f)
   {
-   PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
+   PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf);
    if (init && fd == 2)
     {
      /* Initial stderr is unbuffered */
@@ -1830,7 +1847,7 @@ PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
  PerlIO *f = (*tab->Open)(tab,path,mode);
  if (f)
   {
-   PerlIO_push(f,self,mode);
+   PerlIO_push(f,self,mode,Nullch,0);
   }
  return f;
 }
@@ -1841,7 +1858,7 @@ PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
  PerlIO *next = PerlIONext(f);
  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
  if (code = 0)
-  code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
+  code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0);
  return code;
 }
 
@@ -1856,7 +1873,8 @@ PerlIOBuf_flush(PerlIO *f)
  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
   {
    /* write() the buffer */
-   STDCHAR *p = b->buf;
+   STDCHAR *buf = PerlIO_get_base(f);
+   STDCHAR *p = buf;
    int count;
    PerlIO *n = PerlIONext(f);
    while (p < b->ptr)
@@ -1873,12 +1891,13 @@ PerlIOBuf_flush(PerlIO *f)
        break;
       }
     }
-   b->posn += (p - b->buf);
+   b->posn += (p - buf);
   }
  else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
   {
+   STDCHAR *buf = PerlIO_get_base(f);
    /* Note position change */
-   b->posn += (b->ptr - b->buf);
+   b->posn += (b->ptr - buf);
    if (b->ptr < b->end)
     {
      /* We did not consume all of it */
@@ -1901,6 +1920,7 @@ PerlIOBuf_fill(PerlIO *f)
 {
  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
  PerlIO *n = PerlIONext(f);
+ STDCHAR *buf;
  SSize_t avail;
  /* FIXME: doing the down-stream flush is a bad idea if it causes
     pre-read data in stdio buffer to be discarded
@@ -1913,7 +1933,7 @@ PerlIOBuf_fill(PerlIO *f)
  if (PerlIO_flush(f) != 0)
   return -1;
 
- b->ptr = b->end = b->buf;
+ b->ptr = b->end = buf = PerlIO_get_base(f);
  if (PerlIO_fast_gets(n))
   {
    /* Layer below is also buffered
@@ -1955,7 +1975,7 @@ PerlIOBuf_fill(PerlIO *f)
     PerlIOBase(f)->flags |= PERLIO_F_ERROR;
    return -1;
   }
- b->end      = b->buf+avail;
+ b->end      = buf+avail;
  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
  return 0;
 }
@@ -2291,9 +2311,9 @@ PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
 }
 
 IV
-PerlIOPending_pushed(PerlIO *f,const char *mode)
+PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len)
 {
- IV code    = PerlIOBuf_pushed(f,mode);
+ IV code    = PerlIOBuf_pushed(f,mode,arg,len);
  PerlIOl *l = PerlIOBase(f);
  /* Our PerlIO_fast_gets must match what we are pushed on,
     or sv_gets() etc. get muddled when it changes mid-string
@@ -2364,11 +2384,11 @@ typedef struct
 } PerlIOCrlf;
 
 IV
-PerlIOCrlf_pushed(PerlIO *f, const char *mode)
+PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len)
 {
  IV code;
  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
- code = PerlIOBuf_pushed(f,mode);
+ code = PerlIOBuf_pushed(f,mode,arg,len);
 #if 0
  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n",
               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
@@ -3119,7 +3139,7 @@ PerlIO_tmpfile(void)
  FILE *stdio = PerlSIO_tmpfile();
  if (stdio)
   {
-   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+"),PerlIOStdio);
+   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio);
    s->stdio  = stdio;
   }
  return f;
diff --git a/perlio.h b/perlio.h
index 7d4cdcd2dc..b2e5179470 100644
--- a/perlio.h
+++ b/perlio.h
@@ -82,7 +82,7 @@ typedef PerlIOl *PerlIO;
 
 extern void	PerlIO_define_layer	(PerlIO_funcs *tab);
 extern SV *	PerlIO_find_layer	(const char *name, STRLEN len);
-extern PerlIO *	PerlIO_push		(PerlIO *f,PerlIO_funcs *tab,const char *mode);
+extern PerlIO *	PerlIO_push		(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len);
 extern void	PerlIO_pop		(PerlIO *f);
 
 #endif /* PerlIO */
diff --git a/perliol.h b/perliol.h
index 19cf95f620..47751fe6ed 100644
--- a/perliol.h
+++ b/perliol.h
@@ -10,7 +10,7 @@ struct _PerlIO_funcs
  PerlIO *	(*Fdopen)(PerlIO_funcs *tab, int fd, const char *mode);
  PerlIO *	(*Open)(PerlIO_funcs *tab, const char *path, const char *mode);
  int		(*Reopen)(const char *path, const char *mode, PerlIO *f);
- IV		(*Pushed)(PerlIO *f,const char *mode);
+ IV		(*Pushed)(PerlIO *f,const char *mode,const char *arg,STRLEN len);
  IV		(*Popped)(PerlIO *f);
  /* Unix-like functions - cf sfio line disciplines */
  SSize_t	(*Read)(PerlIO *f, void *vbuf, Size_t count);
@@ -94,7 +94,7 @@ extern PerlIO *PerlIO_allocate(pTHX);
 /* Generic, or stub layer functions */
 
 extern IV	PerlIOBase_fileno    (PerlIO *f);
-extern IV	PerlIOBase_pushed    (PerlIO *f, const char *mode);
+extern IV	PerlIOBase_pushed    (PerlIO *f, const char *mode,const char *arg,STRLEN len);
 extern IV	PerlIOBase_popped    (PerlIO *f);
 extern SSize_t	PerlIOBase_unread    (PerlIO *f, const void *vbuf, Size_t count);
 extern IV	PerlIOBase_eof       (PerlIO *f);