This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Implement PerlIO_binmode()
authorNick Ing-Simmons <nik@tiuk.ti.com>
Thu, 23 Nov 2000 19:46:23 +0000 (19:46 +0000)
committerNick Ing-Simmons <nik@tiuk.ti.com>
Thu, 23 Nov 2000 19:46:23 +0000 (19:46 +0000)
Fix PerlIOCrlf_unread() (*--ptr rather than *ptr-- ...)
Test on UNIX with PERLIO="perlio crlf" to mimic Win32,
make binmode in t/lib/io_tell.t unconditional so that works.
Checkin just so Win32 machine can see these changes.

p4raw-id: //depot/perlio@7842

doio.c
perlio.c
perlio.h
pp_sys.c
t/lib/io_tell.t

diff --git a/doio.c b/doio.c
index 3c0bcf1..914f91c 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1066,7 +1066,11 @@ fail_discipline:
                end = strchr(s+1, ':');
                if (!end)
                    end = s+len;
+#ifndef PERLIO_LAYERS
                Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s);
+#else
+               s = end;
+#endif
            }
        }
     }
@@ -1076,46 +1080,11 @@ fail_discipline:
 int
 Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode)
 {
-#ifdef DOSISH
-#  if defined(atarist) || defined(__MINT__)
-    if (!PerlIO_flush(fp)) {
-       if (mode & O_BINARY)
-           ((FILE*)fp)->_flag |= _IOBIN;
-       else
-           ((FILE*)fp)->_flag &= ~ _IOBIN;
-       return 1;
-    }
-    return 0;
-#  else
-    if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) {
-#    if defined(WIN32) && defined(__BORLANDC__)
-       /* The translation mode of the stream is maintained independent
-        * of the translation mode of the fd in the Borland RTL (heavy
-        * digging through their runtime sources reveal).  User has to
-        * set the mode explicitly for the stream (though they don't
-        * document this anywhere). GSAR 97-5-24
-        */
-       PerlIO_seek(fp,0L,0);
-       if (mode & O_BINARY)
-           ((FILE*)fp)->flags |= _F_BIN;
-       else
-           ((FILE*)fp)->flags &= ~ _F_BIN;
-#    endif
-       return 1;
-    }
-    else
-       return 0;
-#  endif
-#else
-#  if defined(USEMYBINMODE)
-    if (my_binmode(fp, iotype, mode) != FALSE)
-       return 1;
-    else
-       return 0;
-#  else
-    return 1;
-#  endif
-#endif
+ /* The old body of this is now in non-LAYER part of perlio.c
+  * This is a stub for any XS code which might have been calling it.
+  */
+ char *name = (O_BINARY != O_TEXT && !(mode & O_BINARY)) ? ":crlf" : ":raw";
+ return PerlIO_binmode(aTHX_ fp, iotype, mode, name);
 }
 
 #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
@@ -2151,7 +2120,7 @@ static int S_s64_malloc( S64_IOB *ptr) {
            return( 0);
        
        ptr->size += _S64_BUFFER_SIZE;
-        
+       
        return( 1);
     }
 
@@ -2162,7 +2131,7 @@ static int S_s64_malloc( S64_IOB *ptr) {
 int Perl_do_s64_getc( PerlIO *f) {
     S64_IOB *ptr = _s64_get_buffer(f);
     if( ptr) {
-       if( ptr->cnt) 
+       if( ptr->cnt)
            return( ptr->buffer[--ptr->cnt]);
     }
     return( getc(f));
@@ -2174,7 +2143,7 @@ int Perl_do_s64_ungetc( int ch, PerlIO *f) {
 
     if( !ptr) ptr=_s64_create_buffer(f);
     if( !ptr) return( EOF);
-    if( !ptr->buffer || (ptr->buffer && ptr->cnt >= ptr->size)) 
+    if( !ptr->buffer || (ptr->buffer && ptr->cnt >= ptr->size))
        if( !_s64_malloc( ptr)) return( EOF);
     ptr->buffer[ptr->cnt++] = ch;
 
index 8856166..697fc86 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -40,6 +40,56 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
  /* NOTREACHED */
  return -1;
 }
+
+int
+PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
+{
+/* This used to be contents of do_binmode in doio.c */
+#ifdef DOSISH
+#  if defined(atarist) || defined(__MINT__)
+    if (!PerlIO_flush(fp)) {
+       if (mode & O_BINARY)
+           ((FILE*)fp)->_flag |= _IOBIN;
+       else
+           ((FILE*)fp)->_flag &= ~ _IOBIN;
+       return 1;
+    }
+    return 0;
+#  else
+    if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) {
+#    if defined(WIN32) && defined(__BORLANDC__)
+       /* The translation mode of the stream is maintained independent
+        * of the translation mode of the fd in the Borland RTL (heavy
+        * digging through their runtime sources reveal).  User has to
+        * set the mode explicitly for the stream (though they don't
+        * document this anywhere). GSAR 97-5-24
+        */
+       PerlIO_seek(fp,0L,0);
+       if (mode & O_BINARY)
+           ((FILE*)fp)->flags |= _F_BIN;
+       else
+           ((FILE*)fp)->flags &= ~ _F_BIN;
+#    endif
+       return 1;
+    }
+    else
+       return 0;
+#  endif
+#else
+#  if defined(USEMYBINMODE)
+    if (my_binmode(fp, iotype, mode) != FALSE)
+       return 1;
+    else
+       return 0;
+#  else
+    return 1;
+#  endif
+#endif
+}
+
+
+
+
 #endif
 
 #if !defined(PERL_IMPLICIT_SYS)
@@ -193,7 +243,7 @@ PerlIO_cleantable(PerlIO **tablep)
    for (i=PERLIO_TABLE_SIZE-1; i > 0; i--)
     {
      PerlIO *f = table+i;
-     if (*f) 
+     if (*f)
       {
        PerlIO_close(f);
       }
@@ -431,6 +481,41 @@ PerlIO_default_layer(I32 n)
  return tab;
 }
 
+#define PerlIO_default_top() PerlIO_default_layer(-1)
+#define PerlIO_default_btm() PerlIO_default_layer(0)
+
+void
+PerlIO_stdstreams()
+{
+ if (!_perlio)
+  {
+   PerlIO_allocate();
+   PerlIO_fdopen(0,"Ir");
+   PerlIO_fdopen(1,"Iw");
+   PerlIO_fdopen(2,"Iw");
+  }
+}
+
+PerlIO *
+PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
+{
+ PerlIOl *l = NULL;
+ Newc('L',l,tab->size,char,PerlIOl);
+ if (l)
+  {
+   Zero(l,tab->size,char);
+   l->next = *f;
+   l->tab  = tab;
+   *f      = l;
+   if ((*l->tab->Pushed)(f,mode) != 0)
+    {
+     PerlIO_pop(f);
+     return NULL;
+    }
+  }
+ return f;
+}
+
 int
 PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
 {
@@ -450,19 +535,34 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
         e++;
        if (e > s)
         {
-         SV *layer = PerlIO_find_layer(s,e-s);
-         if (layer)
+         if ((e - s) == 3 && strncmp(s,"raw",3) == 0)
           {
-           PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
-           if (tab)
+           /* Pop back to bottom layer */
+           if (PerlIONext(f))
             {
-             PerlIO *new = PerlIO_push(f,tab,mode);
-             if (!new)
-              return -1;
+             PerlIO_flush(f);
+             while (PerlIONext(f))
+              {
+               PerlIO_pop(f);
+              }
             }
           }
          else
-          Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
+          {
+           SV *layer = PerlIO_find_layer(s,e-s);
+           if (layer)
+            {
+             PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer)));
+             if (tab)
+              {
+               PerlIO *new = PerlIO_push(f,tab,mode);
+               if (!new)
+                return -1;
+              }
+            }
+           else
+            Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s);
+          }
         }
        s = e;
       }
@@ -471,44 +571,32 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names)
  return 0;
 }
 
-#define PerlIO_default_top() PerlIO_default_layer(-1)
-#define PerlIO_default_btm() PerlIO_default_layer(0)
 
-void
-PerlIO_stdstreams()
-{
- if (!_perlio)
-  {
-   PerlIO_allocate();
-   PerlIO_fdopen(0,"Ir");
-   PerlIO_fdopen(1,"Iw");
-   PerlIO_fdopen(2,"Iw");
-  }
-}
 
-PerlIO *
-PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
+/*--------------------------------------------------------------------------------------*/
+/* Given the abstraction above the public API functions */
+
+int
+PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names)
 {
- PerlIOl *l = NULL;
- Newc('L',l,tab->size,char,PerlIOl);
- if (l)
+ if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
   {
-   Zero(l,tab->size,char);
-   l->next = *f;
-   l->tab  = tab;
-   *f      = l;
-   if ((*l->tab->Pushed)(f,mode) != 0)
+   PerlIO *top = fp;
+   PerlIOl *l;
+   while (l = *top)
     {
-     PerlIO_pop(f);
-     return NULL;
+     if (PerlIOBase(top)->tab == &PerlIO_crlf)
+      {
+       PerlIO_flush(top);
+       PerlIO_pop(top);
+       break;
+      }
+     top = PerlIONext(top);
     }
   }
- return f;
+ return PerlIO_apply_layers(aTHX_ fp, NULL, names) == 0 ? TRUE : FALSE;
 }
 
-/*--------------------------------------------------------------------------------------*/
-/* Given the abstraction above the public API functions */
-
 #undef PerlIO_close
 int
 PerlIO_close(PerlIO *f)
@@ -948,8 +1036,8 @@ PerlIOUnix_oflags(const char *mode)
  if (*mode == 'b')
   {
    oflags |= O_BINARY;
-   mode++; 
-  }   
+   mode++;
+  }
  /* Always open in binary mode */
  oflags |= O_BINARY;
  if (*mode || oflags == -1)
@@ -1672,7 +1760,7 @@ PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count)
    while (count > 0)
     {
      SSize_t avail = PerlIO_get_cnt(f);
-     SSize_t take  = (count < avail) ? count : avail; 
+     SSize_t take  = (count < avail) ? count : avail;
      if (take > 0)
       {
        STDCHAR *ptr = PerlIO_get_ptr(f);
@@ -1931,14 +2019,14 @@ PerlIO_funcs PerlIO_perlio = {
 /*--------------------------------------------------------------------------------------*/
 /* crlf - translation
    On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries
-   to hand back a line at a time and keeping a record of which nl we "lied" about. 
+   to hand back a line at a time and keeping a record of which nl we "lied" about.
    On write translate "\n" to CR,LF
  */
 
 typedef struct
 {
  PerlIOBuf     base;         /* PerlIOBuf stuff */
- STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */ 
+ STDCHAR       *nl;           /* Position of crlf we "lied" about in the buffer */
 } PerlIOCrlf;
 
 SSize_t
@@ -1946,9 +2034,15 @@ PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
 {
  const STDCHAR *buf = (const STDCHAR *) vbuf+count;
  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
  SSize_t unread = 0;
  if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
   PerlIO_flush(f);
+ if (c->nl)
+  {
+   *(c->nl) = 0xd;
+   c->nl = NULL;
+  }
  if (!b->buf)
   PerlIO_get_base(f);
  if (b->buf)
@@ -1965,8 +2059,8 @@ PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
       {
        if (b->ptr - 2 >= b->buf)
         {
-         *(b->ptr)-- = 0xa;
-         *(b->ptr)-- = 0xd;
+         *--(b->ptr) = 0xa;
+         *--(b->ptr) = 0xd;
          unread++;
          count--;
         }
@@ -1978,10 +2072,10 @@ PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
       }
      else
       {
-       *(b->ptr)-- = ch;
+       *--(b->ptr) = ch;
        unread++;
        count--;
-      } 
+      }
     }
   }
  return unread;
@@ -1999,33 +2093,33 @@ PerlIOCrlf_get_cnt(PerlIO *f)
    if (!c->nl)
     {
      STDCHAR *nl   = b->ptr;
-    scan: 
+    scan:
      while (nl < b->end && *nl != 0xd)
       nl++;
      if (nl < b->end && *nl == 0xd)
       {
-     test: 
+     test:
        if (nl+1 < b->end)
         {
          if (nl[1] == 0xa)
           {
            *nl   = '\n';
-           c->nl = nl;  
+           c->nl = nl;
           }
-         else 
+         else
           {
            /* Not CR,LF but just CR */
            nl++;
-           goto scan;  
+           goto scan;
           }
         }
        else
         {
-         /* Blast - found CR as last char in buffer */ 
+         /* Blast - found CR as last char in buffer */
          if (b->ptr < nl)
           {
            /* They may not care, defer work as long as possible */
-           return (nl - b->ptr);            
+           return (nl - b->ptr);
           }
          else
           {
@@ -2041,13 +2135,13 @@ PerlIOCrlf_get_cnt(PerlIO *f)
            b->ptr = nl = b->buf;   /* Which is what we hand off */
            b->posn--;              /* Buffer starts here */
            *nl = 0xd;              /* Fill in the CR */
-           if (code == 0)          
+           if (code == 0)
             goto test;             /* fill() call worked */
            /* CR at EOF - just fall through */
           }
         }
-      }  
-    } 
+      }
+    }
    return (((c->nl) ? (c->nl+1) : b->end) - b->ptr);
   }
  return 0;
@@ -2061,7 +2155,14 @@ PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
  if (!b->buf)
   PerlIO_get_base(f);
  if (!ptr)
-  ptr = ((c->nl) ? (c->nl+1) : b->end) - cnt; 
+  {
+   ptr = ((c->nl) ? (c->nl+1) : b->end) - cnt;
+  }
+ else
+  {
+   if (ptr != (((c->nl) ? (c->nl+1) : b->end) - cnt))
+    abort();
+  }
  if (c->nl)
   {
    if (ptr > c->nl)
@@ -2070,7 +2171,7 @@ PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
      *(c->nl) = 0xd;
      c->nl = NULL;
      ptr++;
-    } 
+    }
   }
  b->ptr = ptr;
  PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
@@ -2094,19 +2195,22 @@ PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
     {
      if (*buf == '\n')
       {
-       if (b->ptr + 2 >= eptr)
+       if ((b->ptr + 2) > eptr)
         {
          /* Not room for both */
          PerlIO_flush(f);
          break;
         }
-       *(b->ptr)++ = 0xd; /* CR */
-       *(b->ptr)++ = 0xa; /* LF */
-       buf++;
-       if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
-        { 
-         PerlIO_flush(f);
-         break;
+       else
+        {
+         *(b->ptr)++ = 0xd; /* CR */
+         *(b->ptr)++ = 0xa; /* LF */
+         buf++;
+         if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF)
+          {
+           PerlIO_flush(f);
+           break;
+          }
         }
       }
      else
@@ -2130,10 +2234,8 @@ PerlIOCrlf_flush(PerlIO *f)
  PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf);
  if (c->nl)
   {
-   dTHX;
-   Perl_warn(aTHX_ __FUNCTION__ " f=%p flush with nl@%p",f,c->nl);
    *(c->nl) = 0xd;
-   c->nl = NULL; 
+   c->nl = NULL;
   }
  return PerlIOBuf_flush(f);
 }
index 8cb4f7e..75f00a2 100644 (file)
--- a/perlio.h
+++ b/perlio.h
@@ -309,7 +309,10 @@ extern PerlIO *    PerlIO_fdupopen         (PerlIO *);
 extern int     PerlIO_isutf8           (PerlIO *);
 #endif
 #ifndef PerlIO_apply_layers
-extern int     PerlIO_apply_layers     (pTHX_ PerlIO *f,const char *mode, const char *names);
+extern int     PerlIO_apply_layers     (pTHX_ PerlIO *f, const char *mode, const char *names);
+#endif
+#ifndef PerlIO_binmode
+extern int     PerlIO_binmode          (pTHX_ PerlIO *f, int iotype, int omode, const char *names);
 #endif
 
 extern void PerlIO_debug(const char *fmt,...);
index 2194653..88ce86c 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -687,11 +687,14 @@ PP(pp_binmode)
     PerlIO *fp;
     MAGIC *mg;
     SV *discp = Nullsv;
+    STRLEN len  = 0;
+    char *names = NULL;
 
     if (MAXARG < 1)
        RETPUSHUNDEF;
-    if (MAXARG > 1)
+    if (MAXARG > 1) {
        discp = POPs;
+    }
 
     gv = (GV*)POPs;
 
@@ -712,7 +715,12 @@ PP(pp_binmode)
     if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
        RETPUSHUNDEF;
 
-    if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp)))
+    if (discp) {
+       names = SvPV(discp,len);
+    }
+
+    if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp),
+                       (discp) ? SvPV_nolen(discp) : Nullch))
        RETPUSHYES;
     else
        RETPUSHUNDEF;
@@ -3137,7 +3145,7 @@ PP(pp_fttext)
            (void)PerlIO_close(fp);
            RETPUSHUNDEF;
        }
-       do_binmode(fp, '<', O_BINARY);
+       PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
        len = PerlIO_read(fp, tbuf, sizeof(tbuf));
        (void)PerlIO_close(fp);
        if (len <= 0) {
index 3aa4b03..65c63bd 100755 (executable)
@@ -27,7 +27,7 @@ print "1..13\n";
 use IO::File;
 
 $tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file");
-binmode $tst if ($^O eq 'MSWin32' or $^O eq 'dos');
+binmode $tst; # its a nop unless it matters. Was only if ($^O eq 'MSWin32' or $^O eq 'dos');
 if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; }
 
 $firstline = <$tst>;