Fix 'mmap' lib/filehand.t (ungetc) test fail.

[perl5.git] / perlio.c

diff --git a/perlio.c b/perlio.c
index 75b50ed..eb25314 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -469,16 +469,16 @@ PerlIO_default_layer(I32 n)
      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 
+     else
       {
        av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0)));
       }
-    } 
+    }
    len  = av_len(PerlIO_layer_av);
   }
  if (n < 0)
@@ -518,7 +518,7 @@ PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode)
    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\n",f,tab->name,(mode) ? mode : "(Null)");
    if ((*l->tab->Pushed)(f,mode) != 0)
     {
      PerlIO_pop(f);
@@ -592,7 +592,7 @@ int
 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)"); 
+              f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)");
  if (!names || (O_TEXT != O_BINARY && mode & O_BINARY))
   {
    PerlIO *top = f;
@@ -602,7 +602,7 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names)
      if (PerlIOBase(top)->tab == &PerlIO_crlf)
       {
        PerlIO_flush(top);
-       PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;       
+       PerlIOBase(top)->flags &= ~PERLIO_F_CRLF;
        break;
       }
      top = PerlIONext(top);
@@ -798,10 +798,10 @@ PerlIO_has_base(PerlIO *f)
 int
 PerlIO_fast_gets(PerlIO *f)
 {
- if (f && *f)
+ if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS))
   {
-   PerlIOl *l = PerlIOBase(f);
-   return (l->tab->Set_ptrcnt != NULL);
+   PerlIO_funcs *tab = PerlIOBase(f)->tab;
+   return (tab->Set_ptrcnt != NULL);
   }
  return 0;
 }
@@ -848,14 +848,20 @@ PerlIO_get_bufsiz(PerlIO *f)
 STDCHAR *
 PerlIO_get_ptr(PerlIO *f)
 {
- return (*PerlIOBase(f)->tab->Get_ptr)(f);
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ if (tab->Get_ptr == NULL)
+  return NULL;
+ return (*tab->Get_ptr)(f);
 }
 
 #undef PerlIO_get_cnt
 int
 PerlIO_get_cnt(PerlIO *f)
 {
- return (*PerlIOBase(f)->tab->Get_cnt)(f);
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ if (tab->Get_cnt == NULL)
+  return 0;
+ return (*tab->Get_cnt)(f);
 }
 
 #undef PerlIO_set_cnt
@@ -869,6 +875,12 @@ PerlIO_set_cnt(PerlIO *f,int cnt)
 void
 PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt)
 {
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
+ if (tab->Set_ptrcnt == NULL)
+  {
+   dTHX;
+   Perl_croak(aTHX_ "PerlIO buffer snooping abuse");
+  }
  (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt);
 }
 
@@ -887,13 +899,13 @@ PerlIO_modestr(PerlIO *f,char *buf)
  char *s = buf;
  IV flags = PerlIOBase(f)->flags;
  if (flags & PERLIO_F_CANREAD)
-  *s++ = 'r'; 
+  *s++ = 'r';
  if (flags & PERLIO_F_CANWRITE)
-  *s++ = 'w'; 
+  *s++ = 'w';
  if (flags & PERLIO_F_CRLF)
-  *s++ = 't'; 
+  *s++ = 't';
  else
-  *s++ = 'b'; 
+  *s++ = 'b';
  *s = '\0';
  return buf;
 }
@@ -904,8 +916,11 @@ PerlIOBase_pushed(PerlIO *f, const char *mode)
  PerlIOl *l = PerlIOBase(f);
  const char *omode = mode;
  char temp[8];
+ PerlIO_funcs *tab = PerlIOBase(f)->tab;
  l->flags  &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|
                 PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
+ if (tab->Set_ptrcnt != NULL)
+  l->flags |= PERLIO_F_FASTGETS;
  if (mode)
   {
    switch (*mode++)
@@ -950,9 +965,11 @@ PerlIOBase_pushed(PerlIO *f, const char *mode)
                  (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND);
     }
   }
+#if 0
  PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08x (%s)\n",
               f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)",
-              l->flags,PerlIO_modestr(f,temp)); 
+              l->flags,PerlIO_modestr(f,temp));
+#endif
  return 0;
 }
 
@@ -962,16 +979,26 @@ PerlIOBase_popped(PerlIO *f)
  return 0;
 }
 
+extern PerlIO_funcs PerlIO_pending;
+
 SSize_t
 PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count)
 {
+#if 0
  Off_t old = PerlIO_tell(f);
- if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
+ if (0 && PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0)
   {
    Off_t new = PerlIO_tell(f);
    return old - new;
   }
- return 0;
+ else
+  {
+   return 0;
+  }
+#else
+ PerlIO_push(f,&PerlIO_pending,"r");
+ return PerlIOBuf_unread(f,vbuf,count);
+#endif
 }
 
 IV
@@ -1298,7 +1325,7 @@ PerlIOStdio_mode(const char *mode,char *tmode)
      *tmode++ = *mode++;
     }
    *tmode++ = 'b';
-   *tmode = '\0';   
+   *tmode = '\0';
   }
  return ret;
 }
@@ -1366,7 +1393,7 @@ PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode)
  if (stdio)
   {
    char tmode[8];
-   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(), self, 
+   PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(), self,
                                (mode = PerlIOStdio_mode(mode,tmode))),
                                PerlIOStdio);
    s->stdio  = stdio;
@@ -1452,7 +1479,7 @@ PerlIOStdio_close(PerlIO *f)
  int optval, optlen = sizeof(int);
  FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio;
  return(
-   (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ? 
+   (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ?
        fclose(stdio) :
        close(PerlIO_fileno(f)));
 }
@@ -1664,6 +1691,14 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f)
 /*--------------------------------------------------------------------------------------*/
 /* perlio buffer layer */
 
+IV
+PerlIOBuf_pushed(PerlIO *f, const char *mode)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ b->posn = PerlIO_tell(PerlIONext(f));
+ return PerlIOBase_pushed(f,mode);
+}
+
 PerlIO *
 PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
 {
@@ -1675,23 +1710,23 @@ PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
    init = 1;
    mode++;
   }
- if (O_BINARY != O_TEXT)
-  {
-   int code = PerlLIO_setmode(fd, O_BINARY);
-   PerlIO_debug("PerlIOBuf_fdopen %s fd=%d m=%s c=%d\n",tab->name,fd,mode,code); 
-  }
+#if O_BINARY != O_TEXT
+ /* do something about failing setmode()? --jhi */
+ PerlLIO_setmode(fd, O_BINARY);
+#endif
  f = (*tab->Fdopen)(tab,fd,mode);
  if (f)
   {
    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
-   b->posn = PerlIO_tell(PerlIONext(f));
    if (init && fd == 2)
     {
      /* Initial stderr is unbuffered */
      PerlIOBase(f)->flags |= PERLIO_F_UNBUF;
-    } 
+    }
+#if 0
    PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08x\n",
                 self->name,f,fd,mode,PerlIOBase(f)->flags);
+#endif
   }
  return f;
 }
@@ -1703,8 +1738,7 @@ PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
  PerlIO *f = (*tab->Open)(tab,path,mode);
  if (f)
   {
-   PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode),PerlIOBuf);
-   b->posn = PerlIO_tell(PerlIONext(f));
+   PerlIO_push(f,self,mode);
   }
  return f;
 }
@@ -1716,11 +1750,6 @@ PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
  int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next);
  if (code = 0)
   code = (*PerlIOBase(f)->tab->Pushed)(f,mode);
- if (code == 0)
-  {
-   PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
-   b->posn = PerlIO_tell(PerlIONext(f));
-  }
  return code;
 }
 
@@ -1889,19 +1918,20 @@ PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count)
    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
     {
      avail = (b->ptr - b->buf);
-     if (avail > (SSize_t) count)
-      avail = count;
-     b->ptr -= avail;
     }
    else
     {
      avail = b->bufsiz;
-     if (avail > (SSize_t) count)
-      avail = count;
-     b->end = b->ptr + avail;
+     b->end = b->buf + avail;
+     b->ptr = b->end;
+     PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+     b->posn -= b->bufsiz;
     }
+   if (avail > (SSize_t) count)
+    avail = count;
    if (avail > 0)
     {
+     b->ptr -= avail;
      buf    -= avail;
      if (buf != b->ptr)
       {
@@ -1969,10 +1999,10 @@ PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count)
 IV
 PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence)
 {
- PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
- int code = PerlIO_flush(f);
- if (code == 0)
+ IV code;
+ if ((code = PerlIO_flush(f)) == 0)
   {
+   PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
    PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
    code = PerlIO_seek(PerlIONext(f),offset,whence);
    if (code == 0)
@@ -2090,7 +2120,7 @@ PerlIO_funcs PerlIO_perlio = {
  PerlIOBuf_fdopen,
  PerlIOBuf_open,
  PerlIOBuf_reopen,
- PerlIOBase_pushed,
+ PerlIOBuf_pushed,
  PerlIOBase_noop_ok,
  PerlIOBuf_read,
  PerlIOBuf_unread,
@@ -2112,6 +2142,120 @@ PerlIO_funcs PerlIO_perlio = {
 };
 
 /*--------------------------------------------------------------------------------------*/
+/* Temp layer to hold unread chars when cannot do it any other way */
+
+IV
+PerlIOPending_fill(PerlIO *f)
+{
+ /* Should never happen */
+ PerlIO_flush(f);
+ return 0;
+}
+
+IV
+PerlIOPending_close(PerlIO *f)
+{
+ /* A tad tricky - flush pops us, then we close new top */
+ PerlIO_flush(f);
+ return PerlIO_close(f);
+}
+
+IV
+PerlIOPending_seek(PerlIO *f, Off_t offset, int whence)
+{
+ /* A tad tricky - flush pops us, then we seek new top */
+ PerlIO_flush(f);
+ return PerlIO_seek(f,offset,whence);
+}
+
+
+IV
+PerlIOPending_flush(PerlIO *f)
+{
+ PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
+ if (b->buf && b->buf != (STDCHAR *) &b->oneword)
+  {
+   Safefree(b->buf);
+   b->buf = NULL;
+  }
+ PerlIO_pop(f);
+ return 0;
+}
+
+void
+PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
+{
+ if (cnt <= 0)
+  {
+   PerlIO_flush(f);
+  }
+ else
+  {
+   PerlIOBuf_set_ptrcnt(f,ptr,cnt);
+  }
+}
+
+IV
+PerlIOPending_pushed(PerlIO *f,const char *mode)
+{
+ IV code    = PerlIOBuf_pushed(f,mode);
+ 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
+    when we auto-pop.
+  */
+ l->flags   = (l->flags & ~PERLIO_F_FASTGETS) |
+              (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_FASTGETS);
+ return code;
+}
+
+SSize_t
+PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count)
+{
+ SSize_t avail = PerlIO_get_cnt(f);
+ SSize_t got   = 0;
+ if (count < avail)
+  avail = count;
+ if (avail > 0)
+  got = PerlIOBuf_read(f,vbuf,avail);
+ if (got < count)
+  got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got);
+ return got;
+}
+
+
+PerlIO_funcs PerlIO_pending = {
+ "pending",
+ sizeof(PerlIOBuf),
+ PERLIO_K_BUFFERED,
+ PerlIOBase_fileno,
+ NULL,
+ NULL,
+ NULL,
+ PerlIOPending_pushed,
+ PerlIOBase_noop_ok,
+ PerlIOPending_read,
+ PerlIOBuf_unread,
+ PerlIOBuf_write,
+ PerlIOPending_seek,
+ PerlIOBuf_tell,
+ PerlIOPending_close,
+ PerlIOPending_flush,
+ PerlIOPending_fill,
+ PerlIOBase_eof,
+ PerlIOBase_error,
+ PerlIOBase_clearerr,
+ PerlIOBuf_setlinebuf,
+ PerlIOBuf_get_base,
+ PerlIOBuf_bufsiz,
+ PerlIOBuf_get_ptr,
+ PerlIOBuf_get_cnt,
+ PerlIOPending_set_ptrcnt,
+};
+
+
+
+/*--------------------------------------------------------------------------------------*/
 /* 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.
@@ -2129,10 +2273,12 @@ PerlIOCrlf_pushed(PerlIO *f, const char *mode)
 {
  IV code;
  PerlIOBase(f)->flags |= PERLIO_F_CRLF;
- code = PerlIOBase_pushed(f,mode);
+ code = PerlIOBuf_pushed(f,mode);
+#if 0
  PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08x\n",
               f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)",
-              PerlIOBase(f)->flags); 
+              PerlIOBase(f)->flags);
+#endif
  return code;
 }
 
@@ -2150,7 +2296,7 @@ PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
   return PerlIOBuf_unread(f,vbuf,count);
  else
   {
-   const STDCHAR *buf = (const STDCHAR *) vbuf+count;  
+   const STDCHAR *buf = (const STDCHAR *) vbuf+count;
    PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
    SSize_t unread = 0;
    if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
@@ -2163,6 +2309,7 @@ PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count)
       {
        b->end = b->ptr = b->buf + b->bufsiz;
        PerlIOBase(f)->flags |= PERLIO_F_RDBUF;
+       b->posn -= b->bufsiz;
       }
      while (count > 0 && b->ptr > b->buf)
       {
@@ -2292,12 +2439,12 @@ PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt)
       chk--;
     }
    chk -= cnt;
-   
+
    if (ptr != chk)
     {
      dTHX;
      Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08x nl=%p e=%p for %d",
-                ptr, chk, flags, c->nl, b->end, cnt);    
+                ptr, chk, flags, c->nl, b->end, cnt);
     }
   }
  if (c->nl)
@@ -2321,7 +2468,7 @@ PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count)
   return PerlIOBuf_write(f,vbuf,count);
  else
   {
-   PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); 
+   PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
    const STDCHAR *buf  = (const STDCHAR *) vbuf;
    const STDCHAR *ebuf = buf+count;
    if (!b->buf)
@@ -2599,7 +2746,7 @@ PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
      m->bbuf = b->buf;
     }
   }
- return PerlIOBuf_unread(f,vbuf,count);
+return PerlIOBuf_unread(f,vbuf,count);
 }
 
 SSize_t
@@ -2695,7 +2842,7 @@ PerlIO_funcs PerlIO_mmap = {
  PerlIOBuf_fdopen,
  PerlIOBuf_open,
  PerlIOBuf_reopen,
- PerlIOBase_pushed,
+ PerlIOBuf_pushed,
  PerlIOBase_noop_ok,
  PerlIOBuf_read,
  PerlIOMmap_unread,