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