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