ext/PerlIO-mmap/mmap.xs

   1 /*
   2  * ex: set ts=8 sts=4 sw=4 et:
   3  */
   4
   5 #define PERL_NO_GET_CONTEXT
   6 #include "EXTERN.h"
   7 #include "perl.h"
   8 #include "XSUB.h"
   9
  10 #if defined(PERLIO_LAYERS) && defined(HAS_MMAP)
  11
  12 #include "perliol.h"
  13 #include <sys/mman.h>
  14
  15 /*
  16  * mmap as "buffer" layer
  17  */
  18
  19 typedef struct {
  20     PerlIOBuf base;             /* PerlIOBuf stuff */
  21     Mmap_t mptr;                /* Mapped address */
  22     Size_t len;                 /* mapped length */
  23     STDCHAR *bbuf;              /* malloced buffer if map fails */
  24 } PerlIOMmap;
  25
  26 IV
  27 PerlIOMmap_map(pTHX_ PerlIO *f)
  28 {
  29     dVAR;
  30     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
  31     const IV flags = PerlIOBase(f)->flags;
  32     IV code = 0;
  33     if (m->len)
  34         abort();
  35     if (flags & PERLIO_F_CANREAD) {
  36         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
  37         Stat_t st;
  38         const int fd = PerlIO_fileno(f);
  39         if (fd < 0) {
  40           SETERRNO(EBADF,RMS_IFI);
  41           return -1;
  42         }
  43         code = Fstat(fd, &st);
  44         if (code == 0 && S_ISREG(st.st_mode)) {
  45             SSize_t len = st.st_size - b->posn;
  46             if (len > 0) {
  47                 Off_t posn;
  48                 if (PL_mmap_page_size <= 0)
  49                   Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
  50                              PL_mmap_page_size);
  51                 if (b->posn < 0) {
  52                     /*
  53                      * This is a hack - should never happen - open should
  54                      * have set it !
  55                      */
  56                     b->posn = PerlIO_tell(PerlIONext(f));
  57                 }
  58                 posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
  59                 len = st.st_size - posn;
  60                 m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
  61                 if (m->mptr && m->mptr != (Mmap_t) - 1) {
  62 #if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
  63                     madvise(m->mptr, len, MADV_SEQUENTIAL);
  64 #endif
  65 #if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
  66                     madvise(m->mptr, len, MADV_WILLNEED);
  67 #endif
  68                     PerlIOBase(f)->flags =
  69                         (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
  70                     b->end = ((STDCHAR *) m->mptr) + len;
  71                     b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
  72                     b->ptr = b->buf;
  73                     m->len = len;
  74                 }
  75                 else {
  76                     b->buf = NULL;
  77                 }
  78             }
  79             else {
  80                 PerlIOBase(f)->flags =
  81                     flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
  82                 b->buf = NULL;
  83                 b->ptr = b->end = b->ptr;
  84                 code = -1;
  85             }
  86         }
  87     }
  88     return code;
  89 }
  90
  91 IV
  92 PerlIOMmap_unmap(pTHX_ PerlIO *f)
  93 {
  94     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
  95     IV code = 0;
  96     if (m->len) {
  97         PerlIOBuf * const b = &m->base;
  98         if (b->buf) {
  99             /* The munmap address argument is tricky: depending on the
 100              * standard it is either "void *" or "caddr_t" (which is
 101              * usually "char *" (signed or unsigned).  If we cast it
 102              * to "void *", those that have it caddr_t and an uptight
 103              * C++ compiler, will freak out.  But casting it as char*
 104              * should work.  Maybe.  (Using Mmap_t figured out by
 105              * Configure doesn't always work, apparently.) */
 106             code = munmap((char*)m->mptr, m->len);
 107             b->buf = NULL;
 108             m->len = 0;
 109             m->mptr = NULL;
 110             if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
 111                 code = -1;
 112         }
 113         b->ptr = b->end = b->buf;
 114         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
 115     }
 116     return code;
 117 }
 118
 119 STDCHAR *
 120 PerlIOMmap_get_base(pTHX_ PerlIO *f)
 121 {
 122     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
 123     PerlIOBuf * const b = &m->base;
 124     if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
 125         /*
 126          * Already have a readbuffer in progress
 127          */
 128         return b->buf;
 129     }
 130     if (b->buf) {
 131         /*
 132          * We have a write buffer or flushed PerlIOBuf read buffer
 133          */
 134         m->bbuf = b->buf;       /* save it in case we need it again */
 135         b->buf = NULL;          /* Clear to trigger below */
 136     }
 137     if (!b->buf) {
 138         PerlIOMmap_map(aTHX_ f);        /* Try and map it */
 139         if (!b->buf) {
 140             /*
 141              * Map did not work - recover PerlIOBuf buffer if we have one
 142              */
 143             b->buf = m->bbuf;
 144         }
 145     }
 146     b->ptr = b->end = b->buf;
 147     if (b->buf)
 148         return b->buf;
 149     return PerlIOBuf_get_base(aTHX_ f);
 150 }
 151
 152 SSize_t
 153 PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 154 {
 155     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
 156     PerlIOBuf * const b = &m->base;
 157     if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
 158         PerlIO_flush(f);
 159     if (b->ptr && (b->ptr - count) >= b->buf
 160         && memEQ(b->ptr - count, vbuf, count)) {
 161         b->ptr -= count;
 162         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
 163         return count;
 164     }
 165     if (m->len) {
 166         /*
 167          * Loose the unwritable mapped buffer
 168          */
 169         PerlIO_flush(f);
 170         /*
 171          * If flush took the "buffer" see if we have one from before
 172          */
 173         if (!b->buf && m->bbuf)
 174             b->buf = m->bbuf;
 175         if (!b->buf) {
 176             PerlIOBuf_get_base(aTHX_ f);
 177             m->bbuf = b->buf;
 178         }
 179     }
 180     return PerlIOBuf_unread(aTHX_ f, vbuf, count);
 181 }
 182
 183 SSize_t
 184 PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 185 {
 186     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
 187     PerlIOBuf * const b = &m->base;
 188
 189     if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
 190         /*
 191          * No, or wrong sort of, buffer
 192          */
 193         if (m->len) {
 194             if (PerlIOMmap_unmap(aTHX_ f) != 0)
 195                 return 0;
 196         }
 197         /*
 198          * If unmap took the "buffer" see if we have one from before
 199          */
 200         if (!b->buf && m->bbuf)
 201             b->buf = m->bbuf;
 202         if (!b->buf) {
 203             PerlIOBuf_get_base(aTHX_ f);
 204             m->bbuf = b->buf;
 205         }
 206     }
 207     return PerlIOBuf_write(aTHX_ f, vbuf, count);
 208 }
 209
 210 IV
 211 PerlIOMmap_flush(pTHX_ PerlIO *f)
 212 {
 213     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
 214     PerlIOBuf * const b = &m->base;
 215     IV code = PerlIOBuf_flush(aTHX_ f);
 216     /*
 217      * Now we are "synced" at PerlIOBuf level
 218      */
 219     if (b->buf) {
 220         if (m->len) {
 221             /*
 222              * Unmap the buffer
 223              */
 224             if (PerlIOMmap_unmap(aTHX_ f) != 0)
 225                 code = -1;
 226         }
 227         else {
 228             /*
 229              * We seem to have a PerlIOBuf buffer which was not mapped
 230              * remember it in case we need one later
 231              */
 232             m->bbuf = b->buf;
 233         }
 234     }
 235     return code;
 236 }
 237
 238 IV
 239 PerlIOMmap_fill(pTHX_ PerlIO *f)
 240 {
 241     PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
 242     IV code = PerlIO_flush(f);
 243     if (code == 0 && !b->buf) {
 244         code = PerlIOMmap_map(aTHX_ f);
 245     }
 246     if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
 247         code = PerlIOBuf_fill(aTHX_ f);
 248     }
 249     return code;
 250 }
 251
 252 IV
 253 PerlIOMmap_close(pTHX_ PerlIO *f)
 254 {
 255     PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
 256     PerlIOBuf * const b = &m->base;
 257     IV code = PerlIO_flush(f);
 258     if (m->bbuf) {
 259         b->buf = m->bbuf;
 260         m->bbuf = NULL;
 261         b->ptr = b->end = b->buf;
 262     }
 263     if (PerlIOBuf_close(aTHX_ f) != 0)
 264         code = -1;
 265     return code;
 266 }
 267
 268 PerlIO *
 269 PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
 270 {
 271  return PerlIOBase_dup(aTHX_ f, o, param, flags);
 272 }
 273
 274
 275 PERLIO_FUNCS_DECL(PerlIO_mmap) = {
 276     sizeof(PerlIO_funcs),
 277     "mmap",
 278     sizeof(PerlIOMmap),
 279     PERLIO_K_BUFFERED|PERLIO_K_RAW,
 280     PerlIOBuf_pushed,
 281     PerlIOBuf_popped,
 282     PerlIOBuf_open,
 283     PerlIOBase_binmode,         /* binmode */
 284     NULL,
 285     PerlIOBase_fileno,
 286     PerlIOMmap_dup,
 287     PerlIOBuf_read,
 288     PerlIOMmap_unread,
 289     PerlIOMmap_write,
 290     PerlIOBuf_seek,
 291     PerlIOBuf_tell,
 292     PerlIOBuf_close,
 293     PerlIOMmap_flush,
 294     PerlIOMmap_fill,
 295     PerlIOBase_eof,
 296     PerlIOBase_error,
 297     PerlIOBase_clearerr,
 298     PerlIOBase_setlinebuf,
 299     PerlIOMmap_get_base,
 300     PerlIOBuf_bufsiz,
 301     PerlIOBuf_get_ptr,
 302     PerlIOBuf_get_cnt,
 303     PerlIOBuf_set_ptrcnt,
 304 };
 305
 306 #endif /* Layers available */
 307
 308 MODULE = PerlIO::mmap   PACKAGE = PerlIO::mmap
 309
 310 PROTOTYPES: DISABLE
 311
 312 BOOT:
 313 {
 314 #if defined(PERLIO_LAYERS) && defined(HAS_MMAP)
 315     PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
 316 #endif
 317 }
 318