X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/12605ff99dc0b98fd730bbd2380934b87b8b32f5..5e20fb07d2b8373f53f053086ba668649763de9a:/perlio.c diff --git a/perlio.c b/perlio.c index 42bdb84..f5eb485 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. @@ -65,9 +49,8 @@ #include "XSUB.h" -#ifdef __Lynx__ -/* Missing proto on LynxOS */ -int mkstemp(char*); +#ifdef VMS +#include #endif #define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags) @@ -126,7 +109,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 +121,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 @@ -155,28 +128,10 @@ 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 return 0; -# endif #else # if defined(USEMYBINMODE) dTHX; @@ -195,7 +150,6 @@ document # endif #endif } -#endif /* sfio */ #ifndef O_ACCMODE #define O_ACCMODE 3 /* Assume traditional implementation */ @@ -240,8 +194,12 @@ PerlIO_intmode2str(int rawmode, char *mode, int *writing) mode[ix++] = '+'; } } +#if O_BINARY != 0 + /* Unless O_BINARY is different from zero, bit-and:ing + * with it won't do much good. */ if (rawmode & O_BINARY) mode[ix++] = 'b'; +# endif mode[ix] = '\0'; return ptype; } @@ -272,14 +230,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 * @@ -287,22 +238,21 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) { #if defined(PERL_MICRO) || defined(__SYMBIAN32__) return NULL; -#else -#ifdef PERL_IMPLICIT_SYS +#elif defined(PERL_IMPLICIT_SYS) return PerlSIO_fdupopen(f); #else -#ifdef WIN32 +# ifdef WIN32 return win32_fdupopen(f); -#else +# else if (f) { - const int fd = PerlLIO_dup(PerlIO_fileno(f)); + const int fd = PerlLIO_dup_cloexec(PerlIO_fileno(f)); if (fd >= 0) { char mode[8]; -#ifdef DJGPP +# ifdef DJGPP const int omode = djgpp_get_stream_mode(f); -#else +# else const int omode = fcntl(fd, F_GETFL); -#endif +# endif PerlIO_intmode2str(omode,mode,NULL); /* the r+ is a hack */ return PerlIO_fdopen(fd, mode); @@ -312,10 +262,9 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) else { SETERRNO(EBADF, SS_IVCHAN); } -#endif +# endif return NULL; #endif -#endif } @@ -334,9 +283,13 @@ 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); + fd = PerlLIO_open3_cloexec(name, imode, perm); if (fd >= 0) return PerlIO_fdopen(fd, mode + 1); } @@ -354,6 +307,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; @@ -377,90 +331,6 @@ Perl_boot_core_PerlIO(pTHX) #endif -#ifdef PERLIO_IS_STDIO - -void -PerlIO_init(pTHX) -{ - PERL_UNUSED_CONTEXT; - /* - * Does nothing (yet) except force this file to be included in perl - * binary. That allows this file to force inclusion of other functions - * that may be required by loadable extensions e.g. for - * FileHandle::tmpfile - */ -} - -#undef PerlIO_tmpfile -PerlIO * -PerlIO_tmpfile(void) -{ - return tmpfile(); -} - -#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. @@ -468,46 +338,41 @@ 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, ...) { va_list ap; dSYS; + + if (!DEBUG_i_TEST) + return; + 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 - = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666); + PL_perlio_debug_fd = PerlLIO_open3_cloexec(s, + O_WRONLY | O_CREAT | O_APPEND, 0666); else - PL_perlio_debug_fd = -1; + PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */ } else { - /* tainting or set*id, so ignore the environment, and ensure we - skip these tests next time through. */ - PL_perlio_debug_fd = -1; + /* tainting or set*id, so ignore the environment and send the + debug output to stderr, like other -D switches. */ + PL_perlio_debug_fd = PerlLIO_dup_cloexec(2); /* stderr */ } } if (PL_perlio_debug_fd > 0) { - dTHX; #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); + PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2)); #else const char *s = CopFILE(PL_curcop); STRLEN len; @@ -516,7 +381,7 @@ 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); + PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, s, len)); SvREFCNT_dec(sv); #endif } @@ -538,6 +403,9 @@ PerlIO_verify_head(pTHX_ PerlIO *f) { PerlIOl *head, *p; int seen = 0; +#ifndef PERL_IMPLICIT_SYS + PERL_UNUSED_CONTEXT; +#endif if (!PerlIOValid(f)) return; p = head = PerlIOBase(f)->head; @@ -573,7 +441,6 @@ PerlIO_init_table(pTHX) PerlIO * PerlIO_allocate(pTHX) { - dVAR; /* * Find a free slot in the table, allocating new table as necessary */ @@ -585,10 +452,7 @@ PerlIO_allocate(pTHX) last = (PerlIOl **) (f); for (i = 1; i < PERLIO_TABLE_SIZE; i++) { if (!((++f)->next)) { - f->flags = 0; /* lockcnt */ - f->tab = NULL; - f->head = f; - return (PerlIO *)f; + goto good_exit; } } } @@ -597,6 +461,8 @@ PerlIO_allocate(pTHX) return NULL; } *last = (PerlIOl*) f++; + + good_exit: f->flags = 0; /* lockcnt */ f->tab = NULL; f->head = f; @@ -609,7 +475,7 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) { if (PerlIOValid(f)) { const PerlIO_funcs * const tab = PerlIOBase(f)->tab; - PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param); + DEBUG_i( PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param) ); if (tab && tab->Dup) return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags); else { @@ -670,16 +536,16 @@ PerlIO_list_free(pTHX_ PerlIO_list_t *list) void PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) { - dVAR; PerlIO_pair_t *p; PERL_UNUSED_CONTEXT; if (list->cur >= list->len) { - list->len += 8; + const IV new_len = list->len + 8; if (list->array) - Renew(list->array, list->len, PerlIO_pair_t); + Renew(list->array, new_len, PerlIO_pair_t); else - Newx(list->array, list->len, PerlIO_pair_t); + Newx(list->array, new_len, PerlIO_pair_t); + list->len = new_len; } p = &(list->array[list->cur++]); p->funcs = funcs; @@ -697,7 +563,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 @@ -719,7 +585,7 @@ PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param); PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param); PerlIO_init_table(aTHX); - PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto); + DEBUG_i( PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto) ); while ((f = *table)) { int i; table = (PerlIOl **) (f++); @@ -740,11 +606,10 @@ PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) void PerlIO_destruct(pTHX) { - dVAR; PerlIOl **table = &PL_perlio; PerlIOl *f; #ifdef USE_ITHREADS - PerlIO_debug("Destruct %p\n",(void*)aTHX); + DEBUG_i( PerlIO_debug("Destruct %p\n",(void*)aTHX) ); #endif while ((f = *table)) { int i; @@ -754,7 +619,7 @@ PerlIO_destruct(pTHX) const PerlIOl *l; while ((l = *x)) { if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) { - PerlIO_debug("Destruct popping %s\n", l->tab->name); + DEBUG_i( PerlIO_debug("Destruct popping %s\n", l->tab->name) ); PerlIO_flush(x); PerlIO_pop(aTHX_ x); } @@ -773,8 +638,8 @@ PerlIO_pop(pTHX_ PerlIO *f) const PerlIOl *l = *f; VERIFY_HEAD(f); if (l) { - PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, - l->tab ? l->tab->name : "(Null)"); + DEBUG_i( PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, + l->tab ? l->tab->name : "(Null)") ); if (l->tab && l->tab->Popped) { /* * If popped returns non-zero do not free its layer structure @@ -806,7 +671,6 @@ PerlIO_pop(pTHX_ PerlIO *f) AV * PerlIO_get_layers(pTHX_ PerlIO *f) { - dVAR; AV * const av = newAV(); if (PerlIOValid(f)) { @@ -840,14 +704,15 @@ PerlIO_get_layers(pTHX_ PerlIO *f) PerlIO_funcs * PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) { - dVAR; + IV i; if ((SSize_t) len <= 0) 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) { - PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f); + const STRLEN this_len = strlen(f->name); + if (this_len == len && memEQ(f->name, name, len)) { + DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) ); return f; } } @@ -875,7 +740,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) return PerlIO_find_layer(aTHX_ name, len, 0); } } - PerlIO_debug("Cannot find %.*s\n", (int) len, name); + DEBUG_i( PerlIO_debug("Cannot find %.*s\n", (int) len, name) ); return NULL; } @@ -929,6 +794,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; @@ -959,7 +825,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) XSRETURN(count); } -#endif /* USE_ATTIBUTES_FOR_PERLIO */ +#endif /* USE_ATTRIBUTES_FOR_PERLIO */ SV * PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab) @@ -969,30 +835,30 @@ 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 during loading of layers. */ - dVAR; dXSARGS; - PERL_UNUSED_ARG(cv); - if (items) - PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))); + PERL_UNUSED_VAR(items); + DEBUG_i( + if (items) + PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))) ); XSRETURN(0); } +XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */ XS(XS_PerlIO__Layer__find) { - dVAR; dXSARGS; - PERL_UNUSED_ARG(cv); if (items < 2) Perl_croak(aTHX_ "Usage class->find(name[,load])"); else { STRLEN len; const char * const name = SvPV_const(ST(1), len); - const bool load = (items > 2) ? SvTRUE(ST(2)) : 0; + const bool load = (items > 2) ? SvTRUE_NN(ST(2)) : 0; PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ name, len, load); ST(0) = (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : @@ -1004,17 +870,15 @@ XS(XS_PerlIO__Layer__find) void PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) { - dVAR; if (!PL_known_layers) PL_known_layers = PerlIO_list_alloc(aTHX); PerlIO_list_push(aTHX_ PL_known_layers, tab, NULL); - PerlIO_debug("define %s %p\n", tab->name, (void*)tab); + DEBUG_i( PerlIO_debug("define %s %p\n", tab->name, (void*)tab) ); } int PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) { - dVAR; if (names) { const char *s = names; while (*s) { @@ -1040,7 +904,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; @@ -1063,9 +927,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) if (*e++) { break; } - /* - * Drop through - */ + /* Fall through */ case '\0': e--; Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), @@ -1107,7 +969,6 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) void PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) { - dVAR; PERLIO_FUNCS_DECL(*tab) = &PerlIO_perlio; #ifdef PERLIO_USING_CRLF tab = &PerlIO_crlf; @@ -1115,9 +976,8 @@ PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) if (PerlIO_stdio.Set_ptrcnt) tab = &PerlIO_stdio; #endif - PerlIO_debug("Pushing %s\n", tab->name); - PerlIO_list_push(aTHX_ av, PerlIO_find_layer(aTHX_ tab->name, 0, 0), - &PL_sv_undef); + DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) ); + PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef); } SV * @@ -1130,8 +990,8 @@ PerlIO_funcs * PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def) { if (n >= 0 && n < av->cur) { - PerlIO_debug("Layer %" IVdf " is %s\n", n, - av->array[n].funcs->name); + DEBUG_i( PerlIO_debug("Layer %" IVdf " is %s\n", n, + av->array[n].funcs->name) ); return av->array[n].funcs; } if (!def) @@ -1187,9 +1047,8 @@ PERLIO_FUNCS_DECL(PerlIO_remove) = { PerlIO_list_t * 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)); @@ -1203,15 +1062,11 @@ 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)); - PerlIO_list_push(aTHX_ PL_def_layerlist, - PerlIO_find_layer(aTHX_ osLayer->name, 0, 0), - &PL_sv_undef); + PerlIO_list_push(aTHX_ PL_def_layerlist, (PerlIO_funcs *)osLayer, + &PL_sv_undef); if (s) { PerlIO_parse_layers(aTHX_ PL_def_layerlist, s); } @@ -1239,7 +1094,6 @@ Perl_boot_core_PerlIO(pTHX) PerlIO_funcs * PerlIO_default_layer(pTHX_ I32 n) { - dVAR; PerlIO_list_t * const av = PerlIO_default_layers(aTHX); if (n < 0) n += av->cur; @@ -1252,7 +1106,6 @@ PerlIO_default_layer(pTHX_ I32 n) void PerlIO_stdstreams(pTHX) { - dVAR; if (!PL_perlio) { PerlIO_init_table(aTHX); PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT); @@ -1267,7 +1120,7 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) VERIFY_HEAD(f); if (tab->fsize != sizeof(PerlIO_funcs)) { Perl_croak( aTHX_ - "%s (%"UVuf") does not match %s (%"UVuf")", + "%s (%" UVuf ") does not match %s (%" UVuf ")", "PerlIO layer function table size", (UV)tab->fsize, "size expected by this perl", (UV)sizeof(PerlIO_funcs) ); } @@ -1275,7 +1128,7 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) PerlIOl *l; if (tab->size < sizeof(PerlIOl)) { Perl_croak( aTHX_ - "%s (%"UVuf") smaller than %s (%"UVuf")", + "%s (%" UVuf ") smaller than %s (%" UVuf ")", "PerlIO layer instance size", (UV)tab->size, "size expected by this perl", (UV)sizeof(PerlIOl) ); } @@ -1289,9 +1142,9 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) l->tab = (PerlIO_funcs*) tab; l->head = ((PerlIOl*)f)->head; *f = l; - PerlIO_debug("PerlIO_push f=%p %s %s %p\n", - (void*)f, tab->name, - (mode) ? mode : "(Null)", (void*)arg); + DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", + (void*)f, tab->name, + (mode) ? mode : "(Null)", (void*)arg) ); if (*l->tab->Pushed && (*l->tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { @@ -1305,8 +1158,8 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) } else if (f) { /* Pseudo-layer where push does its own stack adjust */ - PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, - (mode) ? mode : "(Null)", (void*)arg); + DEBUG_i( PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, + (mode) ? mode : "(Null)", (void*)arg) ); if (tab->Pushed && (*tab->Pushed) (aTHX_ f, mode, arg, (PerlIO_funcs*) tab) != 0) { return NULL; @@ -1385,8 +1238,8 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) } } if (PerlIOValid(f)) { - PerlIO_debug(":raw f=%p :%s\n", (void*)f, - PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)"); + DEBUG_i( PerlIO_debug(":raw f=%p :%s\n", (void*)f, + PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)") ); return 0; } } @@ -1438,10 +1291,14 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) int PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) { - PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f, - (PerlIOBase(f) && PerlIOBase(f)->tab) ? - PerlIOBase(f)->tab->name : "(Null)", - iotype, mode, (names) ? names : "(Null)"); + PERL_UNUSED_ARG(iotype); + PERL_UNUSED_ARG(mode); + + DEBUG_i( + PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f, + (PerlIOBase(f) && PerlIOBase(f)->tab) ? + PerlIOBase(f)->tab->name : "(Null)", + iotype, mode, (names) ? names : "(Null)") ); if (names) { /* Do not flush etc. if (e.g.) switching encodings. @@ -1449,7 +1306,7 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) (for example :unix which is never going to call them) it can do the flush when it is pushed. */ - return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE; + return cBOOL(PerlIO_apply_layers(aTHX_ f, NULL, names) == 0); } else { /* Fake 5.6 legacy of using this call to turn ON O_TEXT */ @@ -1490,7 +1347,7 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) /* Legacy binmode is now _defined_ as being equivalent to pushing :raw So code that used to be here is now in PerlIORaw_pushed(). */ - return PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL) ? TRUE : FALSE; + return cBOOL(PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_raw), NULL, NULL)); } } @@ -1526,15 +1383,13 @@ Perl_PerlIO_close(pTHX_ PerlIO *f) int Perl_PerlIO_fileno(pTHX_ PerlIO *f) { - dVAR; - Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f)); + Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f)); } static PerlIO_funcs * PerlIO_layer_from_ref(pTHX_ SV *sv) { - dVAR; /* * For any scalar type load the handler which is bundled with perl */ @@ -1543,6 +1398,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; } @@ -1568,7 +1424,6 @@ PerlIO_list_t * PerlIO_resolve_layers(pTHX_ const char *layers, const char *mode, int narg, SV **args) { - dVAR; PerlIO_list_t *def = PerlIO_default_layers(aTHX); int incdef = 1; if (!PL_perlio) @@ -1579,7 +1434,7 @@ PerlIO_resolve_layers(pTHX_ const char *layers, * If it is a reference but not an object see if we have a handler * for it */ - if (SvROK(arg) && !sv_isobject(arg)) { + if (SvROK(arg) && !SvOBJECT(SvRV(arg))) { PerlIO_funcs * const handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg)); if (handler) { def = PerlIO_list_alloc(aTHX); @@ -1622,7 +1477,6 @@ PerlIO * PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { - dVAR; if (!f && narg == 1 && *args == &PL_sv_undef) { if ((f = PerlIO_tmpfile())) { if (!layers || !*layers) @@ -1677,9 +1531,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, if (narg > 1 && !(tab->kind & PERLIO_K_MULTIARG)) { Perl_croak(aTHX_ "More than one argument to open(,':%s')",tab->name); } - PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", - tab->name, layers ? layers : "(Null)", mode, fd, - imode, perm, (void*)f, narg, (void*)args); + DEBUG_i( PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", + tab->name, layers ? layers : "(Null)", mode, fd, + imode, perm, (void*)f, narg, (void*)args) ); if (tab->Open) f = (*tab->Open) (aTHX_ tab, layera, n, mode, fd, imode, perm, f, narg, args); @@ -1746,7 +1600,6 @@ Perl_PerlIO_tell(pTHX_ PerlIO *f) int Perl_PerlIO_flush(pTHX_ PerlIO *f) { - dVAR; if (f) { if (*f) { const PerlIO_funcs *tab = PerlIOBase(f)->tab; @@ -1757,7 +1610,7 @@ Perl_PerlIO_flush(pTHX_ PerlIO *f) return 0; /* If no Flush defined, silently succeed. */ } else { - PerlIO_debug("Cannot flush f=%p\n", (void*)f); + DEBUG_i( PerlIO_debug("Cannot flush f=%p\n", (void*)f) ); SETERRNO(EBADF, SS_IVCHAN); return -1; } @@ -1789,7 +1642,6 @@ Perl_PerlIO_flush(pTHX_ PerlIO *f) void PerlIOBase_flush_linebuf(pTHX) { - dVAR; PerlIOl **table = &PL_perlio; PerlIOl *f; while ((f = *table)) { @@ -1907,9 +1759,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)); } @@ -1919,20 +1772,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)); } @@ -1963,7 +1816,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 +1847,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, @@ -2124,6 +1977,37 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) SETERRNO(EINVAL, LIB_INVARG); return -1; } +#ifdef EBCDIC + { + /* The mode variable contains one positional parameter followed by + * optional keyword parameters. The positional parameters must be + * passed as lowercase characters. The keyword parameters can be + * passed in mixed case. They must be separated by commas. Only one + * instance of a keyword can be specified. */ + int comma = 0; + while (*mode) { + switch (*mode++) { + case '+': + if(!comma) + l->flags |= PERLIO_F_CANREAD | PERLIO_F_CANWRITE; + break; + case 'b': + if(!comma) + l->flags &= ~PERLIO_F_CRLF; + break; + case 't': + if(!comma) + l->flags |= PERLIO_F_CRLF; + break; + case ',': + comma = 1; + break; + default: + break; + } + } + } +#else while (*mode) { switch (*mode++) { case '+': @@ -2140,6 +2024,7 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) return -1; } } +#endif } else { if (l->next) { @@ -2149,9 +2034,11 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) } } #if 0 + DEBUG_i( PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n", (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", l->flags, PerlIO_modestr(f, temp)); + ); #endif return 0; } @@ -2184,6 +2071,7 @@ PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) { PerlIOBase(f)->flags |= PERLIO_F_ERROR; SETERRNO(EBADF, SS_IVCHAN); + PerlIO_save_errno(f); return 0; } while (count > 0) { @@ -2192,7 +2080,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); @@ -2303,7 +2191,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); @@ -2333,13 +2221,14 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) PerlIO_funcs * const self = PerlIOBase(o)->tab; SV *arg = NULL; char buf[8]; - PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", - self ? self->name : "(Null)", - (void*)f, (void*)o, (void*)param); - if (self && self->Getarg) - arg = (*self->Getarg)(aTHX_ o, param, flags); + assert(self); + DEBUG_i(PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", + self->name, + (void*)f, (void*)o, (void*)param) ); + if (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,14 +2239,20 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) /* Must be called with PL_perlio_mutex locked. */ static void -S_more_refcounted_fds(pTHX_ const int new_fd) { +S_more_refcounted_fds(pTHX_ const int new_fd) + PERL_TSA_REQUIRES(PL_perlio_mutex) +{ dVAR; const int old_max = PL_perlio_fd_refcnt_size; const int new_max = 16 + (new_fd & ~15); int *new_array; - PerlIO_debug("More fds - old=%d, need %d, new=%d\n", - old_max, new_fd, new_max); +#ifndef PERL_IMPLICIT_SYS + PERL_UNUSED_CONTEXT; +#endif + + DEBUG_i( PerlIO_debug("More fds - old=%d, need %d, new=%d\n", + old_max, new_fd, new_max) ); if (new_fd < old_max) { return; @@ -2370,21 +2265,16 @@ S_more_refcounted_fds(pTHX_ const int new_fd) { new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int)); if (!new_array) { -#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; PL_perlio_fd_refcnt = new_array; - PerlIO_debug("Zeroing %p, %d\n", - (void*)(new_array + old_max), - new_max - old_max); + DEBUG_i( PerlIO_debug("Zeroing %p, %d\n", + (void*)(new_array + old_max), + new_max - old_max) ); Zero(new_array + old_max, new_max - old_max, int); } @@ -2404,9 +2294,7 @@ PerlIOUnix_refcnt_inc(int fd) if (fd >= 0) { dVAR; -#ifdef USE_ITHREADS MUTEX_LOCK(&PL_perlio_mutex); -#endif if (fd >= PL_perlio_fd_refcnt_size) S_more_refcounted_fds(aTHX_ fd); @@ -2416,12 +2304,10 @@ PerlIOUnix_refcnt_inc(int fd) Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n", fd, PL_perlio_fd_refcnt[fd]); } - PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n", - fd, PL_perlio_fd_refcnt[fd]); + DEBUG_i( PerlIO_debug("refcnt_inc: fd %d refcnt=%d\n", + fd, PL_perlio_fd_refcnt[fd]) ); -#ifdef USE_ITHREADS 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); @@ -2431,31 +2317,30 @@ PerlIOUnix_refcnt_inc(int fd) int PerlIOUnix_refcnt_dec(int fd) { - dTHX; int cnt = 0; if (fd >= 0) { +#ifdef DEBUGGING + dTHX; +#else dVAR; -#ifdef USE_ITHREADS - MUTEX_LOCK(&PL_perlio_mutex); #endif + MUTEX_LOCK(&PL_perlio_mutex); 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]; - PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt); -#ifdef USE_ITHREADS + DEBUG_i( PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt) ); 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); + Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd); } return cnt; } @@ -2467,9 +2352,7 @@ PerlIOUnix_refcnt(int fd) int cnt = 0; if (fd >= 0) { dVAR; -#ifdef USE_ITHREADS MUTEX_LOCK(&PL_perlio_mutex); -#endif if (fd >= PL_perlio_fd_refcnt_size) { /* diag_listed_as: refcnt: fd %d%s */ Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n", @@ -2481,9 +2364,7 @@ PerlIOUnix_refcnt(int fd) fd, PL_perlio_fd_refcnt[fd]); } cnt = PL_perlio_fd_refcnt[fd]; -#ifdef USE_ITHREADS MUTEX_UNLOCK(&PL_perlio_mutex); -#endif } else { /* diag_listed_as: refcnt: fd %d%s */ Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd); @@ -2494,12 +2375,11 @@ PerlIOUnix_refcnt(int fd) void PerlIO_cleanup(pTHX) { - dVAR; int i; #ifdef USE_ITHREADS - PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX); + DEBUG_i( PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX) ); #else - PerlIO_debug("Cleanup layers\n"); + DEBUG_i( PerlIO_debug("Cleanup layers\n") ); #endif /* Raise STDIN..STDERR refcount so we don't close them */ @@ -2574,6 +2454,9 @@ typedef struct { static void S_lockcnt_dec(pTHX_ const void* f) { +#ifndef PERL_IMPLICIT_SYS + PERL_UNUSED_CONTEXT; +#endif PerlIO_lockcnt((PerlIO*)f)--; } @@ -2587,8 +2470,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 @@ -2600,6 +2485,7 @@ S_perlio_async_run(pTHX_ PerlIO* f) { *f = l->next; Safefree(l); } + LEAVE; return 1; } @@ -2638,20 +2524,42 @@ PerlIOUnix_oflags(const char *mode) oflags |= O_WRONLY; break; } - if (*mode == 'b') { - oflags |= O_BINARY; + + /* XXX TODO: PerlIO_open() test that exercises 'rb' and 'rt'. */ + + /* Unless O_BINARY is different from O_TEXT, first bit-or:ing one + * of them in, and then bit-and-masking the other them away, won't + * have much of an effect. */ + switch (*mode) { + case 'b': +#if O_TEXT != O_BINARY + oflags |= O_BINARY; oflags &= ~O_TEXT; - mode++; - } - else if (*mode == 't') { +#endif + mode++; + break; + case 't': +#if O_TEXT != O_BINARY oflags |= O_TEXT; oflags &= ~O_BINARY; - mode++; +#endif + mode++; + break; + default: +# if O_BINARY != 0 + /* bit-or:ing with zero O_BINARY would be useless. */ + /* + * If neither "t" nor "b" was specified, open the file + * in O_BINARY mode. + * + * Note that if something else than the zero byte was seen + * here (e.g. bogus mode "rx"), just few lines later we will + * set the errno and invalidate the flags. + */ + oflags |= O_BINARY; +# endif + break; } - /* - * Always open in binary mode - */ - oflags |= O_BINARY; if (*mode || oflags == -1) { SETERRNO(EINVAL, LIB_INVARG); oflags = -1; @@ -2674,11 +2582,11 @@ PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode) Stat_t st; if (PerlLIO_fstat(fd, &st) == 0) { if (!S_ISREG(st.st_mode)) { - PerlIO_debug("%d is not regular file\n",fd); + DEBUG_i( PerlIO_debug("%d is not regular file\n",fd) ); PerlIOBase(f)->flags |= PERLIO_F_NOTREG; } else { - PerlIO_debug("%d _is_ a regular file\n",fd); + DEBUG_i( PerlIO_debug("%d _is_ a regular file\n",fd) ); } } #endif @@ -2734,6 +2642,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { + bool known_cloexec = 0; if (PerlIOValid(f)) { if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN) (*PerlIOBase(f)->tab->Close)(aTHX_ f); @@ -2750,11 +2659,19 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, #endif } if (imode != -1) { - const char *path = SvPV_nolen_const(*args); - fd = PerlLIO_open3(path, imode, perm); + STRLEN len; + const char *path = SvPV_const(*args, len); + if (!IS_SAFE_PATHNAME(path, len, "open")) + return NULL; + fd = PerlLIO_open3_cloexec(path, imode, perm); + known_cloexec = 1; } } if (fd >= 0) { + if (known_cloexec) + setfd_inhexec_for_sysfd(fd); + else + setfd_cloexec_or_inhexec_by_sysfdness(fd); if (*mode == IoTYPE_IMPLICIT) mode++; if (!f) { @@ -2762,6 +2679,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, } if (!PerlIOValid(f)) { if (!(f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { + PerlLIO_close(fd); return NULL; } } @@ -2788,7 +2706,9 @@ PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) const PerlIOUnix * const os = PerlIOSelf(o, PerlIOUnix); int fd = os->fd; if (flags & PERLIO_DUP_FD) { - fd = PerlLIO_dup(fd); + fd = PerlLIO_dup_cloexec(fd); + if (fd >= 0) + setfd_inhexec_for_sysfd(fd); } if (fd >= 0) { f = PerlIOBase_dup(aTHX_ f, o, param, flags); @@ -2797,6 +2717,7 @@ PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) PerlIOUnix_setfd(aTHX_ f, fd, os->oflags); return f; } + PerlLIO_close(fd); } return NULL; } @@ -2805,7 +2726,6 @@ PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) SSize_t PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { - dVAR; int fd; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ return -1; @@ -2824,6 +2744,7 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) if (len < 0) { if (errno != EAGAIN) { PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); } } else if (len == 0 && count != 0) { @@ -2836,13 +2757,12 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) return -1; } - /*NOTREACHED*/ + NOT_REACHED; /*NOTREACHED*/ } SSize_t PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { - dVAR; int fd; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ return -1; @@ -2857,6 +2777,7 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) if (len < 0) { if (errno != EAGAIN) { PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); } } return len; @@ -2865,7 +2786,7 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) return -1; } - /*NOTREACHED*/ + NOT_REACHED; /*NOTREACHED*/ } Off_t @@ -2880,7 +2801,6 @@ PerlIOUnix_tell(pTHX_ PerlIO *f) IV PerlIOUnix_close(pTHX_ PerlIO *f) { - dVAR; const int fd = PerlIOSelf(f, PerlIOUnix)->fd; int code = 0; if (PerlIOBase(f)->flags & PERLIO_F_OPEN) { @@ -3006,6 +2926,7 @@ PerlIOStdio_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab PerlIOSelf(f, PerlIOStdio)->stdio = stdio; /* We never call down so do any pending stuff now */ PerlIO_flush(PerlIONext(f)); + return PerlIOBase_pushed(aTHX_ f, mode, arg, tab); } else { return -1; @@ -3021,8 +2942,28 @@ PerlIO_importFILE(FILE *stdio, const char *mode) { dTHX; PerlIO *f = NULL; +#ifdef EBCDIC + int rc; + char filename[FILENAME_MAX]; + fldata_t fileinfo; +#endif if (stdio) { PerlIOStdio *s; + int fd0 = fileno(stdio); + if (fd0 < 0) { +#ifdef EBCDIC + rc = fldata(stdio,filename,&fileinfo); + if(rc != 0){ + return NULL; + } + if(fileinfo.__dsorgHFS){ + return NULL; + } + /*This MVS dataset , OK!*/ +#else + return NULL; +#endif + } if (!mode || !*mode) { /* We need to probe to see how we can open the stream so start with read/write and then try write and read @@ -3031,8 +2972,12 @@ PerlIO_importFILE(FILE *stdio, const char *mode) Note that the errno value set by a failing fdopen varies between stdio implementations. */ - const int fd = PerlLIO_dup(fileno(stdio)); - FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+")); + const int fd = PerlLIO_dup_cloexec(fd0); + FILE *f2; + if (fd < 0) { + return f; + } + f2 = PerlSIO_fdopen(fd, (mode = "r+")); if (!f2) { f2 = PerlSIO_fdopen(fd, (mode = "w")); } @@ -3046,10 +2991,26 @@ PerlIO_importFILE(FILE *stdio, const char *mode) } fclose(f2); } - if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) { + if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) { s = PerlIOSelf(f, PerlIOStdio); s->stdio = stdio; - PerlIOUnix_refcnt_inc(fileno(stdio)); + fd0 = fileno(stdio); + if(fd0 != -1){ + PerlIOUnix_refcnt_inc(fd0); + setfd_cloexec_or_inhexec_by_sysfdness(fd0); + } +#ifdef EBCDIC + else{ + rc = fldata(stdio,filename,&fileinfo); + if(rc != 0){ + PerlIOUnix_refcnt_inc(fd0); + } + if(fileinfo.__dsorgHFS){ + PerlIOUnix_refcnt_inc(fd0); + } + /*This MVS dataset , OK!*/ + } +#endif } } return f; @@ -3062,24 +3023,32 @@ 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); + stdio = PerlSIO_freopen(path, PerlIOStdio_mode(mode, tmode), + s->stdio); if (!s->stdio) return NULL; s->stdio = stdio; - PerlIOUnix_refcnt_inc(fileno(s->stdio)); + fd = fileno(stdio); + PerlIOUnix_refcnt_inc(fd); + setfd_cloexec_or_inhexec_by_sysfdness(fd); return f; } 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); + fd = PerlLIO_open3_cloexec(path, imode, perm); } else { FILE *stdio; @@ -3099,7 +3068,9 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg); if (f) { PerlIOSelf(f, PerlIOStdio)->stdio = stdio; - PerlIOUnix_refcnt_inc(fileno(stdio)); + fd = fileno(stdio); + PerlIOUnix_refcnt_inc(fd); + setfd_cloexec_or_inhexec_by_sysfdness(fd); } else { PerlSIO_fclose(stdio); } @@ -3140,10 +3111,13 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, } if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { PerlIOSelf(f, PerlIOStdio)->stdio = stdio; - PerlIOUnix_refcnt_inc(fileno(stdio)); + fd = fileno(stdio); + PerlIOUnix_refcnt_inc(fd); + setfd_cloexec_or_inhexec_by_sysfdness(fd); } return f; } + PerlLIO_close(fd); } } return NULL; @@ -3160,7 +3134,7 @@ PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) const int fd = fileno(stdio); char mode[8]; if (flags & PERLIO_DUP_FD) { - const int dfd = PerlLIO_dup(fileno(stdio)); + const int dfd = PerlLIO_dup_cloexec(fileno(stdio)); if (dfd >= 0) { stdio = PerlSIO_fdopen(dfd, PerlIO_modestr(o,mode)); goto set_this; @@ -3176,7 +3150,9 @@ PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) set_this: PerlIOSelf(f, PerlIOStdio)->stdio = stdio; if(stdio) { - PerlIOUnix_refcnt_inc(fileno(stdio)); + int fd = fileno(stdio); + PerlIOUnix_refcnt_inc(fd); + setfd_cloexec_or_inhexec_by_sysfdness(fd); } } return f; @@ -3190,7 +3166,9 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) /* XXX this could use PerlIO_canset_fileno() and * PerlIO_set_fileno() support from Configure */ -# if defined(__UCLIBC__) +# if defined(HAS_FDCLOSE) + return fdclose(f, NULL) == 0 ? 1 : 0; +# elif defined(__UCLIBC__) /* uClibc must come before glibc because it defines __GLIBC__ as well. */ f->__filedes = -1; return 1; @@ -3200,7 +3178,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) @@ -3241,14 +3219,12 @@ 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 */ # else - f->_file = -1; + PERLIO_FILE_file(f) = -1; # endif return 1; # else @@ -3305,6 +3281,26 @@ PerlIOStdio_close(pTHX_ PerlIO *f) return 0; if (stdio == stdout || stdio == stderr) return PerlIO_flush(f); + } + MUTEX_LOCK(&PL_perlio_mutex); + /* Right. We need a mutex here because for a brief while we + will have the situation that fd is actually closed. Hence if + a second thread were to get into this block, its dup() would + likely return our fd as its dupfd. (after all, it is closed) + Then if we get to the dup2() first, we blat the fd back + (messing up its temporary as a side effect) only for it to + then close its dupfd (== our fd) in its close(dupfd) */ + + /* There is, of course, a race condition, that any other thread + trying to input/output/whatever on this fd will be stuffed + for the duration of this little manoeuvrer. Perhaps we + should hold an IO mutex for the duration of every IO + operation if we know that invalidate doesn't work on this + platform, but that would suck, and could kill performance. + + Except that correctness trumps speed. + Advice from klortho #11912. */ + if (invalidate) { /* Tricky - must fclose(stdio) to free memory but not close(fd) Use Sarathy's trick from maint-5.6 to invalidate the fileno slot of the FILE * @@ -3313,30 +3309,9 @@ PerlIOStdio_close(pTHX_ PerlIO *f) SAVE_ERRNO; invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio); if (!invalidate) { -#ifdef USE_ITHREADS - MUTEX_LOCK(&PL_perlio_mutex); - /* Right. We need a mutex here because for a brief while we - will have the situation that fd is actually closed. Hence if - a second thread were to get into this block, its dup() would - likely return our fd as its dupfd. (after all, it is closed) - Then if we get to the dup2() first, we blat the fd back - (messing up its temporary as a side effect) only for it to - then close its dupfd (== our fd) in its close(dupfd) */ - - /* There is, of course, a race condition, that any other thread - trying to input/output/whatever on this fd will be stuffed - for the duration of this little manoeuvrer. Perhaps we - should hold an IO mutex for the duration of every IO - operation if we know that invalidate doesn't work on this - platform, but that would suck, and could kill performance. - - Except that correctness trumps speed. - Advice from klortho #11912. */ -#endif - dupfd = PerlLIO_dup(fd); + dupfd = PerlLIO_dup_cloexec(fd); #ifdef USE_ITHREADS if (dupfd < 0) { - MUTEX_UNLOCK(&PL_perlio_mutex); /* Oh cXap. This isn't going to go well. Not sure if we can recover from here, or if closing this particular FILE * is a good idea now. */ @@ -3359,12 +3334,11 @@ PerlIOStdio_close(pTHX_ PerlIO *f) result = close(fd); #endif if (dupfd >= 0) { - PerlLIO_dup2(dupfd,fd); + PerlLIO_dup2_cloexec(dupfd, fd); + setfd_inhexec_for_sysfd(fd); PerlLIO_close(dupfd); -#ifdef USE_ITHREADS - MUTEX_UNLOCK(&PL_perlio_mutex); -#endif } + MUTEX_UNLOCK(&PL_perlio_mutex); return result; } } @@ -3372,7 +3346,6 @@ PerlIOStdio_close(pTHX_ PerlIO *f) SSize_t PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { - dVAR; FILE * s; SSize_t got = 0; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ @@ -3401,6 +3374,12 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) return -1; SETERRNO(0,0); /* just in case */ } +#ifdef __sgi + /* Under some circumstances IRIX stdio fgetc() and fread() + * set the errno to ENOENT, which makes no sense according + * to either IRIX or POSIX. [rt.perl.org #123977] */ + if (errno == ENOENT) SETERRNO(0,0); +#endif return got; } @@ -3447,8 +3426,8 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) } if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) { /* Did not change pointer as expected */ - fgetc(s); /* get char back again */ - break; + if (fgetc(s) != EOF) /* get char back again */ + break; } /* It worked ! */ count--; @@ -3465,7 +3444,6 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) SSize_t PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { - dVAR; SSize_t got; if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ return -1; @@ -3569,6 +3547,7 @@ STDCHAR * PerlIOStdio_get_base(pTHX_ PerlIO *f) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; + PERL_UNUSED_CONTEXT; return (STDCHAR*)PerlSIO_get_base(stdio); } @@ -3576,6 +3555,7 @@ Size_t PerlIOStdio_get_bufsiz(pTHX_ PerlIO *f) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; + PERL_UNUSED_CONTEXT; return PerlSIO_get_bufsiz(stdio); } #endif @@ -3585,6 +3565,7 @@ STDCHAR * PerlIOStdio_get_ptr(pTHX_ PerlIO *f) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; + PERL_UNUSED_CONTEXT; return (STDCHAR*)PerlSIO_get_ptr(stdio); } @@ -3592,6 +3573,7 @@ SSize_t PerlIOStdio_get_cnt(pTHX_ PerlIO *f) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; + PERL_UNUSED_CONTEXT; return PerlSIO_get_cnt(stdio); } @@ -3599,9 +3581,23 @@ void PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; + PERL_UNUSED_CONTEXT; if (ptr != NULL) { #ifdef STDIO_PTR_LVALUE + /* This is a long-standing infamous mess. The root of the + * problem is that one cannot know the signedness of char, and + * more precisely the signedness of FILE._ptr. The following + * things have been tried, and they have all failed (across + * different compilers (remember that core needs to to build + * also with c++) and compiler options: + * + * - casting the RHS to (void*) -- works in *some* places + * - casting the LHS to (void*) -- totally unportable + * + * So let's try silencing the warning at least for gcc. */ + GCC_DIAG_IGNORE_STMT(-Wpointer-sign); PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */ + GCC_DIAG_RESTORE_STMT; #ifdef STDIO_PTR_LVAL_SETS_CNT assert(PerlSIO_get_cnt(stdio) == (cnt)); #endif @@ -3620,14 +3616,12 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) */ #ifdef STDIO_CNT_LVALUE PerlSIO_set_cnt(stdio, cnt); -#else /* STDIO_CNT_LVALUE */ -#if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT)) +#elif (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT)) PerlSIO_set_ptr(stdio, PerlSIO_get_ptr(stdio) + (PerlSIO_get_cnt(stdio) - cnt)); #else /* STDIO_PTR_LVAL_SETS_CNT */ PerlProc_abort(); -#endif /* STDIO_PTR_LVAL_SETS_CNT */ #endif /* STDIO_CNT_LVALUE */ } @@ -3690,20 +3684,12 @@ PerlIOStdio_fill(pTHX_ PerlIO *f) } #endif -#if defined(VMS) - /* An ungetc()d char is handled separately from the regular - * buffer, so we stuff it in the buffer ourselves. - * Should never get called as should hit code above - */ - *(--((*stdio)->_ptr)) = (unsigned char) c; - (*stdio)->_cnt++; -#else /* If buffer snoop scheme above fails fall back to using ungetc(). */ if (PerlSIO_ungetc(c, stdio) != c) return EOF; -#endif + return 0; } @@ -3764,6 +3750,10 @@ PerlIO_exportFILE(PerlIO * f, const char *mode) FILE *stdio = NULL; if (PerlIOValid(f)) { char buf[8]; + int fd = PerlIO_fileno(f); + if (fd < 0) { + return NULL; + } PerlIO_flush(f); if (!mode || !*mode) { mode = PerlIO_modestr(f, buf); @@ -3823,17 +3813,18 @@ PerlIO_findFILE(PerlIO *f) void PerlIO_releaseFILE(PerlIO *p, FILE *f) { - dVAR; PerlIOl *l; 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; } } @@ -3922,7 +3913,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. @@ -3970,6 +3960,7 @@ PerlIOBuf_flush(pTHX_ PerlIO *f) } else if (count < 0 || PerlIO_error(n)) { PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); code = -1; break; } @@ -4072,7 +4063,10 @@ PerlIOBuf_fill(pTHX_ PerlIO *f) if (avail == 0) PerlIOBase(f)->flags |= PERLIO_F_EOF; else + { PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); + } return -1; } b->end = b->buf + avail; @@ -4125,7 +4119,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 */ @@ -4175,7 +4169,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; @@ -4298,7 +4292,7 @@ PerlIOBuf_get_base(pTHX_ PerlIO *f) if (!b->buf) { if (!b->bufsiz) b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ; - Newxz(b->buf,b->bufsiz, STDCHAR); + Newx(b->buf,b->bufsiz, STDCHAR); if (!b->buf) { b->buf = (STDCHAR *) & b->oneword; b->bufsiz = sizeof(b->oneword); @@ -4450,7 +4444,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); @@ -4539,15 +4533,15 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PerlIOBase(f)->flags |= PERLIO_F_CRLF; code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab); #if 0 + DEBUG_i( PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n", (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)", 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); @@ -4570,7 +4564,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)) @@ -4593,14 +4587,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--; } @@ -4612,6 +4607,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; } } @@ -4625,15 +4622,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; } @@ -4673,7 +4670,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 */ /* @@ -4699,7 +4696,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--; } @@ -4717,7 +4714,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--; } @@ -4735,7 +4732,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++; } @@ -4770,8 +4767,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); @@ -4799,7 +4796,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); @@ -4850,301 +4847,9 @@ 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) { - dVAR; if (!PL_perlio) { PerlIO_stdstreams(aTHX); } @@ -5154,7 +4859,6 @@ Perl_PerlIO_stdin(pTHX) PerlIO * Perl_PerlIO_stdout(pTHX) { - dVAR; if (!PL_perlio) { PerlIO_stdstreams(aTHX); } @@ -5164,7 +4868,6 @@ Perl_PerlIO_stdout(pTHX) PerlIO * Perl_PerlIO_stderr(pTHX) { - dVAR; if (!PL_perlio) { PerlIO_stdstreams(aTHX); } @@ -5176,8 +4879,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; @@ -5193,7 +4896,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 } @@ -5295,6 +4998,7 @@ PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) va_list apc; Perl_va_copy(ap, apc); sv = vnewSVpvf(fmt, &apc); + va_end(apc); #else sv = vnewSVpvf(fmt, &ap); #endif @@ -5333,32 +5037,39 @@ PerlIO_stdoutf(const char *fmt, ...) PerlIO * PerlIO_tmpfile(void) { +#ifndef WIN32 dTHX; +#endif PerlIO *f = NULL; #ifdef WIN32 const int fd = win32_tmpfd(); if (fd >= 0) f = PerlIO_fdopen(fd, "w+b"); -#else /* WIN32 */ -# if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2) +#elif ! 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 - */ + int old_umask = umask(0177); if (tmpdir && *tmpdir) { /* if TMPDIR is set and not empty, we try that first */ sv = newSVpv(tmpdir, 0); sv_catpv(sv, tempname + 4); - fd = mkstemp(SvPVX(sv)); + fd = Perl_my_mkstemp_cloexec(SvPVX(sv)); } if (fd < 0) { + SvREFCNT_dec(sv); sv = NULL; /* else we try /tmp */ - fd = mkstemp(tempname); + fd = Perl_my_mkstemp_cloexec(tempname); + } + if (fd < 0) { + /* Try cwd */ + sv = newSVpvs("."); + sv_catpv(sv, tempname + 4); + fd = Perl_my_mkstemp_cloexec(SvPVX(sv)); } + umask(old_umask); if (fd >= 0) { f = PerlIO_fdopen(fd, "w+"); if (f) @@ -5366,22 +5077,49 @@ PerlIO_tmpfile(void) PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname); } SvREFCNT_dec(sv); -# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */ +#else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */ FILE * const stdio = PerlSIO_tmpfile(); if (stdio) f = PerlIO_fdopen(fileno(stdio), "w+"); -# endif /* else HAS_MKSTEMP */ #endif /* else WIN32 */ return f; } +void +Perl_PerlIO_save_errno(pTHX_ PerlIO *f) +{ + PERL_UNUSED_CONTEXT; + if (!PerlIOValid(f)) + return; + PerlIOBase(f)->err = errno; +#ifdef VMS + PerlIOBase(f)->os_err = vaxc$errno; +#elif defined(OS2) + PerlIOBase(f)->os_err = Perl_rc; +#elif defined(WIN32) + PerlIOBase(f)->os_err = GetLastError(); +#endif +} + +void +Perl_PerlIO_restore_errno(pTHX_ PerlIO *f) +{ + PERL_UNUSED_CONTEXT; + if (!PerlIOValid(f)) + return; + SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err); +#ifdef OS2 + Perl_rc = PerlIOBase(f)->os_err); +#elif defined(WIN32) + SetLastError(PerlIOBase(f)->os_err); +#endif +} + #undef HAS_FSETPOS #undef HAS_FGETPOS -#endif /* USE_SFIO */ -#endif /* PERLIO_IS_STDIO */ /*======================================================================================*/ /* @@ -5391,7 +5129,6 @@ PerlIO_tmpfile(void) const char * Perl_PerlIO_context_layers(pTHX_ const char *mode) { - dVAR; const char *direction = NULL; SV *layers; /* @@ -5423,12 +5160,14 @@ Perl_PerlIO_context_layers(pTHX_ const char *mode) int PerlIO_setpos(PerlIO *f, SV *pos) { - dTHX; if (SvOK(pos)) { - STRLEN len; - const Off_t * const posn = (Off_t *) SvPV(pos, len); - if (f && len == sizeof(Off_t)) - return PerlIO_seek(f, *posn, SEEK_SET); + if (f) { + dTHX; + STRLEN len; + const Off_t * const posn = (Off_t *) SvPV(pos, len); + if(len == sizeof(Off_t)) + return PerlIO_seek(f, *posn, SEEK_SET); + } } SETERRNO(EINVAL, SS_IVCHAN); return -1; @@ -5438,15 +5177,16 @@ PerlIO_setpos(PerlIO *f, SV *pos) int PerlIO_setpos(PerlIO *f, SV *pos) { - dTHX; if (SvOK(pos)) { - STRLEN len; - Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len); - if (f && len == sizeof(Fpos_t)) { + if (f) { + dTHX; + STRLEN len; + Fpos_t * const fpos = (Fpos_t *) SvPV(pos, len); + if(len == sizeof(Fpos_t)) #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) - return fsetpos64(f, fpos); + return fsetpos64(f, fpos); #else - return fsetpos(f, fpos); + return fsetpos(f, fpos); #endif } } @@ -5483,62 +5223,22 @@ PerlIO_getpos(PerlIO *f, SV *pos) } #endif -#if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF) - -int -vprintf(char *pat, char *args) -{ - _doprnt(pat, args, stdout); - return 0; /* wrong, but perl doesn't use the return - * value */ -} - -int -vfprintf(FILE *fd, char *pat, char *args) -{ - _doprnt(pat, args, fd); - return 0; /* wrong, but perl doesn't use the return - * value */ -} - -#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 +/* print a failure format string message to stderr and fail exit the process + using only libc without depending on any perl data structures being + initialized. +*/ -#ifndef PerlIO_sprintf -int -PerlIO_sprintf(char *s, int n, const char *fmt, ...) +void +Perl_noperl_die(const char* pat, ...) { - va_list ap; - int result; - va_start(ap, fmt); - result = PerlIO_vsprintf(s, n, fmt, ap); - va_end(ap); - return result; + va_list(arglist); + PERL_ARGS_ASSERT_NOPERL_DIE; + va_start(arglist, pat); + vfprintf(stderr, pat, arglist); + va_end(arglist); + exit(1); } -#endif /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: t - * End: - * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */