File Coverage

ext/PerlIO-mmap/mmap.xs
Criterion Covered Total %
statement 0 113 0.0
branch n/a
condition n/a
subroutine n/a
total 0 113 0.0


line stmt bran cond sub time code
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
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 0         PerlIOMmap_map(pTHX_ PerlIO *f)
34           {
35           dVAR;
36 0         PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
37 0         const IV flags = PerlIOBase(f)->flags;
38           IV code = 0;
39 0         if (m->len)
40 0         abort();
41 0         if (flags & PERLIO_F_CANREAD) {
42 0         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
43 0         const int fd = PerlIO_fileno(f);
44           Stat_t st;
45 0         code = Fstat(fd, &st);
46 0         if (code == 0 && S_ISREG(st.st_mode)) {
47 0         SSize_t len = st.st_size - b->posn;
48 0         if (len > 0) {
49           Off_t posn;
50 0         if (PL_mmap_page_size <= 0)
51 0         Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
52           PL_mmap_page_size);
53 0         if (b->posn < 0) {
54           /*
55           * This is a hack - should never happen - open should
56           * have set it !
57           */
58 0         b->posn = PerlIO_tell(PerlIONext(f));
59           }
60 0         posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size;
61 0         len = st.st_size - posn;
62 0         m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn);
63 0         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 0         PerlIOBase(f)->flags =
71           (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF;
72 0         b->end = ((STDCHAR *) m->mptr) + len;
73 0         b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn);
74 0         b->ptr = b->buf;
75 0         m->len = len;
76           }
77           else {
78 0         b->buf = NULL;
79           }
80           }
81           else {
82 0         PerlIOBase(f)->flags =
83           flags | PERLIO_F_EOF | PERLIO_F_RDBUF;
84 0         b->buf = NULL;
85 0         b->ptr = b->end = b->ptr;
86           code = -1;
87           }
88           }
89           }
90 0         return code;
91           }
92            
93           IV
94 0         PerlIOMmap_unmap(pTHX_ PerlIO *f)
95           {
96 0         PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
97           IV code = 0;
98 0         if (m->len) {
99           PerlIOBuf * const b = &m->base;
100 0         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 0         code = munmap((char*)m->mptr, m->len);
109 0         b->buf = NULL;
110 0         m->len = 0;
111 0         m->mptr = NULL;
112 0         if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0)
113           code = -1;
114           }
115 0         b->ptr = b->end = b->buf;
116 0         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
117           }
118 0         return code;
119           }
120            
121           STDCHAR *
122 0         PerlIOMmap_get_base(pTHX_ PerlIO *f)
123           {
124 0         PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
125           PerlIOBuf * const b = &m->base;
126 0         if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
127           /*
128           * Already have a readbuffer in progress
129           */
130 0         return b->buf;
131           }
132 0         if (b->buf) {
133           /*
134           * We have a write buffer or flushed PerlIOBuf read buffer
135           */
136 0         m->bbuf = b->buf; /* save it in case we need it again */
137 0         b->buf = NULL; /* Clear to trigger below */
138           }
139 0         if (!b->buf) {
140 0         PerlIOMmap_map(aTHX_ f); /* Try and map it */
141 0         if (!b->buf) {
142           /*
143           * Map did not work - recover PerlIOBuf buffer if we have one
144           */
145 0         b->buf = m->bbuf;
146           }
147           }
148 0         b->ptr = b->end = b->buf;
149 0         if (b->buf)
150 0         return b->buf;
151 0         return PerlIOBuf_get_base(aTHX_ f);
152           }
153            
154           SSize_t
155 0         PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
156           {
157 0         PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
158           PerlIOBuf * const b = &m->base;
159 0         if (PerlIOBase(f)->flags & PERLIO_F_WRBUF)
160 0         PerlIO_flush(f);
161 0         if (b->ptr && (b->ptr - count) >= b->buf
162 0         && memEQ(b->ptr - count, vbuf, count)) {
163 0         b->ptr -= count;
164 0         PerlIOBase(f)->flags &= ~PERLIO_F_EOF;
165 0         return count;
166           }
167 0         if (m->len) {
168           /*
169           * Loose the unwritable mapped buffer
170           */
171 0         PerlIO_flush(f);
172           /*
173           * If flush took the "buffer" see if we have one from before
174           */
175 0         if (!b->buf && m->bbuf)
176 0         b->buf = m->bbuf;
177 0         if (!b->buf) {
178 0         PerlIOBuf_get_base(aTHX_ f);
179 0         m->bbuf = b->buf;
180           }
181           }
182 0         return PerlIOBuf_unread(aTHX_ f, vbuf, count);
183           }
184            
185           SSize_t
186 0         PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
187           {
188 0         PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
189           PerlIOBuf * const b = &m->base;
190            
191 0         if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) {
192           /*
193           * No, or wrong sort of, buffer
194           */
195 0         if (m->len) {
196 0         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 0         if (!b->buf && m->bbuf)
203 0         b->buf = m->bbuf;
204 0         if (!b->buf) {
205 0         PerlIOBuf_get_base(aTHX_ f);
206 0         m->bbuf = b->buf;
207           }
208           }
209 0         return PerlIOBuf_write(aTHX_ f, vbuf, count);
210           }
211            
212           IV
213 0         PerlIOMmap_flush(pTHX_ PerlIO *f)
214           {
215 0         PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
216           PerlIOBuf * const b = &m->base;
217 0         IV code = PerlIOBuf_flush(aTHX_ f);
218           /*
219           * Now we are "synced" at PerlIOBuf level
220           */
221 0         if (b->buf) {
222 0         if (m->len) {
223           /*
224           * Unmap the buffer
225           */
226 0         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 0         m->bbuf = b->buf;
235           }
236           }
237 0         return code;
238           }
239            
240           IV
241 0         PerlIOMmap_fill(pTHX_ PerlIO *f)
242           {
243 0         PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
244 0         IV code = PerlIO_flush(f);
245 0         if (code == 0 && !b->buf) {
246 0         code = PerlIOMmap_map(aTHX_ f);
247           }
248 0         if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) {
249 0         code = PerlIOBuf_fill(aTHX_ f);
250           }
251 0         return code;
252           }
253            
254           IV
255 0         PerlIOMmap_close(pTHX_ PerlIO *f)
256           {
257 0         PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap);
258           PerlIOBuf * const b = &m->base;
259 0         IV code = PerlIO_flush(f);
260 0         if (m->bbuf) {
261 0         b->buf = m->bbuf;
262 0         m->bbuf = NULL;
263 0         b->ptr = b->end = b->buf;
264           }
265 0         if (PerlIOBuf_close(aTHX_ f) != 0)
266           code = -1;
267 0         return code;
268           }
269            
270           PerlIO *
271 0         PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags)
272           {
273 0         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 0         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap));
318           #endif
319           }
320