X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/cfedb851ae04e1e3aafe948c7d624e1c65bbd2df..3a9b2cacfb08e1181b7d9ae45cad1ed8acd59972:/perlio.c diff --git a/perlio.c b/perlio.c index e796607..76fe225 100644 --- a/perlio.c +++ b/perlio.c @@ -1,7 +1,10 @@ /* - * 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, 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. */ /* @@ -30,7 +33,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 +117,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) { @@ -119,6 +134,7 @@ perlsio_binmode(FILE *fp, int iotype, int mode) */ #ifdef DOSISH # if defined(atarist) || defined(__MINT__) + PERL_UNUSED_ARG(iotype); if (!fflush(fp)) { if (mode & O_BINARY) ((FILE *) fp)->_flag |= _IOBIN; @@ -129,6 +145,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 +176,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 +481,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,15 +501,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)); - const STRLEN len2 = vsprintf(buffer+len, fmt, ap); - 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); @@ -626,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); } } @@ -645,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++); @@ -657,6 +687,7 @@ PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) } } #else + PERL_UNUSED_CONTEXT; PERL_UNUSED_ARG(proto); PERL_UNUSED_ARG(param); #endif @@ -669,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; @@ -769,7 +800,7 @@ 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 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0); ENTER; SAVEINT(PL_in_load_module); if (cv) { @@ -799,7 +830,8 @@ perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) IO * const io = GvIOn((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; } @@ -811,7 +843,8 @@ perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) IO * const io = GvIOn((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; } @@ -819,14 +852,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; } @@ -851,7 +884,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) 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); @@ -873,7 +906,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; } @@ -885,6 +918,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); @@ -894,6 +928,7 @@ XS(XS_PerlIO__Layer__find) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 2) Perl_croak(aTHX_ "Usage class->find(name[,load])"); else { @@ -993,10 +1028,13 @@ 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); + if (arg) + SvREFCNT_dec(arg); } else { if (ckWARN(WARN_LAYER)) @@ -1182,19 +1220,26 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) goto mismatch; } /* Real layer with a data area */ - Newxc(l,tab->size,char,PerlIOl); - if (l && f) { - Zero(l, tab->size, char); - l->next = *f; - l->tab = (PerlIO_funcs*) tab; - *f = l; - 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) { - PerlIO_pop(aTHX_ f); - return NULL; + if (f) { + char *temp; + Newxz(temp, tab->size, char); + l = (PerlIOl*)temp; + if (l) { + l->next = *f; + l->tab = (PerlIO_funcs*) tab; + *f = l; + 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) { + PerlIO_pop(aTHX_ f); + return NULL; + } } + else + return NULL; } } else if (f) { @@ -1396,32 +1441,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) @@ -1430,8 +1449,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) { + 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 && ckWARN(WARN_LAYER)) + Perl_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 @@ -1445,8 +1470,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 * @@ -1479,16 +1505,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; @@ -1516,7 +1537,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); } @@ -1533,10 +1554,13 @@ 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); + if (arg) + SvREFCNT_dec(arg); l = *PerlIONext(&l); } } @@ -2055,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; @@ -2097,7 +2121,7 @@ PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) SSize_t avail = PerlIO_get_cnt(f); SSize_t take = 0; if (avail > 0) - take = ((SSize_t)count < avail) ? count : avail; + take = ((SSize_t)count < avail) ? (SSize_t)count : avail; if (take > 0) { STDCHAR *ptr = PerlIO_get_ptr(f); Copy(ptr, buf, take, STDCHAR); @@ -2210,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); @@ -2234,32 +2260,27 @@ 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) { + if (PerlIOBase(o)->flags & PERLIO_F_UTF8) + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + if (arg) 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; @@ -2273,12 +2294,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), @@ -2289,7 +2311,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); } @@ -2298,12 +2322,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 @@ -2313,18 +2333,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); } } @@ -2335,19 +2362,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; } @@ -2358,10 +2390,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); @@ -2380,7 +2413,45 @@ PerlIO_cleanup(pTHX) } } - +void PerlIO_teardown() /* 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; + } +} /*--------------------------------------------------------------------------------------*/ /* @@ -2559,7 +2630,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, } else { if (f) { - /*EMPTY*/; + NOOP; /* * FIXME: pop layers ??? */ @@ -2823,6 +2894,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; @@ -2864,7 +2936,6 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, #endif stdio = PerlSIO_fopen(path, mode); if (stdio) { - PerlIOStdio *s; if (!f) { f = PerlIO_allocate(aTHX); } @@ -2872,9 +2943,10 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, mode = PerlIOStdio_mode(mode, tmode); f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg); if (f) { - s = PerlIOSelf(f, PerlIOStdio); - s->stdio = stdio; - PerlIOUnix_refcnt_inc(fileno(s->stdio)); + PerlIOSelf(f, PerlIOStdio)->stdio = stdio; + PerlIOUnix_refcnt_inc(fileno(stdio)); + } else { + PerlSIO_fclose(stdio); } return f; } @@ -2912,9 +2984,8 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, f = PerlIO_allocate(aTHX); } if ((f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg))) { - PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio); - s->stdio = stdio; - PerlIOUnix_refcnt_inc(fileno(s->stdio)); + PerlIOSelf(f, PerlIOStdio)->stdio = stdio; + PerlIOUnix_refcnt_inc(fileno(stdio)); } return f; } @@ -2940,7 +3011,7 @@ PerlIOStdio_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) goto set_this; } else { - /*EMPTY*/; + NOOP; /* FIXME: To avoid messy error recovery if dup fails re-use the existing stdio as though flag was not set */ @@ -2973,6 +3044,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; @@ -3229,7 +3301,7 @@ PerlIOStdio_flush(pTHX_ PerlIO *f) return PerlSIO_fflush(stdio); } else { - /*EMPTY*/; + NOOP; #if 0 /* * FIXME: This discards ungetc() and pre-read stuff which is not @@ -3321,7 +3393,7 @@ 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)); @@ -3370,9 +3442,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))) @@ -3489,6 +3567,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; } @@ -3506,6 +3585,7 @@ FILE * PerlIO_findFILE(PerlIO *f) { PerlIOl *l = *f; + FILE *stdio; while (l) { if (l->tab == &PerlIO_stdio) { PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); @@ -3514,7 +3594,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. */ @@ -3528,6 +3620,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; } @@ -3709,6 +3804,8 @@ PerlIOBuf_fill(pTHX_ PerlIO *f) if (!b->buf) PerlIO_get_base(f); /* allocate via vtable */ + assert(b->buf); /* The b->buf does get allocated via the vtable system. */ + b->ptr = b->end = b->buf; if (!PerlIOValid(n)) { @@ -4192,6 +4289,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) { @@ -4200,7 +4312,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 { @@ -4209,17 +4321,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; } @@ -4369,7 +4483,7 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) ptr -= cnt; } else { - /*EMPTY*/; + NOOP; #if 0 /* * Test code - delete when it works ... @@ -4384,8 +4498,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 } @@ -4554,7 +4668,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); @@ -4593,7 +4707,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; @@ -4941,16 +5062,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); @@ -5005,21 +5126,14 @@ PerlIO_tmpfile(void) if (f) PerlIOBase(f)->flags |= PERLIO_F_TEMP; PerlLIO_unlink(SvPVX_const(sv)); - SvREFCNT_dec(sv); } + 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; @@ -5036,6 +5150,36 @@ 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 = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, + 0, direction, 5, 0, 0); + + assert(layers); + return SvOK(layers) ? SvPV_nolen_const(layers) : NULL; +} + #ifndef HAS_FSETPOS #undef PerlIO_setpos @@ -5126,16 +5270,15 @@ vfprintf(FILE *fd, char *pat, char *args) int PerlIO_vsprintf(char *s, int n, const char *fmt, va_list ap) { - dVAR; - const int val = vsprintf(s, fmt, ap); - 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