X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e80fed9da44c731a6f85b5544b737325bd9a41a7..eae48c8938e50ebb341a72c2886c5ae8587092a5:/perlio.c diff --git a/perlio.c b/perlio.c index cc82ffd..1440048 100644 --- a/perlio.c +++ b/perlio.c @@ -1,12 +1,17 @@ /* - * perlio.c Copyright (c) 1996-2006, Nick Ing-Simmons You may distribute - * under the terms of either the GNU General Public License or the - * Artistic License, as specified in the README file. + * perlio.c + * Copyright (c) 1996-2006, Nick Ing-Simmons + * Copyright (c) 2006, 2007, 2008 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. */ /* * Hour after hour for nearly three weary days he had jogged up and down, * over passes, and through long dales, and across many streams. + * + * [pp.791-792 of _The Lord of the Rings_, V/iii: "The Muster of Rohan"] */ /* This file contains the functions needed to implement PerlIO, which @@ -30,7 +35,11 @@ #ifdef PERL_MICRO # include "uconfig.h" #else -# include "config.h" +# ifndef USE_CROSS_COMPILE +# include "config.h" +# else +# include "xconfig.h" +# endif #endif #define PERLIO_NOT_STDIO 0 @@ -110,7 +119,15 @@ int mkstemp(char*); else \ SETERRNO(EBADF, SS_IVCHAN) +#if defined(__osf__) && _XOPEN_SOURCE < 500 +extern int fseeko(FILE *, off_t, int); +extern off_t ftello(FILE *); +#endif + #ifndef USE_SFIO + +EXTERN_C int perlsio_binmode(FILE *fp, int iotype, int mode); + int perlsio_binmode(FILE *fp, int iotype, int mode) { @@ -118,7 +135,8 @@ perlsio_binmode(FILE *fp, int iotype, int mode) * This used to be contents of do_binmode in doio.c */ #ifdef DOSISH -# if defined(atarist) || defined(__MINT__) +# if defined(atarist) + PERL_UNUSED_ARG(iotype); if (!fflush(fp)) { if (mode & O_BINARY) ((FILE *) fp)->_flag |= _IOBIN; @@ -129,6 +147,7 @@ perlsio_binmode(FILE *fp, int iotype, int mode) return 0; # else dTHX; + PERL_UNUSED_ARG(iotype); #ifdef NETWARE if (PerlLIO_setmode(fp, mode) != -1) { #else @@ -159,6 +178,9 @@ document #else # if defined(USEMYBINMODE) dTHX; +# if defined(__CYGWIN__) + PERL_UNUSED_ARG(iotype); +# endif if (my_binmode(fp, iotype, mode) != FALSE) return 1; else @@ -461,12 +483,19 @@ PerlIO_debug(const char *fmt, ...) va_list ap; dSYS; va_start(ap, fmt); - if (!PL_perlio_debug_fd && !PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) { - 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); - else + if (!PL_perlio_debug_fd) { + if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) { + 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); + else + PL_perlio_debug_fd = -1; + } else { + /* tainting or set*id, so ignore the environment, and ensure we + skip these tests next time through. */ PL_perlio_debug_fd = -1; + } } if (PL_perlio_debug_fd > 0) { dTHX; @@ -474,19 +503,14 @@ PerlIO_debug(const char *fmt, ...) const char * const s = CopFILE(PL_curcop); /* Use fixed buffer as sv_catpvf etc. needs SVs */ char buffer[1024]; - const STRLEN len = my_sprintf(buffer, "%.40s:%" IVdf " ", s ? s : "(none)", (IV) CopLINE(PL_curcop)); -# ifdef USE_VSNPRINTF - const STRLEN len2 = vnsprintf(buffer+len, sizeof(buffer) - len, fmt, ap); -# else - const STRLEN len2 = vsprintf(buffer+len, fmt, ap); -# endif /* USE_VSNPRINTF */ - PerlLIO_write(PL_perlio_debug_fd, buffer, len + len2); + 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); #else const char *s = CopFILE(PL_curcop); STRLEN len; - SV * const sv = newSVpvs(""); - Perl_sv_catpvf(aTHX_ sv, "%s:%" IVdf " ", s ? s : "(none)", - (IV) CopLINE(PL_curcop)); + SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" IVdf " ", s ? s : "(none)", + (IV) CopLINE(PL_curcop)); Perl_sv_vcatpvf(aTHX_ sv, fmt, &ap); s = SvPV_const(sv, len); @@ -590,10 +614,8 @@ PerlIO_list_free(pTHX_ PerlIO_list_t *list) if (--list->refcnt == 0) { if (list->array) { IV i; - for (i = 0; i < list->cur; i++) { - if (list->array[i].arg) - SvREFCNT_dec(list->array[i].arg); - } + for (i = 0; i < list->cur; i++) + SvREFCNT_dec(list->array[i].arg); Safefree(list->array); } Safefree(list); @@ -630,9 +652,13 @@ PerlIO_clone_list(pTHX_ PerlIO_list_t *proto, CLONE_PARAMS *param) int i; list = PerlIO_list_alloc(aTHX); for (i=0; i < proto->cur; i++) { - SV *arg = NULL; - if (proto->array[i].arg) - arg = PerlIO_sv_dup(aTHX_ proto->array[i].arg,param); + SV *arg = proto->array[i].arg; +#ifdef sv_dup + if (arg && param) + arg = sv_dup(arg, param); +#else + PERL_UNUSED_ARG(param); +#endif PerlIO_list_push(aTHX_ list, proto->array[i].funcs, arg); } } @@ -649,7 +675,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_allocate(aTHX); /* root slot is never used */ - PerlIO_debug("Clone %p from %p\n",aTHX,proto); + PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto); while ((f = *table)) { int i; table = (PerlIO **) (f++); @@ -661,6 +687,7 @@ PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) } } #else + PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(proto); PERL_UNUSED_ARG(param); #endif @@ -673,7 +700,7 @@ PerlIO_destruct(pTHX) PerlIO **table = &PL_perlio; PerlIO *f; #ifdef USE_ITHREADS - PerlIO_debug("Destruct %p\n",aTHX); + PerlIO_debug("Destruct %p\n",(void*)aTHX); #endif while ((f = *table)) { int i; @@ -732,6 +759,11 @@ PerlIO_get_layers(pTHX_ PerlIO *f) PerlIOl *l = PerlIOBase(f); while (l) { + /* There is some collusion in the implementation of + XS_PerlIO_get_layers - it knows that name and flags are + generated as fresh SVs here, and takes advantage of that to + "copy" them by taking a reference. If it changes here, it needs + to change there too. */ SV * const name = l->tab && l->tab->name ? newSVpv(l->tab->name, 0) : &PL_sv_undef; SV * const arg = l->tab && l->tab->Getarg ? @@ -773,19 +805,18 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) } else { SV * const pkgsv = newSVpvs("PerlIO"); SV * const layer = newSVpvn(name, len); - CV * const cv = get_cv("PerlIO::Layer::NoWarnings", FALSE); + CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0); ENTER; - SAVEINT(PL_in_load_module); + SAVEBOOL(PL_in_load_module); if (cv) { SAVEGENERICSV(PL_warnhook); - PL_warnhook = (SV *) (SvREFCNT_inc_simple_NN(cv)); + PL_warnhook = MUTABLE_SV((SvREFCNT_inc_simple_NN(cv))); } - PL_in_load_module++; + PL_in_load_module = TRUE; /* * The two SVs are magically freed by load_module */ Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL); - PL_in_load_module--; LEAVE; return PerlIO_find_layer(aTHX_ name, len, 0); } @@ -800,10 +831,11 @@ static int perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) { if (SvROK(sv)) { - IO * const io = GvIOn((GV *) SvRV(sv)); + IO * const io = GvIOn(MUTABLE_GV(SvRV(sv))); PerlIO * const ifp = IoIFP(io); PerlIO * const ofp = IoOFP(io); - Perl_warn(aTHX_ "set %" SVf " %p %p %p", sv, io, ifp, ofp); + Perl_warn(aTHX_ "set %" SVf " %p %p %p", + SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp); } return 0; } @@ -812,10 +844,11 @@ static int perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) { if (SvROK(sv)) { - IO * const io = GvIOn((GV *) SvRV(sv)); + IO * const io = GvIOn(MUTABLE_GV(SvRV(sv))); PerlIO * const ifp = IoIFP(io); PerlIO * const ofp = IoOFP(io); - Perl_warn(aTHX_ "get %" SVf " %p %p %p", sv, io, ifp, ofp); + Perl_warn(aTHX_ "get %" SVf " %p %p %p", + SVfARG(sv), (void*)io, (void*)ifp, (void*)ofp); } return 0; } @@ -823,14 +856,14 @@ perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) static int perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg) { - Perl_warn(aTHX_ "clear %" SVf, sv); + Perl_warn(aTHX_ "clear %" SVf, SVfARG(sv)); return 0; } static int perlio_mg_free(pTHX_ SV *sv, MAGIC *mg) { - Perl_warn(aTHX_ "free %" SVf, sv); + Perl_warn(aTHX_ "free %" SVf, SVfARG(sv)); return 0; } @@ -850,12 +883,12 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) MAGIC *mg; int count = 0; int i; - sv_magic(sv, (SV *) av, PERL_MAGIC_ext, NULL, 0); + sv_magic(sv, MUTABLE_SV(av), PERL_MAGIC_ext, NULL, 0); SvRMAGICAL_off(sv); mg = mg_find(sv, PERL_MAGIC_ext); mg->mg_virtual = &perlio_vtab; mg_magical(sv); - Perl_warn(aTHX_ "attrib %" SVf, sv); + Perl_warn(aTHX_ "attrib %" SVf, SVfARG(sv)); for (i = 2; i < items; i++) { STRLEN len; const char * const name = SvPV_const(ST(i), len); @@ -877,7 +910,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) SV * PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab) { - HV * const stash = gv_stashpvs("PerlIO::Layer", TRUE); + HV * const stash = gv_stashpvs("PerlIO::Layer", GV_ADD); SV * const sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))), stash); return sv; } @@ -889,6 +922,7 @@ XS(XS_PerlIO__Layer__NoWarnings) */ dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items) PerlIO_debug("warning:%s\n",SvPV_nolen_const(ST(0))); XSRETURN(0); @@ -898,6 +932,7 @@ XS(XS_PerlIO__Layer__find) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 2) Perl_croak(aTHX_ "Usage class->find(name[,load])"); else { @@ -943,10 +978,9 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) * seen as an invalid separator character. */ const char q = ((*s == '\'') ? '"' : '\''); - if (ckWARN(WARN_LAYER)) - Perl_warner(aTHX_ packWARN(WARN_LAYER), - "Invalid separator character %c%c%c in PerlIO layer specification %s", - q, *s, q, s); + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), + "Invalid separator character %c%c%c in PerlIO layer specification %s", + q, *s, q, s); SETERRNO(EINVAL, LIB_INVARG); return -1; } @@ -980,10 +1014,9 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) */ case '\0': e--; - if (ckWARN(WARN_LAYER)) - Perl_warner(aTHX_ packWARN(WARN_LAYER), - "Argument list not closed for PerlIO layer \"%.*s\"", - (int) (e - s), s); + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), + "Argument list not closed for PerlIO layer \"%.*s\"", + (int) (e - s), s); return -1; default: /* @@ -997,15 +1030,16 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) PerlIO_funcs * const layer = PerlIO_find_layer(aTHX_ s, llen, 1); if (layer) { + SV *arg = NULL; + if (as) + arg = newSVpvn(as, alen); PerlIO_list_push(aTHX_ av, layer, - (as) ? newSVpvn(as, - alen) : - &PL_sv_undef); + (arg) ? arg : &PL_sv_undef); + SvREFCNT_dec(arg); } else { - if (ckWARN(WARN_LAYER)) - Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", - (int) llen, s); + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", + (int) llen, s); return -1; } } @@ -1177,13 +1211,18 @@ PerlIO * PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) { if (tab->fsize != sizeof(PerlIO_funcs)) { - mismatch: - Perl_croak(aTHX_ "Layer does not match this perl"); + Perl_croak( aTHX_ + "%s (%d) does not match %s (%d)", + "PerlIO layer function table size", tab->fsize, + "size expected by this perl", sizeof(PerlIO_funcs) ); } if (tab->size) { PerlIOl *l; if (tab->size < sizeof(PerlIOl)) { - goto mismatch; + Perl_croak( aTHX_ + "%s (%d) smaller than %s (%d)", + "PerlIO layer instance size", tab->size, + "size expected by this perl", sizeof(PerlIOl) ); } /* Real layer with a data area */ if (f) { @@ -1256,7 +1295,7 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) while (t && (l = *t)) { if (l->tab->Binmode) { /* Has a handler - normal case */ - if ((*l->tab->Binmode)(aTHX_ f) == 0) { + if ((*l->tab->Binmode)(aTHX_ t) == 0) { if (*t == l) { /* Layer still there - move down a layer */ t = PerlIONext(t); @@ -1407,32 +1446,6 @@ Perl_PerlIO_fileno(pTHX_ PerlIO *f) Perl_PerlIO_or_Base(f, Fileno, fileno, -1, (aTHX_ f)); } -static const char * -PerlIO_context_layers(pTHX_ const char *mode) -{ - dVAR; - const char *type = NULL; - /* - * Need to supply default layer info from open.pm - */ - if (PL_curcop) { - SV * const layers = PL_curcop->cop_io; - if (layers) { - STRLEN len; - type = SvPV_const(layers, len); - if (type && mode[0] != 'r') { - /* - * Skip to write part - */ - const char * const s = strchr(type, 0); - if (s && (STRLEN)(s - type) < len) { - type = s + 1; - } - } - } - } - return type; -} static PerlIO_funcs * PerlIO_layer_from_ref(pTHX_ SV *sv) @@ -1441,8 +1454,14 @@ PerlIO_layer_from_ref(pTHX_ SV *sv) /* * For any scalar type load the handler which is bundled with perl */ - if (SvTYPE(sv) < SVt_PVAV) - return PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1); + if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(sv))) { + PerlIO_funcs *f = PerlIO_find_layer(aTHX_ STR_WITH_LEN("scalar"), 1); + /* This isn't supposed to happen, since PerlIO::scalar is core, + * but could happen anyway in smaller installs or with PAR */ + if (!f) + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\""); + return f; + } /* * For other types allow if layer is known but don't try and load it @@ -1456,8 +1475,9 @@ PerlIO_layer_from_ref(pTHX_ SV *sv) return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Code"), 0); case SVt_PVGV: return PerlIO_find_layer(aTHX_ STR_WITH_LEN("Glob"), 0); + default: + return NULL; } - return NULL; } PerlIO_list_t * @@ -1490,16 +1510,11 @@ PerlIO_resolve_layers(pTHX_ const char *layers, } } if (!layers || !*layers) - layers = PerlIO_context_layers(aTHX_ mode); + layers = Perl_PerlIO_context_layers(aTHX_ mode); if (layers && *layers) { PerlIO_list_t *av; if (incdef) { - IV i; - av = PerlIO_list_alloc(aTHX); - for (i = 0; i < def->cur; i++) { - PerlIO_list_push(aTHX_ av, def->array[i].funcs, - def->array[i].arg); - } + av = PerlIO_clone_list(aTHX_ def, NULL); } else { av = def; @@ -1527,7 +1542,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, if (!f && narg == 1 && *args == &PL_sv_undef) { if ((f = PerlIO_tmpfile())) { if (!layers || !*layers) - layers = PerlIO_context_layers(aTHX_ mode); + layers = Perl_PerlIO_context_layers(aTHX_ mode); if (layers && *layers) PerlIO_apply_layers(aTHX_ f, mode, layers); } @@ -1544,10 +1559,12 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, PerlIOl *l = *f; layera = PerlIO_list_alloc(aTHX); while (l) { - SV * const arg = (l->tab->Getarg) - ? (*l->tab->Getarg) (aTHX_ &l, NULL, 0) - : &PL_sv_undef; - PerlIO_list_push(aTHX_ layera, l->tab, arg); + SV *arg = NULL; + if (l->tab->Getarg) + arg = (*l->tab->Getarg) (aTHX_ &l, NULL, 0); + PerlIO_list_push(aTHX_ layera, l->tab, + (arg) ? arg : &PL_sv_undef); + SvREFCNT_dec(arg); l = *PerlIONext(&l); } } @@ -1609,18 +1626,24 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, SSize_t Perl_PerlIO_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { + PERL_ARGS_ASSERT_PERLIO_READ; + Perl_PerlIO_or_Base(f, Read, read, -1, (aTHX_ f, vbuf, count)); } SSize_t Perl_PerlIO_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { + PERL_ARGS_ASSERT_PERLIO_UNREAD; + Perl_PerlIO_or_Base(f, Unread, unread, -1, (aTHX_ f, vbuf, count)); } SSize_t Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { + PERL_ARGS_ASSERT_PERLIO_WRITE; + Perl_PerlIO_or_fail(f, Write, -1, (aTHX_ f, vbuf, count)); } @@ -1747,10 +1770,7 @@ PerlIO_has_base(PerlIO *f) if (tab) return (tab->Get_base != NULL); - SETERRNO(EINVAL, LIB_INVARG); } - else - SETERRNO(EBADF, SS_IVCHAN); return 0; } @@ -1758,15 +1778,14 @@ PerlIO_has_base(PerlIO *f) int PerlIO_fast_gets(PerlIO *f) { - if (PerlIOValid(f) && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) { - const PerlIO_funcs * const tab = PerlIOBase(f)->tab; + if (PerlIOValid(f)) { + if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) { + const PerlIO_funcs * const tab = PerlIOBase(f)->tab; - if (tab) - return (tab->Set_ptrcnt != NULL); - SETERRNO(EINVAL, LIB_INVARG); + if (tab) + return (tab->Set_ptrcnt != NULL); + } } - else - SETERRNO(EBADF, SS_IVCHAN); return 0; } @@ -1779,10 +1798,7 @@ PerlIO_has_cntptr(PerlIO *f) if (tab) return (tab->Get_ptr != NULL && tab->Get_cnt != NULL); - SETERRNO(EINVAL, LIB_INVARG); } - else - SETERRNO(EBADF, SS_IVCHAN); return 0; } @@ -1795,10 +1811,7 @@ PerlIO_canset_cnt(PerlIO *f) if (tab) return (tab->Set_ptrcnt != NULL); - SETERRNO(EINVAL, LIB_INVARG); } - else - SETERRNO(EBADF, SS_IVCHAN); return 0; } @@ -2066,7 +2079,7 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) } #if 0 PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08" UVxf " (%s)\n", - f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", + (void*)f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", l->flags, PerlIO_modestr(f, temp)); #endif return 0; @@ -2221,7 +2234,9 @@ PerlIO_sv_dup(pTHX_ SV *arg, CLONE_PARAMS *param) return NULL; #ifdef sv_dup if (param) { - return sv_dup(arg, param); + arg = sv_dup(arg, param); + SvREFCNT_inc_simple_void_NN(arg); + return arg; } else { return newSVsv(arg); @@ -2245,32 +2260,26 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) } if (f) { PerlIO_funcs * const self = PerlIOBase(o)->tab; - SV *arg; + SV *arg = NULL; char buf[8]; 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); - else { - arg = NULL; - } f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); - if (arg) { - SvREFCNT_dec(arg); - } + if (PerlIOBase(o)->flags & PERLIO_F_UTF8) + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + SvREFCNT_dec(arg); } return f; } -#ifdef USE_THREADS -perl_mutex PerlIO_mutex; -#endif - /* PL_perlio_fd_refcnt[] is in intrpvar.h */ -/* Must be called with PerlIO_mutex locked. */ +/* Must be called with PL_perlio_mutex locked. */ static void S_more_refcounted_fds(pTHX_ const int new_fd) { + dVAR; const int old_max = PL_perlio_fd_refcnt_size; const int new_max = 16 + (new_fd & ~15); int *new_array; @@ -2284,12 +2293,13 @@ S_more_refcounted_fds(pTHX_ const int new_fd) { assert (new_max > new_fd); - new_array - = PerlMemShared_realloc(PL_perlio_fd_refcnt, new_max * sizeof(int)); + /* Use plain realloc() since we need this memory to be really + * global and visible to all the interpreters and/or threads. */ + new_array = (int*) realloc(PL_perlio_fd_refcnt, new_max * sizeof(int)); if (!new_array) { -#ifdef USE_THREADS - MUTEX_UNLOCK(&PerlIO_mutex); +#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), @@ -2300,7 +2310,9 @@ S_more_refcounted_fds(pTHX_ const int new_fd) { PL_perlio_fd_refcnt_size = new_max; PL_perlio_fd_refcnt = new_array; - PerlIO_debug("Zeroing %p, %d\n", new_array + old_max, new_max - old_max); + 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); } @@ -2309,12 +2321,8 @@ S_more_refcounted_fds(pTHX_ const int new_fd) { void PerlIO_init(pTHX) { - /* Place holder for stdstreams call ??? */ -#ifdef USE_THREADS - MUTEX_INIT(&PerlIO_mutex); -#else + /* MUTEX_INIT(&PL_perlio_mutex) is done in PERL_SYS_INIT3(). */ PERL_UNUSED_CONTEXT; -#endif } void @@ -2324,18 +2332,25 @@ PerlIOUnix_refcnt_inc(int fd) if (fd >= 0) { dVAR; -#ifdef USE_THREADS - MUTEX_LOCK(&PerlIO_mutex); +#ifdef USE_ITHREADS + MUTEX_LOCK(&PL_perlio_mutex); #endif if (fd >= PL_perlio_fd_refcnt_size) S_more_refcounted_fds(aTHX_ fd); PL_perlio_fd_refcnt[fd]++; - PerlIO_debug("fd %d refcnt=%d\n",fd,PL_perlio_fd_refcnt[fd]); + if (PL_perlio_fd_refcnt[fd] <= 0) { + 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]); -#ifdef USE_THREADS - MUTEX_UNLOCK(&PerlIO_mutex); +#ifdef USE_ITHREADS + MUTEX_UNLOCK(&PL_perlio_mutex); #endif + } else { + Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd); } } @@ -2346,19 +2361,24 @@ PerlIOUnix_refcnt_dec(int fd) int cnt = 0; if (fd >= 0) { dVAR; -#ifdef USE_THREADS - MUTEX_LOCK(&PerlIO_mutex); +#ifdef USE_ITHREADS + MUTEX_LOCK(&PL_perlio_mutex); #endif - /* XXX should this be a panic? */ - if (fd >= PL_perlio_fd_refcnt_size) - S_more_refcounted_fds(aTHX_ fd); - - /* XXX should this be a panic if it drops below 0? */ + if (fd >= PL_perlio_fd_refcnt_size) { + Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n", + fd, PL_perlio_fd_refcnt_size); + } + if (PL_perlio_fd_refcnt[fd] <= 0) { + Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n", + fd, PL_perlio_fd_refcnt[fd]); + } cnt = --PL_perlio_fd_refcnt[fd]; - PerlIO_debug("fd %d refcnt=%d\n",fd,cnt); -#ifdef USE_THREADS - MUTEX_UNLOCK(&PerlIO_mutex); + PerlIO_debug("refcnt_dec: fd %d refcnt=%d\n", fd, cnt); +#ifdef USE_ITHREADS + MUTEX_UNLOCK(&PL_perlio_mutex); #endif + } else { + Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd); } return cnt; } @@ -2369,10 +2389,11 @@ PerlIO_cleanup(pTHX) dVAR; int i; #ifdef USE_ITHREADS - PerlIO_debug("Cleanup layers for %p\n",aTHX); + PerlIO_debug("Cleanup layers for %p\n",(void*)aTHX); #else PerlIO_debug("Cleanup layers\n"); #endif + /* Raise STDIN..STDERR refcount so we don't close them */ for (i=0; i < 3; i++) PerlIOUnix_refcnt_inc(i); @@ -2391,7 +2412,45 @@ 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 + being present (at least in win32) :-(. + Disable for now. +*/ +#ifdef DEBUGGING + { + /* By now all filehandles should have been closed, so any + * stray (non-STD-)filehandles indicate *possible* (PerlIO) + * errors. */ +#define PERLIO_TEARDOWN_MESSAGE_BUF_SIZE 64 +#define PERLIO_TEARDOWN_MESSAGE_FD 2 + char buf[PERLIO_TEARDOWN_MESSAGE_BUF_SIZE]; + int i; + for (i = 3; i < PL_perlio_fd_refcnt_size; i++) { + if (PL_perlio_fd_refcnt[i]) { + const STRLEN len = + my_snprintf(buf, sizeof(buf), + "PerlIO_teardown: fd %d refcnt=%d\n", + i, PL_perlio_fd_refcnt[i]); + PerlLIO_write(PERLIO_TEARDOWN_MESSAGE_FD, buf, len); + } + } + } +#endif +#endif + /* Not bothering with PL_perlio_mutex since by now + * all the interpreters are gone. */ + if (PL_perlio_fd_refcnt_size /* Assuming initial size of zero. */ + && PL_perlio_fd_refcnt) { + free(PL_perlio_fd_refcnt); /* To match realloc() in S_more_refcounted_fds(). */ + PL_perlio_fd_refcnt = NULL; + PL_perlio_fd_refcnt_size = 0; + } +} /*--------------------------------------------------------------------------------------*/ /* @@ -2544,7 +2603,11 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, mode++; else { imode = PerlIOUnix_oflags(mode); +#ifdef VMS + perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */ +#else perm = 0666; +#endif } if (imode != -1) { const char *path = SvPV_nolen_const(*args); @@ -2834,6 +2897,7 @@ PerlIO_importFILE(FILE *stdio, const char *mode) if ((f = PerlIO_push(aTHX_(f = PerlIO_allocate(aTHX)), PERLIO_FUNCS_CAST(&PerlIO_stdio), mode, NULL))) { s = PerlIOSelf(f, PerlIOStdio); s->stdio = stdio; + PerlIOUnix_refcnt_inc(fileno(stdio)); } } return f; @@ -2959,7 +3023,9 @@ PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) stdio = PerlSIO_fdopen(fd, PerlIO_modestr(o,mode)); set_this: PerlIOSelf(f, PerlIOStdio)->stdio = stdio; - PerlIOUnix_refcnt_inc(fileno(stdio)); + if(stdio) { + PerlIOUnix_refcnt_inc(fileno(stdio)); + } } return f; } @@ -2983,6 +3049,7 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) f->_fileno = -1; return 1; # elif defined(__sun__) + PERL_UNUSED_ARG(f); return 0; # elif defined(__hpux) f->__fileH = 0xff; @@ -3056,8 +3123,11 @@ PerlIOStdio_close(pTHX_ PerlIO *f) const int fd = fileno(stdio); int invalidate = 0; IV result = 0; - int saveerr = 0; - int dupfd = 0; + int dupfd = -1; + dSAVEDERRNO; +#ifdef USE_ITHREADS + dVAR; +#endif #ifdef SOCKS5_VERSION_NAME /* Socks lib overrides close() but stdio isn't linked to that library (though we are) - so we must call close() @@ -3068,8 +3138,15 @@ PerlIOStdio_close(pTHX_ PerlIO *f) if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) invalidate = 1; #endif - if (PerlIOUnix_refcnt_dec(fd) > 0) /* File descriptor still in use */ + /* Test for -1, as *BSD stdio (at least) on fclose sets the FILE* such + that a subsequent fileno() on it returns -1. Don't want to croak() + from within PerlIOUnix_refcnt_dec() if some buggy caller code is + trying to close an already closed handle which somehow it still has + a reference to. (via.xs, I'm looking at you). */ + if (fd != -1 && PerlIOUnix_refcnt_dec(fd) > 0) { + /* File descriptor still in use */ invalidate = 1; + } if (invalidate) { /* For STD* handles, don't close stdio, since we shared the FILE *, too. */ if (stdio == stdin) /* Some stdios are buggy fflush-ing inputs */ @@ -3081,26 +3158,60 @@ PerlIOStdio_close(pTHX_ PerlIO *f) fileno slot of the FILE * */ result = PerlIO_flush(f); - saveerr = errno; + SAVE_ERRNO; invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio); - if (!invalidate) + 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); +#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. */ + } +#endif + } + } else { + SAVE_ERRNO; /* This is here only to silence compiler warnings */ } result = PerlSIO_fclose(stdio); /* We treat error from stdio as success if we invalidated errno may NOT be expected EBADF */ if (invalidate && result != 0) { - errno = saveerr; + RESTORE_ERRNO; result = 0; } #ifdef SOCKS5_VERSION_NAME /* in SOCKS' case, let close() determine return value */ result = close(fd); #endif - if (dupfd) { + if (dupfd >= 0) { PerlLIO_dup2(dupfd,fd); PerlLIO_close(dupfd); +#ifdef USE_ITHREADS + MUTEX_UNLOCK(&PL_perlio_mutex); +#endif } return result; } @@ -3250,9 +3361,9 @@ PerlIOStdio_flush(pTHX_ PerlIO *f) /* * Not writeable - sync by attempting a seek */ - const int err = errno; + dSAVE_ERRNO; if (PerlSIO_fseek(stdio, (Off_t) 0, SEEK_CUR) != 0) - errno = err; + RESTORE_ERRNO; #endif } return 0; @@ -3331,11 +3442,9 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; if (ptr != NULL) { #ifdef STDIO_PTR_LVALUE - PerlSIO_set_ptr(stdio, (void*)ptr); /* LHS STDCHAR* cast non-portable */ + PerlSIO_set_ptr(stdio, ptr); /* LHS STDCHAR* cast non-portable */ #ifdef STDIO_PTR_LVAL_SETS_CNT - if (PerlSIO_get_cnt(stdio) != (cnt)) { - assert(PerlSIO_get_cnt(stdio) == (cnt)); - } + assert(PerlSIO_get_cnt(stdio) == (cnt)); #endif #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT)) /* @@ -3380,9 +3489,15 @@ PerlIOStdio_fill(pTHX_ PerlIO *f) if (PerlSIO_fflush(stdio) != 0) return EOF; } - c = PerlSIO_fgetc(stdio); - if (c == EOF) - return EOF; + for (;;) { + c = PerlSIO_fgetc(stdio); + if (c != EOF) + break; + if (! PerlSIO_ferror(stdio) || errno != EINTR) + return EOF; + PERL_ASYNC_CHECK(); + SETERRNO(0,0); + } #if (defined(STDIO_PTR_LVALUE) && (defined(STDIO_CNT_LVALUE) || defined(STDIO_PTR_LVAL_SETS_CNT))) @@ -3499,6 +3614,7 @@ PerlIO_exportFILE(PerlIO * f, const char *mode) if ((f2 = PerlIO_push(aTHX_ f, PERLIO_FUNCS_CAST(&PerlIO_stdio), buf, NULL))) { PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio); s->stdio = stdio; + PerlIOUnix_refcnt_inc(fileno(stdio)); /* Link previous lower layers under new one */ *PerlIONext(f) = l; } @@ -3516,6 +3632,7 @@ FILE * PerlIO_findFILE(PerlIO *f) { PerlIOl *l = *f; + FILE *stdio; while (l) { if (l->tab == &PerlIO_stdio) { PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); @@ -3524,7 +3641,19 @@ PerlIO_findFILE(PerlIO *f) l = *PerlIONext(&l); } /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */ - return PerlIO_exportFILE(f, NULL); + /* However, we're not really exporting a FILE * to someone else (who + becomes responsible for closing it, or calling PerlIO_releaseFILE()) + So we need to undo its refernce count increase on the underlying file + descriptor. We have to do this, because if the loop above returns you + the FILE *, then *it* didn't increase any reference count. So there's + only one way to be consistent. */ + stdio = PerlIO_exportFILE(f, NULL); + if (stdio) { + const int fd = fileno(stdio); + if (fd >= 0) + PerlIOUnix_refcnt_dec(fd); + } + return stdio; } /* Use this to reverse PerlIO_exportFILE calls. */ @@ -3538,6 +3667,9 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f) PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); if (s->stdio == f) { dTHX; + const int fd = fileno(f); + if (fd >= 0) + PerlIOUnix_refcnt_dec(fd); PerlIO_pop(aTHX_ p); return; } @@ -3986,7 +4118,7 @@ PerlIOBuf_get_base(pTHX_ PerlIO *f) if (!b->buf) { if (!b->bufsiz) b->bufsiz = 4096; - b->buf = Newxz(b->buf,b->bufsiz, STDCHAR); + Newxz(b->buf,b->bufsiz, STDCHAR); if (!b->buf) { b->buf = (STDCHAR *) & b->oneword; b->bufsiz = sizeof(b->oneword); @@ -4009,13 +4141,14 @@ void PerlIOBuf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) { PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); +#ifndef DEBUGGING + PERL_UNUSED_ARG(cnt); +#endif if (!b->buf) PerlIO_get_base(f); b->ptr = ptr; - if (PerlIO_get_cnt(f) != cnt || b->ptr < b->buf) { - assert(PerlIO_get_cnt(f) == cnt); - assert(b->ptr >= b->buf); - } + assert(PerlIO_get_cnt(f) == cnt); + assert(b->ptr >= b->buf); PerlIOBase(f)->flags |= PERLIO_F_RDBUF; } @@ -4204,6 +4337,21 @@ typedef struct { * buffer */ } PerlIOCrlf; +/* Inherit the PERLIO_F_UTF8 flag from previous layer. + * Otherwise the :crlf layer would always revert back to + * raw mode. + */ +static void +S_inherit_utf8_flag(PerlIO *f) +{ + PerlIO *g = PerlIONext(f); + if (PerlIOValid(g)) { + if (PerlIOBase(g)->flags & PERLIO_F_UTF8) { + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + } + } +} + IV PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) { @@ -4212,7 +4360,7 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) code = PerlIOBuf_pushed(aTHX_ f, mode, arg, tab); #if 0 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08" UVxf "\n", - f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)", + (void*)f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)", PerlIOBase(f)->flags); #endif { @@ -4221,17 +4369,19 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) * any given moment at most one CRLF-capable layer being enabled * in the whole layer stack. */ PerlIO *g = PerlIONext(f); - while (g && *g) { + while (PerlIOValid(g)) { PerlIOl *b = PerlIOBase(g); if (b && b->tab == &PerlIO_crlf) { if (!(b->flags & PERLIO_F_CRLF)) b->flags |= PERLIO_F_CRLF; + S_inherit_utf8_flag(g); PerlIO_pop(aTHX_ f); return code; } g = PerlIONext(g); } } + S_inherit_utf8_flag(f); return code; } @@ -4396,8 +4546,8 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) if (ptr != chk ) { Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08" UVxf - " nl=%p e=%p for %d", ptr, chk, flags, c->nl, - b->end, cnt); + " nl=%p e=%p for %d", (void*)ptr, (void*)chk, + flags, c->nl, b->end, cnt); } #endif } @@ -4484,9 +4634,7 @@ PerlIOCrlf_binmode(pTHX_ PerlIO *f) PerlIOBase(f)->flags &= ~PERLIO_F_CRLF; #ifndef PERLIO_USING_CRLF /* CRLF is unusual case - if this is just the :crlf layer pop it */ - if (PerlIOBase(f)->tab == &PerlIO_crlf) { - PerlIO_pop(aTHX_ f); - } + PerlIO_pop(aTHX_ f); #endif } return 0; @@ -4566,7 +4714,7 @@ PerlIOMmap_map(pTHX_ PerlIO *f) } posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size; len = st.st_size - posn; - m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, 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); @@ -4605,7 +4753,14 @@ PerlIOMmap_unmap(pTHX_ PerlIO *f) if (m->len) { PerlIOBuf * const b = &m->base; if (b->buf) { - code = munmap(m->mptr, m->len); + /* 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; @@ -4953,16 +5108,16 @@ int PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) { dTHX; - SV * const sv = newSVpvs(""); + SV * sv; const char *s; STRLEN len; SSize_t wrote; #ifdef NEED_VA_COPY va_list apc; Perl_va_copy(ap, apc); - sv_vcatpvf(sv, fmt, &apc); + sv = vnewSVpvf(fmt, &apc); #else - sv_vcatpvf(sv, fmt, &ap); + sv = vnewSVpvf(fmt, &ap); #endif s = SvPV_const(sv, len); wrote = PerlIO_write(f, s, len); @@ -5007,31 +5162,37 @@ PerlIO_tmpfile(void) f = PerlIO_fdopen(fd, "w+b"); #else /* WIN32 */ # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2) - SV * const sv = newSVpvs("/tmp/PerlIO_XXXXXX"); + int fd = -1; + char tempname[] = "/tmp/PerlIO_XXXXXX"; + const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR"); + SV * sv = NULL; /* * I have no idea how portable mkstemp() is ... NI-S */ - const int fd = mkstemp(SvPVX(sv)); + 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)); + } + if (fd < 0) { + sv = NULL; + /* else we try /tmp */ + fd = mkstemp(tempname); + } if (fd >= 0) { f = PerlIO_fdopen(fd, "w+"); if (f) PerlIOBase(f)->flags |= PERLIO_F_TEMP; - PerlLIO_unlink(SvPVX_const(sv)); - SvREFCNT_dec(sv); + PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname); } + SvREFCNT_dec(sv); # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */ FILE * const stdio = PerlSIO_tmpfile(); - if (stdio) { - if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), - PERLIO_FUNCS_CAST(&PerlIO_stdio), - "w+", NULL))) { - PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio); + if (stdio) + f = PerlIO_fdopen(fileno(stdio), "w+"); - if (s) - s->stdio = stdio; - } - } # endif /* else HAS_MKSTEMP */ #endif /* else WIN32 */ return f; @@ -5048,6 +5209,35 @@ PerlIO_tmpfile(void) * Now some functions in terms of above which may be needed even if we are * not in true PerlIO mode */ +const char * +Perl_PerlIO_context_layers(pTHX_ const char *mode) +{ + dVAR; + const char *direction = NULL; + SV *layers; + /* + * Need to supply default layer info from open.pm + */ + + if (!PL_curcop) + return NULL; + + if (mode && mode[0] != 'r') { + if (PL_curcop->cop_hints & HINT_LEXICAL_IO_OUT) + direction = "open>"; + } else { + if (PL_curcop->cop_hints & HINT_LEXICAL_IO_IN) + direction = "open<"; + } + if (!direction) + return NULL; + + layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0); + + assert(layers); + return SvOK(layers) ? SvPV_nolen_const(layers) : NULL; +} + #ifndef HAS_FSETPOS #undef PerlIO_setpos @@ -5138,20 +5328,15 @@ vfprintf(FILE *fd, char *pat, char *args) int PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) { - dVAR; -#ifdef USE_VSNPRINTF - const int val = vsnprintf(s, n, fmt, ap); -#else - const int val = vsprintf(s, fmt, ap); -#endif /* #ifdef USE_VSNPRINTF */ - if (n >= 0) { - if (strlen(s) >= (STRLEN) n) { - dTHX; - (void) PerlIO_puts(Perl_error_log, - "panic: sprintf overflow - memory corrupted!\n"); - my_exit(1); - } + 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