Make PerlIO_getpos() to behave like fgetpos() on return.

[p5sagit/p5-mst-13.2.git] / perlio.c

diff --git a/perlio.c b/perlio.c
index 1b5bd76..8d54f77 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -385,7 +385,7 @@ PerlIO_default_layer(I32 n)
            av_push(PerlIO_layer_av,SvREFCNT_inc(layer));
           }
          else
-          Perl_warn(aTHX_ "Unknown layer %.*s",(e-s),s);
+          Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s);
          s = e;
         }
       }
@@ -1037,6 +1037,15 @@ PerlIO_funcs PerlIO_unix = {
 /*--------------------------------------------------------------------------------------*/
 /* stdio as a layer */
 
+#if defined(USE_64_BIT_STDIO) && defined(HAS_FSEEKO) && !defined(USE_FSEEK64)
+#define fseek fseeko
+#endif
+
+#if defined(USE_64_BIT_STDIO) && defined(HAS_FTELLO) && !defined(USE_FTELL64)
+#define ftell ftello
+#endif
+
+
 typedef struct
 {
  struct _PerlIO        base;
@@ -1413,6 +1422,7 @@ PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode)
  return f;
 }
 
+
 PerlIO *
 PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
 {
@@ -1421,15 +1431,24 @@ PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode)
  if (f)
   {
    PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf);
-   b->posn = 0;
+   b->posn = PerlIO_tell(PerlIONext(f));
   }
  return f;
 }
 
 int
-PerlIOBase_reopen(const char *path, const char *mode, PerlIO *f)
+PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f)
 {
- return (*PerlIOBase(f)->tab->Reopen)(path,mode,PerlIONext(f));
+ PerlIO *next = PerlIONext(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;
 }
 
 /* This "flush" is akin to sfio's sync in that it handles files in either
@@ -1764,7 +1783,7 @@ PerlIO_funcs PerlIO_perlio = {
  PerlIOBase_fileno,
  PerlIOBuf_fdopen,
  PerlIOBuf_open,
- PerlIOBase_reopen,
+ PerlIOBuf_reopen,
  PerlIOBase_pushed,
  PerlIOBase_noop_ok,
  PerlIOBuf_read,
@@ -1793,13 +1812,18 @@ PerlIO_funcs PerlIO_perlio = {
 typedef struct
 {
  PerlIOBuf     base;         /* PerlIOBuf stuff */
+ Mmap_t                mptr;        /* Mapped address */
  Size_t                len;          /* mapped length */
  STDCHAR       *bbuf;        /* malloced buffer if map fails */
+
 } PerlIOMmap;
 
+static size_t page_size = 0;
+
 IV
 PerlIOMmap_map(PerlIO *f)
 {
+ dTHX;
  PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap);
  PerlIOBuf  *b = &m->base;
  IV flags = PerlIOBase(f)->flags;
@@ -1817,16 +1841,59 @@ PerlIOMmap_map(PerlIO *f)
      SSize_t len = st.st_size - b->posn;
      if (len > 0)
       {
-       b->buf = (STDCHAR *) mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, b->posn);
-       if (b->buf && b->buf != (STDCHAR *) -1)
+       Off_t posn;
+       if (!page_size) {
+#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_PAGE_SIZE))
+          {
+              SETERRNO(0,SS$_NORMAL);
+#   ifdef _SC_PAGESIZE
+              page_size = sysconf(_SC_PAGESIZE);
+#   else
+              page_size = sysconf(_SC_PAGE_SIZE);
+#   endif
+              if ((long)page_size < 0) {
+                  if (errno) {
+                      SV *error = ERRSV;
+                      char *msg;
+                      STRLEN n_a;
+                      (void)SvUPGRADE(error, SVt_PV);
+                      msg = SvPVx(error, n_a);
+                      Perl_croak(aTHX_ "panic: sysconf: %s", msg);
+                  }
+                  else
+                      Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
+              }
+          }
+#else
+#   ifdef HAS_GETPAGESIZE
+        page_size = getpagesize();
+#   else
+#       if defined(I_SYS_PARAM) && defined(PAGESIZE)
+        page_size = PAGESIZE; /* compiletime, bad */
+#       endif
+#   endif
+#endif
+       if ((IV)page_size <= 0)
+           Perl_croak(aTHX_ "panic: bad pagesize %"IVdf, (IV)page_size);
+       }
+       if (b->posn < 0)
+        {
+         /* This is a hack - should never happen - open should have set it ! */
+         b->posn = PerlIO_tell(PerlIONext(f));
+        }
+       posn = (b->posn / page_size) * page_size;
+       len  = st.st_size - posn;
+       m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn);
+       if (m->mptr && m->mptr != (Mmap_t) -1)
         {
 #if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
-         madvise((Mmap_t) b->buf, len, MADV_SEQUENTIAL);
+         madvise(m->mptr, len, MADV_SEQUENTIAL);
 #endif
-         PerlIOBase(f)->flags = flags | PERLIO_F_RDBUF;
-         b->end = b->buf+len;
-         b->ptr = b->buf;
-         m->len = len;
+         PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
+         b->end  = ((STDCHAR *)m->mptr) + len;
+         b->buf  = ((STDCHAR *)m->mptr) + (b->posn - posn);
+         b->ptr  = b->buf;
+         m->len  = len;
         }
        else
         {
@@ -1855,9 +1922,10 @@ PerlIOMmap_unmap(PerlIO *f)
   {
    if (b->buf)
     {
-     code = munmap((Mmap_t) b->buf, m->len);
-     b->buf = NULL;
-     m->len = 0;
+     code = munmap(m->mptr, m->len);
+     b->buf  = NULL;
+     m->len  = 0;
+     m->mptr = NULL;
      if (PerlIO_seek(PerlIONext(f),b->posn,SEEK_SET) != 0)
       code = -1;
     }
@@ -1915,6 +1983,14 @@ PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count)
   {
    /* Loose the unwritable mapped buffer */
    PerlIO_flush(f);
+   /* If flush took the "buffer" see if we have one from before */
+   if (!b->buf && m->bbuf)
+    b->buf = m->bbuf;
+   if (!b->buf)
+    {
+     PerlIOBuf_get_base(f);
+     m->bbuf = b->buf;
+    }
   }
  return PerlIOBuf_unread(f,vbuf,count);
 }
@@ -2011,7 +2087,7 @@ PerlIO_funcs PerlIO_mmap = {
  PerlIOBase_fileno,
  PerlIOBuf_fdopen,
  PerlIOBuf_open,
- PerlIOBase_reopen,
+ PerlIOBuf_reopen,
  PerlIOBase_pushed,
  PerlIOBase_noop_ok,
  PerlIOBuf_read,
@@ -2238,7 +2314,7 @@ int
 PerlIO_getpos(PerlIO *f, Fpos_t *pos)
 {
  *pos = PerlIO_tell(f);
- return 0;
+ return *pos == -1 ? -1 : 0;
 }
 #else
 #ifndef PERLIO_IS_STDIO
@@ -2283,7 +2359,8 @@ PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap)
    if (strlen(s) >= (STRLEN)n)
     {
      dTHX;
-     PerlIO_puts(Perl_error_log,"panic: sprintf overflow - memory corrupted!\n");
+     (void)PerlIO_puts(Perl_error_log,
+                      "panic: sprintf overflow - memory corrupted!\n");
      my_exit(1);
     }
   }