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