X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/dcbac5bbcda3f6b893eade5bc95878a443cbe563..2e061f0fd1e8ed8ce1879ecdfc2e9f7e9ce3b72b:/perlio.c diff --git a/perlio.c b/perlio.c index c61ba44..0ae0a43 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. @@ -31,23 +31,7 @@ #define dSYS dNOOP #endif -#define VOIDUSED 1 -#ifdef PERL_MICRO -# include "uconfig.h" -#else -# ifndef USE_CROSS_COMPILE -# include "config.h" -# else -# include "xconfig.h" -# endif -#endif - #define PERLIO_NOT_STDIO 0 -#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO) -/* - * #define PerlIO FILE - */ -#endif /* * This file provides those parts of PerlIO abstraction * which are not #defined in perlio.h. @@ -70,6 +54,10 @@ int mkstemp(char*); #endif +#ifdef VMS +#include +#endif + #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags) /* Call the callback or PerlIOBase, and return failure. */ @@ -126,7 +114,8 @@ extern int fseeko(FILE *, off_t, int); extern off_t ftello(FILE *); #endif -#ifndef USE_SFIO +#define NATIVE_0xd CR_NATIVE +#define NATIVE_0xa LF_NATIVE EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode); @@ -137,17 +126,6 @@ perlsio_binmode(FILE *fp, int iotype, int mode) * This used to be contents of do_binmode in doio.c */ #ifdef DOSISH -# if defined(atarist) - PERL_UNUSED_ARG(iotype); - if (!fflush(fp)) { - if (mode & O_BINARY) - ((FILE *) fp)->_flag |= _IOBIN; - else - ((FILE *) fp)->_flag &= ~_IOBIN; - return 1; - } - return 0; -# else dTHX; PERL_UNUSED_ARG(iotype); #ifdef NETWARE @@ -159,7 +137,6 @@ perlsio_binmode(FILE *fp, int iotype, int mode) } else return 0; -# endif #else # if defined(USEMYBINMODE) dTHX; @@ -178,7 +155,6 @@ perlsio_binmode(FILE *fp, int iotype, int mode) # endif #endif } -#endif /* sfio */ #ifndef O_ACCMODE #define O_ACCMODE 3 /* Assume traditional implementation */ @@ -255,14 +231,7 @@ PerlIO_destruct(pTHX) int PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) { -#ifdef USE_SFIO - PERL_UNUSED_ARG(iotype); - PERL_UNUSED_ARG(mode); - PERL_UNUSED_ARG(names); - return 1; -#else return perlsio_binmode(fp, iotype, mode); -#endif } PerlIO * @@ -317,7 +286,11 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, if (*args == &PL_sv_undef) return PerlIO_tmpfile(); else { - const char *name = SvPV_nolen_const(*args); + STRLEN len; + const char *name = SvPV_const(*args, len); + if (!IS_SAFE_PATHNAME(name, len, "open")) + return NULL; + if (*mode == IoTYPE_NUMERIC) { fd = PerlLIO_open3(name, imode, perm); if (fd >= 0) @@ -337,6 +310,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, return NULL; } +XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */ XS(XS_PerlIO__Layer__find) { dXSARGS; @@ -383,67 +357,6 @@ PerlIO_tmpfile(void) #else /* PERLIO_IS_STDIO */ -#ifdef USE_SFIO - -#undef HAS_FSETPOS -#undef HAS_FGETPOS - -/* - * This section is just to make sure these functions get pulled in from - * libsfio.a - */ - -#undef PerlIO_tmpfile -PerlIO * -PerlIO_tmpfile(void) -{ - return sftmp(0); -} - -void -PerlIO_init(pTHX) -{ - PERL_UNUSED_CONTEXT; - /* - * Force this file to be included in perl binary. Which allows this - * file to force inclusion of other functions that may be required by - * loadable extensions e.g. for FileHandle::tmpfile - */ - - /* - * Hack sfio does its own 'autoflush' on stdout in common cases. Flush - * results in a lot of lseek()s to regular files and lot of small - * writes to pipes. - */ - sfset(sfstdout, SF_SHARE, 0); -} - -/* This is not the reverse of PerlIO_exportFILE(), PerlIO_releaseFILE() is. */ -PerlIO * -PerlIO_importFILE(FILE *stdio, const char *mode) -{ - const int fd = fileno(stdio); - if (!mode || !*mode) { - mode = "r+"; - } - return PerlIO_fdopen(fd, mode); -} - -FILE * -PerlIO_findFILE(PerlIO *pio) -{ - const int fd = PerlIO_fileno(pio); - FILE * const f = fdopen(fd, "r+"); - PerlIO_flush(pio); - if (!f && errno == EINVAL) - f = fdopen(fd, "w"); - if (!f && errno == EINVAL) - f = fdopen(fd, "r"); - return f; -} - - -#else /* USE_SFIO */ /*======================================================================================*/ /* * Implement all the PerlIO interface ourselves. @@ -451,10 +364,6 @@ PerlIO_findFILE(PerlIO *pio) #include "perliol.h" -#ifdef HAS_MMAP -#include -#endif - void PerlIO_debug(const char *fmt, ...) { @@ -462,7 +371,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 (!TAINTING_get && + PerlProc_getuid() == PerlProc_geteuid() && + PerlProc_getgid() == PerlProc_getegid()) { const char * const s = PerlEnv_getenv("PERLIO_DEBUG"); if (s && *s) PL_perlio_debug_fd @@ -476,14 +387,14 @@ PerlIO_debug(const char *fmt, ...) } } if (PL_perlio_debug_fd > 0) { - dTHX; + int rc = 0; #ifdef USE_ITHREADS const char * const s = CopFILE(PL_curcop); /* Use fixed buffer as sv_catpvf etc. needs SVs */ char buffer[1024]; const STRLEN len1 = my_snprintf(buffer, sizeof(buffer), "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop)); const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap); - PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2); + rc = PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2); #else const char *s = CopFILE(PL_curcop); STRLEN len; @@ -492,9 +403,11 @@ PerlIO_debug(const char *fmt, ...) Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); s = SvPV_const(sv, len); - PerlLIO_write(PL_perlio_debug_fd, s, len); + rc = PerlLIO_write(PL_perlio_debug_fd, s, len); SvREFCNT_dec(sv); #endif + /* silently ignore failures */ + PERL_UNUSED_VAR(rc); } va_end(ap); } @@ -673,7 +586,7 @@ PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param) list = PerlIO_list_alloc(aTHX); for (i=0; i < proto->cur; i++) { SV *arg = proto->array[i].arg; -#ifdef sv_dup +#ifdef USE_ITHREADS if (arg && param) arg = sv_dup(arg, param); #else @@ -822,7 +735,8 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) len = strlen(name); for (i = 0; i < PL_known_layers->cur; i++) { PerlIO_funcs * const f = PL_known_layers->array[i].funcs; - if (memEQ(f->name, name, len) && f->name[len] == 0) { + const STRLEN this_len = strlen(f->name); + if (this_len == len && memEQ(f->name, name, len)) { PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f); return f; } @@ -905,6 +819,7 @@ MGVTBL perlio_vtab = { perlio_mg_free }; +XS(XS_io_MODIFY_SCALAR_ATTRIBUTES); /* prototype to pass -Wmissing-prototypes */ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) { dXSARGS; @@ -945,6 +860,7 @@ PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab) return sv; } +XS(XS_PerlIO__Layer__NoWarnings); /* prototype to pass -Wmissing-prototypes */ XS(XS_PerlIO__Layer__NoWarnings) { /* This is used as a %SIG{__WARN__} handler to suppress warnings @@ -958,6 +874,7 @@ XS(XS_PerlIO__Layer__NoWarnings) XSRETURN(0); } +XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */ XS(XS_PerlIO__Layer__find) { dVAR; @@ -1016,7 +933,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) } do { e++; - } while (isALNUM(*e)); + } while (isWORDCHAR(*e)); llen = e - s; if (*e == '(') { int nesting = 1; @@ -1165,7 +1082,7 @@ PerlIO_default_layers(pTHX) { dVAR; if (!PL_def_layerlist) { - const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO"); + const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO"); PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix; PL_def_layerlist = PerlIO_list_alloc(aTHX); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix)); @@ -1179,9 +1096,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)); @@ -1884,9 +1798,10 @@ Perl_PerlIO_get_base(pTHX_ PerlIO *f) Perl_PerlIO_or_fail(f, Get_base, NULL, (aTHX_ f)); } -int +SSize_t Perl_PerlIO_get_bufsiz(pTHX_ PerlIO *f) { + /* Note that Get_bufsiz returns a Size_t */ Perl_PerlIO_or_fail(f, Get_bufsiz, -1, (aTHX_ f)); } @@ -1896,20 +1811,20 @@ Perl_PerlIO_get_ptr(pTHX_ PerlIO *f) Perl_PerlIO_or_fail(f, Get_ptr, NULL, (aTHX_ f)); } -int +SSize_t Perl_PerlIO_get_cnt(pTHX_ PerlIO *f) { Perl_PerlIO_or_fail(f, Get_cnt, -1, (aTHX_ f)); } void -Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, int cnt) +Perl_PerlIO_set_cnt(pTHX_ PerlIO *f, SSize_t cnt) { Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, NULL, cnt)); } void -Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, int cnt) +Perl_PerlIO_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) { Perl_PerlIO_or_fail_void(f, Set_ptrcnt, (aTHX_ f, ptr, cnt)); } @@ -2169,7 +2084,7 @@ PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) SSize_t avail = PerlIO_get_cnt(f); SSize_t take = 0; if (avail > 0) - take = ((SSize_t)count < avail) ? (SSize_t)count : avail; + take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail; if (take > 0) { STDCHAR *ptr = PerlIO_get_ptr(f); Copy(ptr, buf, take, STDCHAR); @@ -2280,7 +2195,7 @@ PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param) { if (!arg) return NULL; -#ifdef sv_dup +#ifdef USE_ITHREADS if (param) { arg = sv_dup(arg, param); SvREFCNT_inc_simple_void_NN(arg); @@ -2316,7 +2231,7 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) if (self && self->Getarg) arg = (*self->Getarg)(aTHX_ o, param, flags); f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); - if (PerlIOBase(o)->flags & PERLIO_F_UTF8) + if (f && PerlIOBase(o)->flags & PERLIO_F_UTF8) PerlIOBase(f)->flags |= PERLIO_F_UTF8; SvREFCNT_dec(arg); } @@ -2350,10 +2265,7 @@ S_more_refcounted_fds(pTHX_ const int new_fd) { #ifdef USE_ITHREADS MUTEX_UNLOCK(&PL_perlio_mutex); #endif - /* Can't use PerlIO to write as it allocates memory */ - PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, strlen(PL_no_mem)); - my_exit(1); + croak_no_mem(); } PL_perlio_fd_refcnt_size = new_max; @@ -2408,7 +2320,6 @@ PerlIOUnix_refcnt_inc(int fd) int PerlIOUnix_refcnt_dec(int fd) { - dTHX; int cnt = 0; if (fd >= 0) { dVAR; @@ -2417,12 +2328,12 @@ PerlIOUnix_refcnt_dec(int fd) #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", + Perl_croak_nocontext("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", + Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n", fd, PL_perlio_fd_refcnt[fd]); } cnt = --PL_perlio_fd_refcnt[fd]; @@ -2432,7 +2343,7 @@ PerlIOUnix_refcnt_dec(int fd) #endif } else { /* diag_listed_as: refcnt_dec: fd %d%s */ - Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd); + Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd); } return cnt; } @@ -2628,10 +2539,15 @@ PerlIOUnix_oflags(const char *mode) oflags &= ~O_BINARY; mode++; } - /* - * Always open in binary mode - */ - oflags |= O_BINARY; + else { +#ifdef PERLIO_USING_CRLF + /* + * If neither "t" nor "b" was specified, open the file + * in O_BINARY mode. + */ + oflags |= O_BINARY; +#endif + } if (*mode || oflags == -1) { SETERRNO(EINVAL, LIB_INVARG); oflags = -1; @@ -2730,7 +2646,10 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, #endif } if (imode != -1) { - const char *path = SvPV_nolen_const(*args); + STRLEN len; + const char *path = SvPV_const(*args, len); + if (!IS_SAFE_PATHNAME(path, len, "open")) + return NULL; fd = PerlLIO_open3(path, imode, perm); } } @@ -3042,9 +2961,12 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, { char tmode[8]; if (PerlIOValid(f)) { - const char * const path = SvPV_nolen_const(*args); + STRLEN len; + const char * const path = SvPV_const(*args, len); PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio); FILE *stdio; + if (!IS_SAFE_PATHNAME(path, len, "open")) + return NULL; PerlIOUnix_refcnt_dec(fileno(s->stdio)); stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)), s->stdio); @@ -3056,7 +2978,10 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, } else { if (narg > 0) { - const char * const path = SvPV_nolen_const(*args); + STRLEN len; + const char * const path = SvPV_const(*args, len); + if (!IS_SAFE_PATHNAME(path, len, "open")) + return NULL; if (*mode == IoTYPE_NUMERIC) { mode++; fd = PerlLIO_open3(path, imode, perm); @@ -3180,7 +3105,7 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) */ f->_fileno = -1; return 1; -# elif defined(__sun__) +# elif defined(__sun) PERL_UNUSED_ARG(f); return 0; # elif defined(__hpux) @@ -3806,12 +3731,14 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f) while ((l = *p)) { if (l->tab == &PerlIO_stdio) { PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); - if (s->stdio == f) { - dTHX; + if (s->stdio == f) { /* not in a loop */ const int fd = fileno(f); if (fd >= 0) PerlIOUnix_refcnt_dec(fd); - PerlIO_pop(aTHX_ p); + { + dTHX; + PerlIO_pop(aTHX_ p); + } return; } } @@ -3900,7 +3827,6 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, PerlLIO_setmode(fd, O_BINARY); #endif #ifdef VMS -#include /* Enable line buffering with record-oriented regular files * so we don't introduce an extraneous record boundary when * the buffer fills up. @@ -4103,7 +4029,7 @@ PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) */ b->posn -= b->bufsiz; } - if (avail > (SSize_t) count) { + if ((SSize_t) count >= 0 && avail > (SSize_t) count) { /* * If we have space for more than count, just move count */ @@ -4153,7 +4079,7 @@ PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) } while (count > 0) { SSize_t avail = b->bufsiz - (b->ptr - b->buf); - if ((SSize_t) count < avail) + if ((SSize_t) count >= 0 && (SSize_t) count < avail) avail = count; if (flushptr > buf && flushptr <= buf + avail) avail = flushptr - buf; @@ -4428,7 +4354,7 @@ PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { SSize_t avail = PerlIO_get_cnt(f); SSize_t got = 0; - if ((SSize_t)count < avail) + if ((SSize_t) count >= 0 && (SSize_t)count < avail) avail = count; if (avail > 0) got = PerlIOBuf_read(aTHX_ f, vbuf, avail); @@ -4546,7 +4472,7 @@ PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); if (c->nl) { /* XXXX Shouldn't it be done only if b->ptr > c->nl? */ - *(c->nl) = 0xd; + *(c->nl) = NATIVE_0xd; c->nl = NULL; } if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) @@ -4569,14 +4495,15 @@ PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) const int ch = *--buf; if (ch == '\n') { if (b->ptr - 2 >= b->buf) { - *--(b->ptr) = 0xa; - *--(b->ptr) = 0xd; + *--(b->ptr) = NATIVE_0xa; + *--(b->ptr) = NATIVE_0xd; unread++; count--; } else { /* If b->ptr - 1 == b->buf, we are undoing reading 0xa */ - *--(b->ptr) = 0xa; /* Works even if 0xa == '\r' */ + *--(b->ptr) = NATIVE_0xa; /* Works even if 0xa == + '\r' */ unread++; count--; } @@ -4588,6 +4515,8 @@ PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) } } } + if (count > 0) + unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count); return unread; } } @@ -4601,15 +4530,15 @@ PerlIOCrlf_get_cnt(pTHX_ PerlIO *f) PerlIO_get_base(f); if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); - if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == 0xd)) { + if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && (!c->nl || *c->nl == NATIVE_0xd)) { STDCHAR *nl = (c->nl) ? c->nl : b->ptr; scan: - while (nl < b->end && *nl != 0xd) + while (nl < b->end && *nl != NATIVE_0xd) nl++; - if (nl < b->end && *nl == 0xd) { + if (nl < b->end && *nl == NATIVE_0xd) { test: if (nl + 1 < b->end) { - if (nl[1] == 0xa) { + if (nl[1] == NATIVE_0xa) { *nl = '\n'; c->nl = nl; } @@ -4649,7 +4578,7 @@ PerlIOCrlf_get_cnt(pTHX_ PerlIO *f) b->buf--; /* Point at space */ b->ptr = nl = b->buf; /* Which is what we hand * off */ - *nl = 0xd; /* Fill in the CR */ + *nl = NATIVE_0xd; /* Fill in the CR */ if (code == 0) goto test; /* fill() call worked */ /* @@ -4675,7 +4604,7 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) if (!ptr) { if (c->nl) { ptr = c->nl + 1; - if (ptr == b->end && *c->nl == 0xd) { + if (ptr == b->end && *c->nl == NATIVE_0xd) { /* Deferred CR at end of buffer case - we lied about count */ ptr--; } @@ -4693,7 +4622,7 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) */ IV flags = PerlIOBase(f)->flags; STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end; - if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) { + if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == NATIVE_0xd) { /* Deferred CR at end of buffer case - we lied about count */ chk--; } @@ -4711,7 +4640,7 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) /* * They have taken what we lied about */ - *(c->nl) = 0xd; + *(c->nl) = NATIVE_0xd; c->nl = NULL; ptr++; } @@ -4746,8 +4675,8 @@ PerlIOCrlf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) break; } else { - *(b->ptr)++ = 0xd; /* CR */ - *(b->ptr)++ = 0xa; /* LF */ + *(b->ptr)++ = NATIVE_0xd; /* CR */ + *(b->ptr)++ = NATIVE_0xa; /* LF */ buf++; if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { PerlIO_flush(f); @@ -4775,7 +4704,7 @@ PerlIOCrlf_flush(pTHX_ PerlIO *f) { PerlIOCrlf * const c = PerlIOSelf(f, PerlIOCrlf); if (c->nl) { - *(c->nl) = 0xd; + *(c->nl) = NATIVE_0xd; c->nl = NULL; } return PerlIOBuf_flush(aTHX_ f); @@ -4826,297 +4755,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) { @@ -5152,8 +4790,8 @@ Perl_PerlIO_stderr(pTHX) char * PerlIO_getname(PerlIO *f, char *buf) { - dTHX; #ifdef VMS + dTHX; char *name = NULL; bool exported = FALSE; FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; @@ -5169,7 +4807,7 @@ PerlIO_getname(PerlIO *f, char *buf) #else PERL_UNUSED_ARG(f); PERL_UNUSED_ARG(buf); - Perl_croak(aTHX_ "Don't know how to get file name"); + Perl_croak_nocontext("Don't know how to get file name"); return NULL; #endif } @@ -5309,7 +4947,9 @@ PerlIO_stdoutf(const char *fmt, ...) PerlIO * PerlIO_tmpfile(void) { +#ifndef WIN32 dTHX; +#endif PerlIO *f = NULL; #ifdef WIN32 const int fd = win32_tmpfd(); @@ -5319,7 +4959,7 @@ PerlIO_tmpfile(void) # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2) int fd = -1; char tempname[] = "/tmp/PerlIO_XXXXXX"; - const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR"); + const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR"); SV * sv = NULL; /* * I have no idea how portable mkstemp() is ... NI-S @@ -5331,10 +4971,17 @@ PerlIO_tmpfile(void) fd = mkstemp(SvPVX(sv)); } if (fd < 0) { + SvREFCNT_dec(sv); sv = NULL; /* else we try /tmp */ fd = mkstemp(tempname); } + if (fd < 0) { + /* Try cwd */ + sv = newSVpvs("."); + sv_catpv(sv, tempname + 4); + fd = mkstemp(SvPVX(sv)); + } if (fd >= 0) { f = PerlIO_fdopen(fd, "w+"); if (f) @@ -5356,7 +5003,6 @@ PerlIO_tmpfile(void) #undef HAS_FSETPOS #undef HAS_FGETPOS -#endif /* USE_SFIO */ #endif /* PERLIO_IS_STDIO */ /*======================================================================================*/ @@ -5399,9 +5045,9 @@ Perl_PerlIO_context_layers(pTHX_ const char *mode) int PerlIO_setpos(PerlIO *f, SV *pos) { - dTHX; if (SvOK(pos)) { STRLEN len; + dTHX; const Off_t * const posn = (Off_t *) SvPV(pos, len); if (f && len == sizeof(Off_t)) return PerlIO_seek(f, *posn, SEEK_SET); @@ -5459,7 +5105,7 @@ PerlIO_getpos(PerlIO *f, SV *pos) } #endif -#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF) +#if !defined(HAS_VPRINTF) int vprintf(char *pat, char *args) @@ -5479,42 +5125,12 @@ vfprintf(FILE *fd, char *pat, char *args) #endif -#ifndef PerlIO_vsprintf -int -PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) -{ - dTHX; - const int val = my_vsnprintf(s, n > 0 ? n : 0, fmt, ap); - PERL_UNUSED_CONTEXT; - -#ifndef PERL_MY_VSNPRINTF_GUARDED - if (val < 0 || (n > 0 ? val >= n : 0)) { - Perl_croak(aTHX_ "panic: my_vsnprintf overflow in PerlIO_vsprintf\n"); - } -#endif - return val; -} -#endif - -#ifndef PerlIO_sprintf -int -PerlIO_sprintf(char *s, int n, const char *fmt, ...) -{ - va_list ap; - int result; - va_start(ap, fmt); - result = PerlIO_vsprintf(s, n, fmt, ap); - va_end(ap); - return result; -} -#endif - /* * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */