X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ff25d7bcdd32f227c1d1926c13e0ca78af0e3c04..dda4a47798d6:/perlio.c diff --git a/perlio.c b/perlio.c index 20a347e..904d47a 100644 --- a/perlio.c +++ b/perlio.c @@ -49,11 +49,6 @@ #include "XSUB.h" -#ifdef __Lynx__ -/* Missing proto on LynxOS */ -int mkstemp(char*); -#endif - #ifdef VMS #include #endif @@ -243,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); @@ -268,10 +262,9 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) else { SETERRNO(EBADF, SS_IVCHAN); } -#endif +# endif return NULL; #endif -#endif } @@ -296,7 +289,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, 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); } @@ -350,21 +343,26 @@ PerlIO_debug(const char *fmt, ...) { va_list ap; dSYS; + + if (!DEBUG_i_TEST) + return; + va_start(ap, fmt); + if (!PL_perlio_debug_fd) { 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) { @@ -373,7 +371,19 @@ PerlIO_debug(const char *fmt, ...) /* 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)); +# ifdef USE_QUADMATH +# ifdef HAS_VSNPRINTF + /* my_vsnprintf() isn't available with quadmath, but the native vsnprintf() + should be, otherwise the system isn't likely to support quadmath. + Nothing should be calling PerlIO_debug() with floating point anyway. + */ + const STRLEN len2 = vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap); +# else + STATIC_ASSERT_STMT(0); +# endif +# else const STRLEN len2 = my_vsnprintf(buffer + len1, sizeof(buffer) - len1, fmt, ap); +# endif PERL_UNUSED_RESULT(PerlLIO_write(PL_perlio_debug_fd, buffer, len1 + len2)); #else const char *s = CopFILE(PL_curcop); @@ -477,7 +487,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 { @@ -542,11 +552,12 @@ PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) 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; @@ -586,7 +597,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++); @@ -610,7 +621,7 @@ PerlIO_destruct(pTHX) 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; @@ -620,7 +631,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); } @@ -639,8 +650,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 @@ -713,7 +724,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) PerlIO_funcs * const f = PL_known_layers->array[i].funcs; 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); + DEBUG_i( PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f) ); return f; } } @@ -741,7 +752,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; } @@ -843,9 +854,10 @@ XS(XS_PerlIO__Layer__NoWarnings) during loading of layers. */ 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); } @@ -853,7 +865,6 @@ XS(XS_PerlIO__Layer__find); /* prototype to pass -Wmissing-prototypes */ XS(XS_PerlIO__Layer__find) { dXSARGS; - PERL_UNUSED_ARG(cv); if (items < 2) Perl_croak(aTHX_ "Usage class->find(name[,load])"); else { @@ -874,7 +885,7 @@ PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) 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 @@ -928,9 +939,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), @@ -979,7 +988,7 @@ PerlIO_default_buffer(pTHX_ PerlIO_list_t *av) if (PerlIO_stdio.Set_ptrcnt) tab = &PerlIO_stdio; #endif - PerlIO_debug("Pushing %s\n", tab->name); + DEBUG_i( PerlIO_debug("Pushing %s\n", tab->name) ); PerlIO_list_push(aTHX_ av, (PerlIO_funcs *)tab, &PL_sv_undef); } @@ -993,8 +1002,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) @@ -1123,7 +1132,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) ); } @@ -1131,7 +1140,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) ); } @@ -1145,9 +1154,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) { @@ -1161,8 +1170,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; @@ -1241,8 +1250,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; } } @@ -1294,10 +1303,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. @@ -1305,7 +1318,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 */ @@ -1346,7 +1359,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)); } } @@ -1530,9 +1543,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); @@ -1609,7 +1622,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; } @@ -1976,6 +1989,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 '+': @@ -1992,6 +2036,7 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) return -1; } } +#endif } else { if (l->next) { @@ -2001,9 +2046,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; } @@ -2187,9 +2234,9 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) SV *arg = NULL; char buf[8]; assert(self); - PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", - self->name, - (void*)f, (void*)o, (void*)param); + 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); @@ -2216,8 +2263,8 @@ S_more_refcounted_fds(pTHX_ const int new_fd) PERL_UNUSED_CONTEXT; #endif - PerlIO_debug("More fds - old=%d, need %d, new=%d\n", - old_max, new_fd, new_max); + 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; @@ -2230,18 +2277,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 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); } @@ -2261,9 +2306,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); @@ -2273,12 +2316,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); @@ -2290,10 +2331,12 @@ PerlIOUnix_refcnt_dec(int fd) { 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_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n", @@ -2305,10 +2348,8 @@ PerlIOUnix_refcnt_dec(int fd) 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_nocontext("refcnt_dec: fd %d < 0\n", fd); @@ -2323,9 +2364,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", @@ -2337,9 +2376,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); @@ -2352,9 +2389,9 @@ PerlIO_cleanup(pTHX) { 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 */ @@ -2557,11 +2594,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 @@ -2617,6 +2654,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); @@ -2637,10 +2675,15 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, const char *path = SvPV_const(*args, len); if (!IS_SAFE_PATHNAME(path, len, "open")) return NULL; - fd = PerlLIO_open3(path, imode, perm); + 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) { @@ -2675,7 +2718,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); @@ -2939,7 +2984,7 @@ 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(fd0); + const int fd = PerlLIO_dup_cloexec(fd0); FILE *f2; if (fd < 0) { return f; @@ -2961,11 +3006,12 @@ PerlIO_importFILE(FILE *stdio, const char *mode) if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) { s = PerlIOSelf(f, PerlIOStdio); s->stdio = stdio; + fd0 = fileno(stdio); + if(fd0 != -1){ + PerlIOUnix_refcnt_inc(fd0); + setfd_cloexec_or_inhexec_by_sysfdness(fd0); + } #ifdef EBCDIC - fd0 = fileno(stdio); - if(fd0 != -1){ - PerlIOUnix_refcnt_inc(fd0); - } else{ rc = fldata(stdio,filename,&fileinfo); if(rc != 0){ @@ -2976,8 +3022,6 @@ PerlIO_importFILE(FILE *stdio, const char *mode) } /*This MVS dataset , OK!*/ } -#else - PerlIOUnix_refcnt_inc(fileno(stdio)); #endif } } @@ -3003,7 +3047,9 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, 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 { @@ -3014,7 +3060,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, return NULL; if (*mode == IoTYPE_NUMERIC) { mode++; - fd = PerlLIO_open3(path, imode, perm); + fd = PerlLIO_open3_cloexec(path, imode, perm); } else { FILE *stdio; @@ -3034,7 +3080,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); } @@ -3075,7 +3123,9 @@ 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; } @@ -3096,7 +3146,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; @@ -3112,7 +3162,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; @@ -3126,7 +3178,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; @@ -3182,7 +3236,7 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) structure at all */ # else - f->_file = -1; + PERLIO_FILE_file(f) = -1; # endif return 1; # else @@ -3239,6 +3293,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 * @@ -3247,30 +3321,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. */ @@ -3293,12 +3346,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; } } @@ -3507,6 +3559,7 @@ STDCHAR * PerlIOStdio_get_base(pTHX_ PerlIO *f) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; + PERL_UNUSED_CONTEXT; return (STDCHAR*)PerlSIO_get_base(stdio); } @@ -3514,6 +3567,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 @@ -3523,6 +3577,7 @@ STDCHAR * PerlIOStdio_get_ptr(pTHX_ PerlIO *f) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; + PERL_UNUSED_CONTEXT; return (STDCHAR*)PerlSIO_get_ptr(stdio); } @@ -3530,6 +3585,7 @@ SSize_t PerlIOStdio_get_cnt(pTHX_ PerlIO *f) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; + PERL_UNUSED_CONTEXT; return PerlSIO_get_cnt(stdio); } @@ -3537,6 +3593,7 @@ 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 @@ -3550,9 +3607,9 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) * - casting the LHS to (void*) -- totally unportable * * So let's try silencing the warning at least for gcc. */ - GCC_DIAG_IGNORE(-Wpointer-sign); + GCC_DIAG_IGNORE_STMT(-Wpointer-sign); PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */ - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; #ifdef STDIO_PTR_LVAL_SETS_CNT assert(PerlSIO_get_cnt(stdio) == (cnt)); #endif @@ -3571,14 +3628,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 */ } @@ -4249,7 +4304,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); @@ -4490,9 +4545,11 @@ 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 { /* If the old top layer is a CRLF layer, reactivate it (if @@ -4768,7 +4825,7 @@ PerlIOCrlf_binmode(pTHX_ PerlIO *f) PerlIO_pop(aTHX_ f); #endif } - return 0; + return PerlIOBase_binmode(aTHX_ f); } PERLIO_FUNCS_DECL(PerlIO_crlf) = { @@ -5000,33 +5057,29 @@ PerlIO_tmpfile(void) 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 = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR"); SV * sv = NULL; - int old_umask = umask(0600); - /* - * 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 = mkstemp(SvPVX(sv)); + fd = Perl_my_mkstemp_cloexec(SvPVX(sv)); } umask(old_umask); if (fd >= 0) { @@ -5036,13 +5089,12 @@ 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; } @@ -5050,6 +5102,7 @@ PerlIO_tmpfile(void) void Perl_PerlIO_save_errno(pTHX_ PerlIO *f) { + PERL_UNUSED_CONTEXT; if (!PerlIOValid(f)) return; PerlIOBase(f)->err = errno; @@ -5065,6 +5118,7 @@ Perl_PerlIO_save_errno(pTHX_ PerlIO *f) void Perl_PerlIO_restore_errno(pTHX_ PerlIO *f) { + PERL_UNUSED_CONTEXT; if (!PerlIOValid(f)) return; SETERRNO(PerlIOBase(f)->err, PerlIOBase(f)->os_err); @@ -5181,26 +5235,6 @@ PerlIO_getpos(PerlIO *f, SV *pos) } #endif -#if !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 - /* 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. @@ -5209,7 +5243,7 @@ vfprintf(FILE *fd, char *pat, char *args) void Perl_noperl_die(const char* pat, ...) { - va_list(arglist); + va_list arglist; PERL_ARGS_ASSERT_NOPERL_DIE; va_start(arglist, pat); vfprintf(stderr, pat, arglist);