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