/*
* ex: set ts=8 sts=4 sw=4 et:
*/
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#if defined(PERLIO_LAYERS) && defined(HAS_MMAP)
#include "perliol.h"
#include <sys/mman.h>
/*
* mmap as "buffer" layer
*/
typedef struct {
PerlIOBuf base; /* PerlIOBuf stuff */
Mmap_t mptr; /* Mapped address */
Size_t len; /* mapped length */
STDCHAR *bbuf; /* malloced buffer if map fails */
} PerlIOMmap;
IV
PerlIOMmap_map(pTHX_ PerlIO *f)
{
dVAR;
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
const IV flags = PerlIOBase(f)->flags;
IV code = 0;
if (m->len)
abort();
if (flags & PERLIO_F_CANREAD) {
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
Stat_t st;
const int fd = PerlIO_fileno(f);
if (fd < 0) {
SETERRNO(EBADF,RMS_IFI);
return -1;
}
code = Fstat(fd, &st);
if (code == 0 && S_ISREG(st.st_mode)) {
SSize_t len = st.st_size - b->posn;
if (len > 0) {
Off_t posn;
if (PL_mmap_page_size <= 0)
Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
PL_mmap_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 / PL_mmap_page_size) * PL_mmap_page_size;
len = st.st_size - posn;
m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
if (m->mptr && m->mptr != (Mmap_t) - 1) {
#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL)
madvise(m->mptr, len, MADV_SEQUENTIAL);
#endif
#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED)
madvise(m->mptr, len, MADV_WILLNEED);
#endif
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 {
b->buf = NULL;
}
}
else {
PerlIOBase(f)->flags =
flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
b->buf = NULL;
b->ptr = b->end = b->ptr;
code = -1;
}
}
}
return code;
}
IV
PerlIOMmap_unmap(pTHX_ PerlIO *f)
{
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
IV code = 0;
if (m->len) {
PerlIOBuf * const b = &m->base;
if (b->buf) {
/* The munmap address argument is tricky: depending on the
* standard it is either "void *" or "caddr_t" (which is
* usually "char *" (signed or unsigned). If we cast it
* to "void *", those that have it caddr_t and an uptight
* C++ compiler, will freak out. But casting it as char*
* should work. Maybe. (Using Mmap_t figured out by
* Configure doesn't always work, apparently.) */
code = munmap((char*)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;
}
b->ptr = b->end = b->buf;
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
}
return code;
}
STDCHAR *
PerlIOMmap_get_base(pTHX_ PerlIO *f)
{
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
PerlIOBuf * const b = &m->base;
if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
/*
* Already have a readbuffer in progress
*/
return b->buf;
}
if (b->buf) {
/*
* We have a write buffer or flushed PerlIOBuf read buffer
*/
m->bbuf = b->buf; /* save it in case we need it again */
b->buf = NULL; /* Clear to trigger below */
}
if (!b->buf) {
PerlIOMmap_map(aTHX_ f); /* Try and map it */
if (!b->buf) {
/*
* Map did not work - recover PerlIOBuf buffer if we have one
*/
b->buf = m->bbuf;
}
}
b->ptr = b->end = b->buf;
if (b->buf)
return b->buf;
return PerlIOBuf_get_base(aTHX_ f);
}
SSize_t
PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
PerlIOBuf * const b = &m->base;
if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
PerlIO_flush(f);
if (b->ptr && (b->ptr - count) >= b->buf
&& memEQ(b->ptr - count, vbuf, count)) {
b->ptr -= count;
PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
return count;
}
if (m->len) {
/*
* 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(aTHX_ f);
m->bbuf = b->buf;
}
}
return PerlIOBuf_unread(aTHX_ f, vbuf, count);
}
SSize_t
PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
{
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
PerlIOBuf * const b = &m->base;
if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
/*
* No, or wrong sort of, buffer
*/
if (m->len) {
if (PerlIOMmap_unmap(aTHX_ f) != 0)
return 0;
}
/*
* If unmap 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(aTHX_ f);
m->bbuf = b->buf;
}
}
return PerlIOBuf_write(aTHX_ f, vbuf, count);
}
IV
PerlIOMmap_flush(pTHX_ PerlIO *f)
{
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
PerlIOBuf * const b = &m->base;
IV code = PerlIOBuf_flush(aTHX_ f);
/*
* Now we are "synced" at PerlIOBuf level
*/
if (b->buf) {
if (m->len) {
/*
* Unmap the buffer
*/
if (PerlIOMmap_unmap(aTHX_ f) != 0)
code = -1;
}
else {
/*
* We seem to have a PerlIOBuf buffer which was not mapped
* remember it in case we need one later
*/
m->bbuf = b->buf;
}
}
return code;
}
IV
PerlIOMmap_fill(pTHX_ PerlIO *f)
{
PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
IV code = PerlIO_flush(f);
if (code == 0 && !b->buf) {
code = PerlIOMmap_map(aTHX_ f);
}
if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
code = PerlIOBuf_fill(aTHX_ f);
}
return code;
}
IV
PerlIOMmap_close(pTHX_ PerlIO *f)
{
PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
PerlIOBuf * const b = &m->base;
IV code = PerlIO_flush(f);
if (m->bbuf) {
b->buf = m->bbuf;
m->bbuf = NULL;
b->ptr = b->end = b->buf;
}
if (PerlIOBuf_close(aTHX_ f) != 0)
code = -1;
return code;
}
PerlIO *
PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
{
return PerlIOBase_dup(aTHX_ f, o, param, flags);
}
PERLIO_FUNCS_DECL(PerlIO_mmap) = {
sizeof(PerlIO_funcs),
"mmap",
sizeof(PerlIOMmap),
PERLIO_K_BUFFERED|PERLIO_K_RAW,
PerlIOBuf_pushed,
PerlIOBuf_popped,
PerlIOBuf_open,
PerlIOBase_binmode, /* binmode */
NULL,
PerlIOBase_fileno,
PerlIOMmap_dup,
PerlIOBuf_read,
PerlIOMmap_unread,
PerlIOMmap_write,
PerlIOBuf_seek,
PerlIOBuf_tell,
PerlIOBuf_close,
PerlIOMmap_flush,
PerlIOMmap_fill,
PerlIOBase_eof,
PerlIOBase_error,
PerlIOBase_clearerr,
PerlIOBase_setlinebuf,
PerlIOMmap_get_base,
PerlIOBuf_bufsiz,
PerlIOBuf_get_ptr,
PerlIOBuf_get_cnt,
PerlIOBuf_set_ptrcnt,
};
#endif /* Layers available */
MODULE = PerlIO::mmap PACKAGE = PerlIO::mmap
PROTOTYPES: DISABLE
BOOT:
{
#if defined(PERLIO_LAYERS) && defined(HAS_MMAP)
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
#endif
}