Make "real" layers of ":utf8" and ":raw".

 So now PERLIO=utf8 perl ...
does what Andreas wanted.
Fix arg passing in open.pm (still have a Carp issue).

p4raw-id: //depot/perlio@8511

diff --git a/lib/open.pm b/lib/open.pm
index 1e073c2..53ae308 100644 (file)
--- a/lib/open.pm
+++ b/lib/open.pm
@@ -7,22 +7,25 @@ use vars qw(%layers @layers);
 # Populate hash in non-PerlIO case
 %layers = (crlf => 1, raw => 0) unless (@layers);
 
+# warn join(',',keys %layers);
+
 our $VERSION = '1.00';
 
 sub import {
-    shift;
-    die "`use open' needs explicit list of disciplines" unless @_;
+    my ($class,@args) = @_;
+    croak("`use open' needs explicit list of disciplines") unless @args;
     $^H |= $open::hint_bits;
     my ($in,$out) = split(/\0/,(${^OPEN} || '\0'));
     my @in  = split(/\s+/,$in);
     my @out = split(/\s+/,$out);
-    while (@_) {
-       my $type = shift;
-       my $discp = shift;
+    while (@args) {
+       my $type = shift(@args);
+       my $discp = shift(@args);
        my @val;
-       foreach my $layer (split(/\s+:?/,$discp)) {
+       foreach my $layer (split(/\s+/,$discp)) {
+            $layer =~ s/^://;
            unless(exists $layers{$layer}) {
-               croak "Unknown discipline layer '$layer'";
+               carp("Unknown discipline layer '$layer'");
            }
            push(@val,":$layer");
            if ($layer =~ /^(crlf|raw)$/) {

diff --git a/perlio.c b/perlio.c
index 61af376..1c8f65d 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -417,8 +417,30 @@ PerlIO_define_layer(PerlIO_funcs *tab)
  HV *stash = gv_stashpv("perlio::Layer", TRUE);
  SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash);
  hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0);
+ PerlIO_debug("define %s %p\n",tab->name,tab);
 }
 
+void
+PerlIO_default_buffer(pTHX)
+{
+ PerlIO_funcs *tab = &PerlIO_perlio;
+ if (O_BINARY != O_TEXT)
+  {
+   tab = &PerlIO_crlf;
+  }
+ else
+  {
+   if (PerlIO_stdio.Set_ptrcnt)
+    {
+     tab = &PerlIO_stdio;
+    }
+  }
+ PerlIO_debug("Pushing %s\n",tab->name);
+ av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(tab->name,0)));
+
+}
+
+
 PerlIO_funcs *
 PerlIO_default_layer(I32 n)
 {
@@ -437,6 +459,7 @@ PerlIO_default_layer(I32 n)
 #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);
    PerlIO_define_layer(&PerlIO_stdio);
@@ -444,9 +467,11 @@ PerlIO_default_layer(I32 n)
 #ifdef HAS_MMAP
    PerlIO_define_layer(&PerlIO_mmap);
 #endif
+   PerlIO_define_layer(&PerlIO_utf8);
    av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0)));
    if (s)
     {
+     IV buffered = 0;
      while (*s)
       {
        while (*s && isSPACE((unsigned char)*s))
@@ -462,8 +487,15 @@ PerlIO_default_layer(I32 n)
          layer = PerlIO_find_layer(s,e-s);
          if (layer)
           {
+           PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
+           if ((tab->kind & PERLIO_K_DUMMY) && (tab->kind & PERLIO_K_BUFFERED))
+            {
+             if (!buffered)
+              PerlIO_default_buffer(aTHX);
+            }
            PerlIO_debug("Pushing %.*s\n",(e-s),s);
            av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
+           buffered |= (tab->kind & PERLIO_K_BUFFERED);
           }
          else
           Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
@@ -475,21 +507,7 @@ PerlIO_default_layer(I32 n)
  len  = av_len(PerlIO_layer_av);
  if (len < 1)
   {
-   if (O_BINARY != O_TEXT)
-    {
-     av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0)));
-    }
-   else
-    {
-     if (PerlIO_stdio.Set_ptrcnt)
-      {
-       av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0)));
-      }
-     else
-      {
-       av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
-      }
-    }
+   PerlIO_default_buffer(aTHX);
    len  = av_len(PerlIO_layer_av);
   }
  if (n < 0)
@@ -541,6 +559,34 @@ PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN
  return f;
 }
 
+IV
+PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
+{
+ if (PerlIONext(f))
+  {
+   PerlIO_pop(f);
+   PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+   return 0;
+  }
+ return -1;
+}
+
+IV
+PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len)
+{
+ /* Pop back to bottom layer */
+ if (PerlIONext(f))
+  {
+   PerlIO_flush(f);
+   while (PerlIONext(f))
+    {
+     PerlIO_pop(f);
+    }
+   return 0;
+  }
+ return -1;
+}
+
 int
 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 {
@@ -937,6 +983,105 @@ PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 }
 
 /*--------------------------------------------------------------------------------------*/
+/* utf8 and raw dummy layers */
+
+PerlIO *
+PerlIOUtf8_fdopen(PerlIO_funcs *self, int fd,const char *mode)
+{
+ PerlIO_funcs *tab = PerlIO_default_layer(-2);
+ PerlIO *f = (*tab->Fdopen)(tab,fd,mode);
+ if (f)
+  {
+   PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+  }
+ return f;
+}
+
+PerlIO *
+PerlIOUtf8_open(PerlIO_funcs *self, const char *path,const char *mode)
+{
+ PerlIO_funcs *tab = PerlIO_default_layer(-2);
+ PerlIO *f = (*tab->Open)(tab,path,mode);
+ if (f)
+  {
+   PerlIOBase(f)->flags |= PERLIO_F_UTF8;
+  }
+ return f;
+}
+
+PerlIO_funcs PerlIO_utf8 = {
+ "utf8",
+ sizeof(PerlIOl),
+ PERLIO_K_DUMMY|PERLIO_K_BUFFERED,
+ 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 *
+PerlIORaw_fdopen(PerlIO_funcs *self, int fd,const char *mode)
+{
+ PerlIO_funcs *tab = PerlIO_default_layer(0);
+ 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);
+ return (*tab->Open)(tab,path,mode);
+}
+
+PerlIO_funcs PerlIO_raw = {
+ "raw",
+ sizeof(PerlIOl),
+ PERLIO_K_DUMMY|PERLIO_K_RAW,
+ NULL,
+ PerlIORaw_fdopen,
+ PerlIORaw_open,
+ NULL,
+ PerlIORaw_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 */
+};
+/*--------------------------------------------------------------------------------------*/
+/*--------------------------------------------------------------------------------------*/
 /* "Methods" of the "base class" */
 
 IV
@@ -3004,6 +3149,8 @@ PerlIO_init(void)
   }
 }
 
+
+
 #undef PerlIO_stdin
 PerlIO *
 PerlIO_stdin(void)

diff --git a/perliol.h b/perliol.h
index 04c7071..f524fcd 100644 (file)
--- a/perliol.h
+++ b/perliol.h
@@ -40,6 +40,7 @@ struct _PerlIO_funcs
 #define PERLIO_K_BUFFERED      0x00000002
 #define PERLIO_K_CANCRLF       0x00000004
 #define PERLIO_K_FASTGETS      0x00000008
+#define PERLIO_K_DUMMY         0x00000010
 
 /*--------------------------------------------------------------------------------------*/
 struct _PerlIO
@@ -78,6 +79,8 @@ extern PerlIO_funcs PerlIO_unix;
 extern PerlIO_funcs PerlIO_perlio;
 extern PerlIO_funcs PerlIO_stdio;
 extern PerlIO_funcs PerlIO_crlf;
+extern PerlIO_funcs PerlIO_utf8;
+extern PerlIO_funcs PerlIO_raw;
 /* The EXT is need for Cygwin -- but why only for _pending? --jhi */
 EXT PerlIO_funcs PerlIO_pending;
 #ifdef HAS_MMAP