X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/20b7effb9761caf5aee8475b6a6d731b40c80cd7..dd8dc88c6c318c49836493d65c4faf0e5ede57b2:/perlio.c diff --git a/perlio.c b/perlio.c index 6c742d2..d6cd41e 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 @@ -241,24 +236,23 @@ PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) PerlIO * PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) { -#if defined(PERL_MICRO) || defined(__SYMBIAN32__) +#if defined(PERL_MICRO) 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); } @@ -338,29 +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 */ - /*======================================================================================*/ /* * Implement all the PerlIO interface ourselves. @@ -373,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) { @@ -396,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,10 +464,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; } } } @@ -489,6 +473,8 @@ PerlIO_allocate(pTHX) return NULL; } *last = (PerlIOl*) f++; + + good_exit: f->flags = 0; /* lockcnt */ f->tab = NULL; f->head = f; @@ -501,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 { @@ -566,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; @@ -610,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++); @@ -634,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; @@ -644,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); } @@ -663,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 @@ -737,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; } } @@ -765,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; } @@ -850,7 +837,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) @@ -867,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); } @@ -877,13 +865,12 @@ 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 { 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)) : @@ -898,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 @@ -952,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), @@ -1003,9 +988,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 * @@ -1018,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) @@ -1093,9 +1077,8 @@ PerlIO_default_layers(pTHX) 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); } @@ -1149,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) ); } @@ -1157,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) ); } @@ -1171,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) { @@ -1187,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; @@ -1267,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; } } @@ -1320,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. @@ -1331,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 */ @@ -1372,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)); } } @@ -1459,7 +1446,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); @@ -1503,7 +1490,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { if (!f && narg == 1 && *args == &PL_sv_undef) { - if ((f = PerlIO_tmpfile())) { + imode = PerlIOUnix_oflags(mode); + + if (imode != -1 && (f = PerlIO_tmpfile_flags(imode))) { if (!layers || !*layers) layers = Perl_PerlIO_context_layers(aTHX_ mode); if (layers && *layers) @@ -1556,9 +1545,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); @@ -1635,7 +1624,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; } @@ -2002,6 +1991,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 '+': @@ -2018,6 +2038,7 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) return -1; } } +#endif } else { if (l->next) { @@ -2027,9 +2048,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; } @@ -2062,6 +2085,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) { @@ -2212,11 +2236,11 @@ 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 ? self->name : "(Null)", - (void*)f, (void*)o, (void*)param); - if (self && self->Getarg) - arg = (*self->Getarg)(aTHX_ o, param, flags); + 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 (f && PerlIOBase(o)->flags & PERLIO_F_UTF8) PerlIOBase(f)->flags |= PERLIO_F_UTF8; @@ -2229,8 +2253,9 @@ 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) { - dVAR; +S_more_refcounted_fds(pTHX_ const int new_fd) + PERL_TSA_REQUIRES(PL_perlio_mutex) +{ const int old_max = PL_perlio_fd_refcnt_size; const int new_max = 16 + (new_fd & ~15); int *new_array; @@ -2239,8 +2264,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; @@ -2253,18 +2278,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); } @@ -2282,11 +2305,8 @@ PerlIOUnix_refcnt_inc(int fd) { dTHX; 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); @@ -2296,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); @@ -2313,10 +2331,11 @@ PerlIOUnix_refcnt_dec(int fd) { int cnt = 0; if (fd >= 0) { - dVAR; -#ifdef USE_ITHREADS - MUTEX_LOCK(&PL_perlio_mutex); +#ifdef DEBUGGING + dTHX; +#else #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", @@ -2328,10 +2347,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); @@ -2345,10 +2362,7 @@ PerlIOUnix_refcnt(int fd) dTHX; 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", @@ -2360,9 +2374,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); @@ -2375,9 +2387,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 */ @@ -2400,7 +2412,6 @@ PerlIO_cleanup(pTHX) void PerlIO_teardown(void) /* Call only from PERL_SYS_TERM(). */ { - dVAR; #if 0 /* XXX we can't rely on an interpreter being present at this late stage, XXX so we can't use a function like PerlLIO_write that relies on one @@ -2580,11 +2591,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 @@ -2640,6 +2651,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); @@ -2660,10 +2672,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) { @@ -2698,7 +2715,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); @@ -2720,10 +2739,6 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ return -1; fd = PerlIOSelf(f, PerlIOUnix)->fd; -#ifdef PERLIO_STD_SPECIAL - if (fd == 0) - return PERLIO_STD_IN(fd, vbuf, count); -#endif if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD) || PerlIOBase(f)->flags & (PERLIO_F_EOF|PERLIO_F_ERROR)) { return 0; @@ -2734,6 +2749,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) { @@ -2746,7 +2762,7 @@ 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 @@ -2756,16 +2772,13 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ return -1; fd = PerlIOSelf(f, PerlIOUnix)->fd; -#ifdef PERLIO_STD_SPECIAL - if (fd == 1 || fd == 2) - return PERLIO_STD_OUT(fd, vbuf, count); -#endif while (1) { const SSize_t len = PerlLIO_write(fd, vbuf, count); if (len >= 0 || errno != EINTR) { if (len < 0) { if (errno != EAGAIN) { PerlIOBase(f)->flags |= PERLIO_F_ERROR; + PerlIO_save_errno(f); } } return len; @@ -2774,7 +2787,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 @@ -2792,6 +2805,7 @@ PerlIOUnix_close(pTHX_ PerlIO *f) const int fd = PerlIOSelf(f, PerlIOUnix)->fd; int code = 0; if (PerlIOBase(f)->flags & PERLIO_F_OPEN) { + code = PerlIOBase_close(aTHX_ f); if (PerlIOUnix_refcnt_dec(fd) > 0) { PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; return 0; @@ -2930,12 +2944,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 @@ -2944,7 +2974,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; @@ -2966,7 +2996,23 @@ 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; - 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; @@ -2991,7 +3037,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 { @@ -3002,7 +3050,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; @@ -3022,7 +3070,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); } @@ -3063,7 +3113,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; } @@ -3084,7 +3136,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; @@ -3100,7 +3152,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; @@ -3114,7 +3168,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; @@ -3165,13 +3221,7 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) f->_file = -1; return 1; # elif defined(WIN32) -# if defined(UNDER_CE) - /* WIN_CE does not have access to FILE internals, it hardly has FILE - structure at all - */ -# else - f->_file = -1; -# endif + PERLIO_FILE_file(f) = -1; return 1; # else #if 0 @@ -3200,7 +3250,6 @@ PerlIOStdio_close(pTHX_ PerlIO *f) int dupfd = -1; dSAVEDERRNO; #ifdef USE_ITHREADS - dVAR; #endif #ifdef SOCKS5_VERSION_NAME /* Socks lib overrides close() but stdio isn't linked to @@ -3227,6 +3276,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 * @@ -3235,30 +3304,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. */ @@ -3281,12 +3329,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; } } @@ -3322,6 +3369,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; } @@ -3489,6 +3542,7 @@ STDCHAR * PerlIOStdio_get_base(pTHX_ PerlIO *f) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; + PERL_UNUSED_CONTEXT; return (STDCHAR*)PerlSIO_get_base(stdio); } @@ -3496,6 +3550,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 @@ -3505,6 +3560,7 @@ STDCHAR * PerlIOStdio_get_ptr(pTHX_ PerlIO *f) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; + PERL_UNUSED_CONTEXT; return (STDCHAR*)PerlSIO_get_ptr(stdio); } @@ -3512,6 +3568,7 @@ SSize_t PerlIOStdio_get_cnt(pTHX_ PerlIO *f) { FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; + PERL_UNUSED_CONTEXT; return PerlSIO_get_cnt(stdio); } @@ -3519,6 +3576,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 @@ -3532,9 +3590,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 @@ -3553,14 +3611,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 */ } @@ -3899,6 +3955,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; } @@ -4001,7 +4058,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; @@ -4227,7 +4287,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); @@ -4468,9 +4528,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 @@ -4746,7 +4808,7 @@ PerlIOCrlf_binmode(pTHX_ PerlIO *f) PerlIO_pop(aTHX_ f); #endif } - return 0; + return PerlIOBase_binmode(aTHX_ f); } PERLIO_FUNCS_DECL(PerlIO_crlf) = { @@ -4970,65 +5032,105 @@ PerlIO_stdoutf(const char *fmt, ...) PerlIO * PerlIO_tmpfile(void) { + return PerlIO_tmpfile_flags(0); +} + +#define MKOSTEMP_MODES ( O_RDWR | O_CREAT | O_EXCL ) +#define MKOSTEMP_MODE_MASK ( O_ACCMODE | O_CREAT | O_EXCL | O_TRUNC ) + +PerlIO * +PerlIO_tmpfile_flags(int imode) +{ #ifndef WIN32 dTHX; #endif PerlIO *f = NULL; #ifdef WIN32 - const int fd = win32_tmpfd(); + const int fd = win32_tmpfd_mode(imode); if (fd >= 0) f = PerlIO_fdopen(fd, "w+b"); -#else /* WIN32 */ -# if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2) +#elif ! 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); + imode &= ~MKOSTEMP_MODE_MASK; 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_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE); } if (fd < 0) { SvREFCNT_dec(sv); sv = NULL; /* else we try /tmp */ - fd = mkstemp(tempname); + fd = Perl_my_mkostemp_cloexec(tempname, imode | O_VMS_DELETEONCLOSE); } if (fd < 0) { /* Try cwd */ sv = newSVpvs("."); sv_catpv(sv, tempname + 4); - fd = mkstemp(SvPVX(sv)); + fd = Perl_my_mkostemp_cloexec(SvPVX(sv), imode | O_VMS_DELETEONCLOSE); } umask(old_umask); if (fd >= 0) { - f = PerlIO_fdopen(fd, "w+"); + /* fdopen() with a numeric mode */ + char mode[8]; + int writing = 1; + (void)PerlIO_intmode2str(imode | MKOSTEMP_MODES, mode, &writing); + f = PerlIO_fdopen(fd, mode); if (f) PerlIOBase(f)->flags |= PERLIO_F_TEMP; +# ifndef VMS PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname); +# endif } 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 /* PERLIO_IS_STDIO */ /*======================================================================================*/ /* @@ -5070,11 +5172,13 @@ int PerlIO_setpos(PerlIO *f, SV *pos) { if (SvOK(pos)) { - STRLEN len; - dTHX; - const Off_t * const posn = (Off_t *) SvPV(pos, len); - if (f && len == sizeof(Off_t)) - return PerlIO_seek(f, *posn, SEEK_SET); + 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; @@ -5084,15 +5188,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 } } @@ -5129,32 +5234,22 @@ 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 */ -} +/* 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. +*/ -int -vfprintf(FILE *fd, char *pat, char *args) +void +Perl_noperl_die(const char* pat, ...) { - _doprnt(pat, args, fd); - return 0; /* wrong, but perl doesn't use the return - * value */ + 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: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */