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
|
|
|
|
|
|
|