This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
"Clean" implementation of binmode(FH)/":raw" identity.
authorNick Ing-Simmons <nik@tiuk.ti.com>
Wed, 19 Jun 2002 20:50:54 +0000 (20:50 +0000)
committerNick Ing-Simmons <nik@tiuk.ti.com>
Wed, 19 Jun 2002 20:50:54 +0000 (20:50 +0000)
New function table entry so all layer definitions need tweaking.
Extra function table entry allows a layer to remain on a binmode stack
New PerlIOBase_binmode allows easy implementation of default policy.

p4raw-id: //depot/perlio@17309

ext/PerlIO/Scalar/Scalar.xs
ext/PerlIO/Via/Via.pm
ext/PerlIO/Via/Via.xs
ext/PerlIO/encoding/encoding.xs
makedef.pl
perlio.c
perliol.h
pod/perliol.pod
win32/win32io.c

index c904394..314c0f3 100644 (file)
@@ -265,10 +265,11 @@ PerlIOScalar_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 PerlIO_funcs PerlIO_scalar = {
  "Scalar",
  sizeof(PerlIOScalar),
- PERLIO_K_BUFFERED,
+ PERLIO_K_BUFFERED|PERLIO_K_RAW,
  PerlIOScalar_pushed,
  PerlIOScalar_popped,
  PerlIOScalar_open,
+ PerlIOBase_binmode,
  PerlIOScalar_arg,
  PerlIOScalar_fileno,
  PerlIOScalar_dup,
index 01805ca..92614b4 100644 (file)
@@ -46,6 +46,12 @@ Optional - layer is about to be removed.
 
 Not yet in use.
 
+=item $obj->BINMODE([,$fh])
+
+Optional - if not available layer is popped on binmode($fh) or when C<:raw>
+is pushed. If present it should return 0 on success -1 on error and undef
+to pop the layer.
+
 =item $class->FDOPEN($fd)
 
 Not yet in use.
index 6835f58..d1ebab2 100644 (file)
@@ -34,6 +34,7 @@ typedef struct
  CV *CLEARERR;
  CV *mERROR;
  CV *mEOF;
+ CV *BINMODE;
 } PerlIOVia;
 
 #define MYMethod(x) #x,&s->x
@@ -318,6 +319,19 @@ PerlIOVia_fileno(pTHX_ PerlIO *f)
 }
 
 IV
+PerlIOVia_binmode(pTHX_ PerlIO *f)
+{
+ PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
+ SV *result = PerlIOVia_method(aTHX_ f,MYMethod(BINMODE),G_SCALAR,Nullsv);
+ if (!result || !SvOK(result))
+  {
+   PerlIO_pop(aTHX_ f);
+   return 0;
+  }
+ return SvIV(result);
+}
+
+IV
 PerlIOVia_seek(pTHX_ PerlIO *f, Off_t offset, int whence)
 {
  PerlIOVia *s = PerlIOSelf(f,PerlIOVia);
@@ -551,6 +565,7 @@ PerlIO_funcs PerlIO_object = {
  PerlIOVia_pushed,
  PerlIOVia_popped,
  PerlIOVia_open, /* NULL, */
+ PerlIOVia_binmode, /* NULL, */
  PerlIOVia_getarg,
  PerlIOVia_fileno,
  PerlIOVia_dup,
index 2903f72..df911ed 100644 (file)
@@ -590,6 +590,7 @@ PerlIO_funcs PerlIO_encode = {
     PerlIOEncode_pushed,
     PerlIOEncode_popped,
     PerlIOBuf_open,
+    NULL, /* binmode - always pop */
     PerlIOEncode_getarg,
     PerlIOBase_fileno,
     PerlIOEncode_dup,
index e864f68..e812214 100644 (file)
@@ -738,6 +738,7 @@ my @layer_syms = qw(
                         PerlIOBase_error
                         PerlIOBase_fileno
                         PerlIOBase_pushed
+                        PerlIOBase_binmode
                         PerlIOBase_popped
                         PerlIOBase_read
                         PerlIOBase_setlinebuf
index 4916358..4728b71 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -1020,33 +1020,58 @@ PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
 }
 
 IV
+PerlIOBase_binmode(pTHX_ PerlIO *f)
+{
+   if (PerlIOValid(f)) {
+       /* Is layer suitable for raw stream ? */
+       if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) {
+           /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */
+           PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
+       }
+       else {
+           /* Not suitable - pop it */
+           PerlIO_pop(aTHX_ f);
+       }
+       return 0;
+   }
+   return -1;
+}
+
+IV
 PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
 {
-    /*
-     * Remove the dummy layer
-     */
-    PerlIO_pop(aTHX_ f);
-    /*
-     * Pop back to bottom layer
-     */
+
     if (PerlIOValid(f)) {
+       PerlIO *t;
+       PerlIOl *l;
+       PerlIO_pop(aTHX_ f);     /* Remove the dummy layer */
        PerlIO_flush(f);
-       while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW)) {
-           if (*PerlIONext(f)) {
-               PerlIO_pop(aTHX_ f);
+       /*
+        * Strip all layers that are not suitable for a raw stream
+        */
+       t = f;
+       while (t && (l = *t)) {
+           if (l->tab->Binmode) {
+               /* Has a handler - normal case */
+               if ((*l->tab->Binmode)(aTHX_ f) == 0) {
+                   if (*t == l) {
+                       /* Layer still there - move down a layer */
+                       t = PerlIONext(t);
+                   }
+               }
+               else {
+                   return -1;
+               }
            }
            else {
-               /*
-                * Nothing bellow - push unix on top then remove it
-                */
-               if (PerlIO_push(aTHX_ f, PerlIO_default_btm(), mode, arg)) {
-                   PerlIO_pop(aTHX_ PerlIONext(f));
-               }
-               break;
+               /* No handler - pop it */
+               PerlIO_pop(aTHX_ t);
            }
        }
-       PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
-       return 0;
+       if (PerlIOValid(f)) {
+           PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name);
+           return 0;
+       }
     }
     return -1;
 }
@@ -1105,22 +1130,17 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
        return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE;
     }
     else {
-       if (*f) {
-           /* Turn off UTF-8-ness, to undo UTF-8 locale effects
-              This may be too simplistic!
-            */
-           PerlIOBase(f)->flags &= ~PERLIO_F_UTF8;
-       }
-       /* FIXME?: Looking down the layer stack seems wrong,
-          but is a way of reaching past (say) an encoding layer
-          to flip CRLF-ness of the layer(s) below
-        */
+       /* Fake 5.6 legacy of using this call to turn ON O_TEXT */
 #ifdef PERLIO_USING_CRLF
        /* Legacy binmode only has meaning if O_TEXT has a value distinct from
           O_BINARY so we can look for it in mode.
         */
        if (!(mode & O_BINARY)) {
            /* Text mode */
+           /* FIXME?: Looking down the layer stack seems wrong,
+              but is a way of reaching past (say) an encoding layer
+              to flip CRLF-ness of the layer(s) below
+            */
            while (*f) {
                /* Perhaps we should turn on bottom-most aware layer
                   e.g. Ilya's idea that UNIX TTY could serve
@@ -1143,31 +1163,10 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
            return FALSE;
        }
 #endif
-       /* Either asked for BINMODE or that is normal on this platform
-          see if any CRLF aware layers are present and turn off the flag
-          and possibly remove layer.
+       /* Legacy binmode is now _defined_ as being equivalent to pushing :raw
+          So code that used to be here is now in PerlIORaw_pushed().
         */
-       while (*f) {
-           if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) {
-               if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
-                   /* In text mode - flush any pending stuff and flip it */
-                   PerlIO_flush(f);
-                   PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
-#ifndef PERLIO_USING_CRLF
-                   /* CRLF is unusual case - if this is just the :crlf layer pop it */
-                   if (PerlIOBase(f)->tab == &PerlIO_crlf) {
-                       PerlIO_pop(aTHX_ f);
-                   }
-#endif
-                   /* Normal case is only one layer doing this, so exit on first
-                      abnormal case can always do multiple binmode calls
-                    */
-                   return TRUE;
-               }
-           }
-           f = PerlIONext(f);
-       }
-       return TRUE;
+       return PerlIO_push(aTHX_ f, &PerlIO_raw, Nullch, Nullsv) ? TRUE : FALSE;
     }
 }
 
@@ -2373,6 +2372,7 @@ PerlIO_funcs PerlIO_unix = {
     PerlIOUnix_pushed,
     PerlIOBase_popped,
     PerlIOUnix_open,
+    PerlIOBase_binmode,         /* binmode */
     NULL,
     PerlIOUnix_fileno,
     PerlIOUnix_dup,
@@ -2923,10 +2923,11 @@ PerlIOStdio_fill(pTHX_ PerlIO *f)
 PerlIO_funcs PerlIO_stdio = {
     "stdio",
     sizeof(PerlIOStdio),
-    PERLIO_K_BUFFERED,
+    PERLIO_K_BUFFERED|PERLIO_K_RAW,
     PerlIOBase_pushed,
     PerlIOBase_popped,
     PerlIOStdio_open,
+    PerlIOBase_binmode,         /* binmode */
     NULL,
     PerlIOStdio_fileno,
     PerlIOStdio_dup,
@@ -3473,10 +3474,11 @@ PerlIOBuf_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 PerlIO_funcs PerlIO_perlio = {
     "perlio",
     sizeof(PerlIOBuf),
-    PERLIO_K_BUFFERED,
+    PERLIO_K_BUFFERED|PERLIO_K_RAW,
     PerlIOBuf_pushed,
     PerlIOBuf_popped,
     PerlIOBuf_open,
+    PerlIOBase_binmode,         /* binmode */
     NULL,
     PerlIOBase_fileno,
     PerlIOBuf_dup,
@@ -3594,10 +3596,11 @@ PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
 PerlIO_funcs PerlIO_pending = {
     "pending",
     sizeof(PerlIOBuf),
-    PERLIO_K_BUFFERED,
+    PERLIO_K_BUFFERED|PERLIO_K_RAW,  /* not sure about RAW here */
     PerlIOPending_pushed,
     PerlIOBuf_popped,
     NULL,
+    PerlIOBase_binmode,         /* binmode */
     NULL,
     PerlIOBase_fileno,
     PerlIOBuf_dup,
@@ -3884,13 +3887,30 @@ PerlIOCrlf_flush(pTHX_ PerlIO *f)
     return PerlIOBuf_flush(aTHX_ f);
 }
 
+IV
+PerlIOCrlf_binmode(pTHX_ PerlIO *f)
+{
+    if ((PerlIOBase(f)->flags & PERLIO_F_CRLF)) {
+       /* In text mode - flush any pending stuff and flip it */
+       PerlIOBase(f)->flags &= ~PERLIO_F_CRLF;
+#ifndef PERLIO_USING_CRLF
+       /* CRLF is unusual case - if this is just the :crlf layer pop it */
+       if (PerlIOBase(f)->tab == &PerlIO_crlf) {
+               PerlIO_pop(aTHX_ f);
+       }
+#endif
+    }
+    return 0;
+}
+
 PerlIO_funcs PerlIO_crlf = {
     "crlf",
     sizeof(PerlIOCrlf),
-    PERLIO_K_BUFFERED | PERLIO_K_CANCRLF,
+    PERLIO_K_BUFFERED | PERLIO_K_CANCRLF | PERLIO_K_RAW,
     PerlIOCrlf_pushed,
     PerlIOBuf_popped,         /* popped */
     PerlIOBuf_open,
+    PerlIOCrlf_binmode,       /* binmode */
     NULL,
     PerlIOBase_fileno,
     PerlIOBuf_dup,
@@ -4202,10 +4222,11 @@ PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 PerlIO_funcs PerlIO_mmap = {
     "mmap",
     sizeof(PerlIOMmap),
-    PERLIO_K_BUFFERED,
+    PERLIO_K_BUFFERED|PERLIO_K_RAW,
     PerlIOBuf_pushed,
     PerlIOBuf_popped,
     PerlIOBuf_open,
+    PerlIOBase_binmode,         /* binmode */
     NULL,
     PerlIOBase_fileno,
     PerlIOMmap_dup,
index 124589b..76d74a7 100644 (file)
--- a/perliol.h
+++ b/perliol.h
@@ -24,6 +24,7 @@ struct _PerlIO_funcs {
                     const char *mode,
                     int fd, int imode, int perm,
                     PerlIO *old, int narg, SV **args);
+    IV (*Binmode)(pTHX_ PerlIO *f);
     SV *(*Getarg) (pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags);
     IV (*Fileno) (pTHX_ PerlIO *f);
     PerlIO *(*Dup) (pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags);
@@ -125,6 +126,7 @@ 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_popped(pTHX_ PerlIO *f);
+extern IV PerlIOBase_binmode(pTHX_ PerlIO *f);
 extern SSize_t PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count);
 extern SSize_t PerlIOBase_unread(pTHX_ PerlIO *f, const void *vbuf,
                                 Size_t count);
index b4c8069..81cbab1 100644 (file)
@@ -98,6 +98,7 @@ same as the public C<PerlIO_xxxxx> functions:
                        int fd, int imode, int perm,
                        PerlIO *old,
                        int narg, SV **args);
+   IV          (*Binmode)(pTHX_ PerlIO *f);
    SV *                (*Getarg)(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
    IV          (*Fileno)(pTHX_ PerlIO *f);
    PerlIO *     (*Dup)(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
@@ -346,24 +347,31 @@ The size of the per-instance data structure, e.g.:
 
        IV kind;
 
- XXX: explain all the available flags here
-
 =over 4
 
 =item * PERLIO_K_BUFFERED
 
+The layer is buffered.
+
+=item * PERLIO_K_RAW
+
+The layer is acceptable to have in a binmode(FH) stack - i.e. it does not
+(or will configure itself not to) transform bytes passing through it.
+
 =item * PERLIO_K_CANCRLF
 
+Layer can translate between "\n" and CRLF line ends.
+
 =item * PERLIO_K_FASTGETS
 
+Layer allows buffer snooping.
+
 =item * PERLIO_K_MULTIARG
 
 Used when the layer's open() accepts more arguments than usual. The
 extra arguments should come not before the C<MODE> argument. When this
 flag is used it's up to the layer to validate the args.
 
-=item * PERLIO_K_RAW
-
 =back
 
 =item Pushed
@@ -455,6 +463,16 @@ then push itself on top if that succeeds.
 
 Returns C<NULL> on failure.
 
+=item Binmode
+
+       IV        (*Binmode)(pTHX_ PerlIO *f);
+
+Optional. Used when C<:raw> layer is pushed (explicitly or as a result
+of binmode(FH)). If not present layer will be popped. If present
+should configure layer as binary (or pop itself) and return 0.
+If it returns -1 for error C<binmode> will fail with layer
+still on the stack.
+
 =item Getarg
 
        SV *      (*Getarg)(pTHX_ PerlIO *f,
@@ -700,8 +718,11 @@ and so resumes reading from layer below.)
 =item "raw"
 
 A dummy layer which never exists on the layer stack. Instead when
-"pushed" it actually pops the stack(!), removing itself, and any other
-layers until it reaches a layer with the class C<PERLIO_K_RAW> bit set.
+"pushed" it actually pops the stack removing itself, it then calls
+Binmode function table entry on all the layers in the stack - normally
+this (via PerlIOBase_binmode) removes any layers which do not have
+C<PERLIO_K_RAW> bit set. Layers can modify that behaviour by defining
+their own Binmode entry.
 
 =item "utf8"
 
index 3cf31c5..7997658 100644 (file)
@@ -288,9 +288,9 @@ PerlIOWin32_close(pTHX_ PerlIO *f)
  PerlIOWin32 *s = PerlIOSelf(f,PerlIOWin32);
  if (s->refcnt == 1)
   {
-   IV code = 0;          
+   IV code = 0;        
 #if 0
-   /* This does not do pipes etc. correctly */   
+   /* This does not do pipes etc. correctly */ 
    if (!CloseHandle(s->h))
     {
      s->h = INVALID_HANDLE_VALUE;
@@ -309,15 +309,15 @@ PerlIOWin32_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
 {
  PerlIOWin32 *os = PerlIOSelf(f,PerlIOWin32);
  HANDLE proc = GetCurrentProcess();
- HANDLE new; 
+ HANDLE new;
  if (DuplicateHandle(proc, os->h, proc, &new, 0, FALSE,  DUPLICATE_SAME_ACCESS))
   {
    char mode[8];
    int fd = win32_open_osfhandle((intptr_t) new, PerlIOUnix_oflags(PerlIO_modestr(o,mode)));
-   if (fd >= 0) 
+   if (fd >= 0)
     {
      f = PerlIOBase_dup(aTHX_ f, o, params, flags);
-     if (f) 
+     if (f)
       {
        PerlIOWin32 *fs = PerlIOSelf(f,PerlIOWin32);
        fs->h  = new;
@@ -347,6 +347,7 @@ PerlIO_funcs PerlIO_win32 = {
  PerlIOWin32_pushed,
  PerlIOWin32_popped,
  PerlIOWin32_open,
+ PerlIOBase_binmode,
  NULL,                 /* getarg */
  PerlIOWin32_fileno,
  PerlIOWin32_dup,