X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2e0cfa16dea85dd33fe3cbf38f3324f4a8418181..9c39c5366bcf770efa7af1f634be0a019c74bf8f:/perlio.c diff --git a/perlio.c b/perlio.c index 6a092d0..7782728 100644 --- a/perlio.c +++ b/perlio.c @@ -1,7 +1,7 @@ /* * perlio.c * Copyright (c) 1996-2006, Nick Ing-Simmons - * Copyright (c) 2006, 2007, 2008 Larry Wall and others + * Copyright (c) 2006, 2007, 2008, 2009, 2010, 2011 Larry Wall and others * * You may distribute under the terms of either the GNU General Public License * or the Artistic License, as specified in the README file. @@ -155,23 +155,6 @@ perlsio_binmode(FILE *fp, int iotype, int mode) #else if (PerlLIO_setmode(fileno(fp), mode) != -1) { #endif -# if defined(WIN32) && defined(__BORLANDC__) - /* - * The translation mode of the stream is maintained independent -of - * the translation mode of the fd in the Borland RTL (heavy - * digging through their runtime sources reveal). User has to -set - * the mode explicitly for the stream (though they don't -document - * this anywhere). GSAR 97-5-24 - */ - fseek(fp, 0L, 0); - if (mode & O_BINARY) - fp->flags |= _F_BIN; - else - fp->flags &= ~_F_BIN; -# endif return 1; } else @@ -468,17 +451,6 @@ PerlIO_findFILE(PerlIO *pio) #include "perliol.h" -/* - * We _MUST_ have if we are using lseek() and may have large - * files - */ -#ifdef I_UNISTD -#include -#endif -#ifdef HAS_MMAP -#include -#endif - void PerlIO_debug(const char *fmt, ...) { @@ -486,7 +458,9 @@ PerlIO_debug(const char *fmt, ...) dSYS; va_start(ap, fmt); if (!PL_perlio_debug_fd) { - if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) { + if (!PL_tainting && + PerlProc_getuid() == PerlProc_geteuid() && + PerlProc_getgid() == PerlProc_getegid()) { const char * const s = PerlEnv_getenv("PERLIO_DEBUG"); if (s && *s) PL_perlio_debug_fd @@ -1203,9 +1177,6 @@ PerlIO_default_layers(pTHX) PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio)); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio)); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf)); -#ifdef HAS_MMAP - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap)); -#endif PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8)); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove)); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte)); @@ -1543,6 +1514,7 @@ PerlIO_layer_from_ref(pTHX_ SV *sv) /* This isn't supposed to happen, since PerlIO::scalar is core, * but could happen anyway in smaller installs or with PAR */ if (!f) + /* diag_listed_as: Unknown PerlIO layer "%s" */ Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\""); return f; } @@ -1963,7 +1935,7 @@ PERLIO_FUNCS_DECL(PerlIO_utf8) = { sizeof(PerlIO_funcs), "utf8", 0, - PERLIO_K_DUMMY | PERLIO_K_UTF8, + PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG, PerlIOUtf8_pushed, NULL, PerlIOBase_open, @@ -1994,7 +1966,7 @@ PERLIO_FUNCS_DECL(PerlIO_byte) = { sizeof(PerlIO_funcs), "bytes", 0, - PERLIO_K_DUMMY, + PERLIO_K_DUMMY | PERLIO_K_MULTIARG, PerlIOUtf8_pushed, NULL, PerlIOBase_open, @@ -2412,6 +2384,7 @@ PerlIOUnix_refcnt_inc(int fd) PL_perlio_fd_refcnt[fd]++; if (PL_perlio_fd_refcnt[fd] <= 0) { + /* diag_listed_as: refcnt_inc: fd %d%s */ Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n", fd, PL_perlio_fd_refcnt[fd]); } @@ -2422,6 +2395,7 @@ PerlIOUnix_refcnt_inc(int fd) MUTEX_UNLOCK(&PL_perlio_mutex); #endif } else { + /* diag_listed_as: refcnt_inc: fd %d%s */ Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd); } } @@ -2437,10 +2411,12 @@ PerlIOUnix_refcnt_dec(int fd) MUTEX_LOCK(&PL_perlio_mutex); #endif if (fd >= PL_perlio_fd_refcnt_size) { + /* diag_listed_as: refcnt_dec: fd %d%s */ Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n", fd, PL_perlio_fd_refcnt_size); } if (PL_perlio_fd_refcnt[fd] <= 0) { + /* diag_listed_as: refcnt_dec: fd %d%s */ Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n", fd, PL_perlio_fd_refcnt[fd]); } @@ -2450,6 +2426,7 @@ PerlIOUnix_refcnt_dec(int fd) MUTEX_UNLOCK(&PL_perlio_mutex); #endif } else { + /* diag_listed_as: refcnt_dec: fd %d%s */ Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd); } return cnt; @@ -2582,8 +2559,10 @@ S_perlio_async_run(pTHX_ PerlIO* f) { SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f); PerlIO_lockcnt(f)++; PERL_ASYNC_CHECK(); - if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) + if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) { + LEAVE; return 0; + } /* we've just run some perl-level code that could have done * anything, including closing the file or clearing this layer. * If so, free any lower layers that have already been @@ -2595,6 +2574,7 @@ S_perlio_async_run(pTHX_ PerlIO* f) { *f = l->next; Safefree(l); } + LEAVE; return 1; } @@ -3236,9 +3216,7 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) f->_file = -1; return 1; # elif defined(WIN32) -# if defined(__BORLANDC__) - f->fd = PerlLIO_dup(fileno(f)); -# elif defined(UNDER_CE) +# if defined(UNDER_CE) /* WIN_CE does not have access to FILE internals, it hardly has FILE structure at all */ @@ -4539,10 +4517,8 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PerlIOBase(f)->flags); #endif { - /* Enable the first CRLF capable layer you can find, but if none - * found, the one we just pushed is fine. This results in at - * any given moment at most one CRLF-capable layer being enabled - * in the whole layer stack. */ + /* If the old top layer is a CRLF layer, reactivate it (if + * necessary) and remove this new layer from the stack */ PerlIO *g = PerlIONext(f); if (PerlIOValid(g)) { PerlIOl *b = PerlIOBase(g); @@ -4845,297 +4821,6 @@ PERLIO_FUNCS_DECL(PerlIO_crlf) = { PerlIOCrlf_set_ptrcnt, }; -#ifdef HAS_MMAP -/*--------------------------------------------------------------------------------------*/ -/* - * mmap as "buffer" layer - */ - -typedef struct { - PerlIOBuf base; /* PerlIOBuf stuff */ - Mmap_t mptr; /* Mapped address */ - Size_t len; /* mapped length */ - STDCHAR *bbuf; /* malloced buffer if map fails */ -} PerlIOMmap; - -IV -PerlIOMmap_map(pTHX_ PerlIO *f) -{ - dVAR; - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - const IV flags = PerlIOBase(f)->flags; - IV code = 0; - if (m->len) - abort(); - if (flags & PERLIO_F_CANREAD) { - PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); - const int fd = PerlIO_fileno(f); - Stat_t st; - code = Fstat(fd, &st); - if (code == 0 && S_ISREG(st.st_mode)) { - SSize_t len = st.st_size - b->posn; - if (len > 0) { - Off_t posn; - if (PL_mmap_page_size <= 0) - Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, - PL_mmap_page_size); - if (b->posn < 0) { - /* - * This is a hack - should never happen - open should - * have set it ! - */ - b->posn = PerlIO_tell(PerlIONext(f)); - } - posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size; - len = st.st_size - posn; - m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn); - if (m->mptr && m->mptr != (Mmap_t) - 1) { -#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL) - madvise(m->mptr, len, MADV_SEQUENTIAL); -#endif -#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED) - madvise(m->mptr, len, MADV_WILLNEED); -#endif - PerlIOBase(f)->flags = - (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF; - b->end = ((STDCHAR *) m->mptr) + len; - b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn); - b->ptr = b->buf; - m->len = len; - } - else { - b->buf = NULL; - } - } - else { - PerlIOBase(f)->flags = - flags | PERLIO_F_EOF | PERLIO_F_RDBUF; - b->buf = NULL; - b->ptr = b->end = b->ptr; - code = -1; - } - } - } - return code; -} - -IV -PerlIOMmap_unmap(pTHX_ PerlIO *f) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - IV code = 0; - if (m->len) { - PerlIOBuf * const b = &m->base; - if (b->buf) { - /* The munmap address argument is tricky: depending on the - * standard it is either "void *" or "caddr_t" (which is - * usually "char *" (signed or unsigned). If we cast it - * to "void *", those that have it caddr_t and an uptight - * C++ compiler, will freak out. But casting it as char* - * should work. Maybe. (Using Mmap_t figured out by - * Configure doesn't always work, apparently.) */ - code = munmap((char*)m->mptr, m->len); - b->buf = NULL; - m->len = 0; - m->mptr = NULL; - if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0) - code = -1; - } - b->ptr = b->end = b->buf; - PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); - } - return code; -} - -STDCHAR * -PerlIOMmap_get_base(pTHX_ PerlIO *f) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - PerlIOBuf * const b = &m->base; - if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { - /* - * Already have a readbuffer in progress - */ - return b->buf; - } - if (b->buf) { - /* - * We have a write buffer or flushed PerlIOBuf read buffer - */ - m->bbuf = b->buf; /* save it in case we need it again */ - b->buf = NULL; /* Clear to trigger below */ - } - if (!b->buf) { - PerlIOMmap_map(aTHX_ f); /* Try and map it */ - if (!b->buf) { - /* - * Map did not work - recover PerlIOBuf buffer if we have one - */ - b->buf = m->bbuf; - } - } - b->ptr = b->end = b->buf; - if (b->buf) - return b->buf; - return PerlIOBuf_get_base(aTHX_ f); -} - -SSize_t -PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - PerlIOBuf * const b = &m->base; - if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) - PerlIO_flush(f); - if (b->ptr && (b->ptr - count) >= b->buf - && memEQ(b->ptr - count, vbuf, count)) { - b->ptr -= count; - PerlIOBase(f)->flags &= ~PERLIO_F_EOF; - return count; - } - if (m->len) { - /* - * Loose the unwritable mapped buffer - */ - PerlIO_flush(f); - /* - * If flush took the "buffer" see if we have one from before - */ - if (!b->buf && m->bbuf) - b->buf = m->bbuf; - if (!b->buf) { - PerlIOBuf_get_base(aTHX_ f); - m->bbuf = b->buf; - } - } - return PerlIOBuf_unread(aTHX_ f, vbuf, count); -} - -SSize_t -PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - PerlIOBuf * const b = &m->base; - - if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) { - /* - * No, or wrong sort of, buffer - */ - if (m->len) { - if (PerlIOMmap_unmap(aTHX_ f) != 0) - return 0; - } - /* - * If unmap took the "buffer" see if we have one from before - */ - if (!b->buf && m->bbuf) - b->buf = m->bbuf; - if (!b->buf) { - PerlIOBuf_get_base(aTHX_ f); - m->bbuf = b->buf; - } - } - return PerlIOBuf_write(aTHX_ f, vbuf, count); -} - -IV -PerlIOMmap_flush(pTHX_ PerlIO *f) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - PerlIOBuf * const b = &m->base; - IV code = PerlIOBuf_flush(aTHX_ f); - /* - * Now we are "synced" at PerlIOBuf level - */ - if (b->buf) { - if (m->len) { - /* - * Unmap the buffer - */ - if (PerlIOMmap_unmap(aTHX_ f) != 0) - code = -1; - } - else { - /* - * We seem to have a PerlIOBuf buffer which was not mapped - * remember it in case we need one later - */ - m->bbuf = b->buf; - } - } - return code; -} - -IV -PerlIOMmap_fill(pTHX_ PerlIO *f) -{ - PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); - IV code = PerlIO_flush(f); - if (code == 0 && !b->buf) { - code = PerlIOMmap_map(aTHX_ f); - } - if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { - code = PerlIOBuf_fill(aTHX_ f); - } - return code; -} - -IV -PerlIOMmap_close(pTHX_ PerlIO *f) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - PerlIOBuf * const b = &m->base; - IV code = PerlIO_flush(f); - if (m->bbuf) { - b->buf = m->bbuf; - m->bbuf = NULL; - b->ptr = b->end = b->buf; - } - if (PerlIOBuf_close(aTHX_ f) != 0) - code = -1; - return code; -} - -PerlIO * -PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) -{ - return PerlIOBase_dup(aTHX_ f, o, param, flags); -} - - -PERLIO_FUNCS_DECL(PerlIO_mmap) = { - sizeof(PerlIO_funcs), - "mmap", - sizeof(PerlIOMmap), - PERLIO_K_BUFFERED|PERLIO_K_RAW, - PerlIOBuf_pushed, - PerlIOBuf_popped, - PerlIOBuf_open, - PerlIOBase_binmode, /* binmode */ - NULL, - PerlIOBase_fileno, - PerlIOMmap_dup, - PerlIOBuf_read, - PerlIOMmap_unread, - PerlIOMmap_write, - PerlIOBuf_seek, - PerlIOBuf_tell, - PerlIOBuf_close, - PerlIOMmap_flush, - PerlIOMmap_fill, - PerlIOBase_eof, - PerlIOBase_error, - PerlIOBase_clearerr, - PerlIOBase_setlinebuf, - PerlIOMmap_get_base, - PerlIOBuf_bufsiz, - PerlIOBuf_get_ptr, - PerlIOBuf_get_cnt, - PerlIOBuf_set_ptrcnt, -}; - -#endif /* HAS_MMAP */ - PerlIO * Perl_PerlIO_stdin(pTHX) {