X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5cb43542c0ef13c00ac1ccb9844ae0df5c118b04..ccbd73a450bd33362373a3a066beffb348f528a7:/perlio.c diff --git a/perlio.c b/perlio.c index f684a4e..7eb7e27 100644 --- a/perlio.c +++ b/perlio.c @@ -1,7 +1,7 @@ /* * perlio.c * Copyright (c) 1996-2006, Nick Ing-Simmons - * Copyright (c) 2006, 2007, Nick Ing-Simmons and others + * 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. @@ -134,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; @@ -144,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 @@ -174,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 @@ -502,9 +507,8 @@ PerlIO_debug(const char *fmt, ...) #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); @@ -755,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 ? @@ -796,7 +805,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) { @@ -902,7 +911,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; } @@ -914,6 +923,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); @@ -923,6 +933,7 @@ XS(XS_PerlIO__Layer__find) { dVAR; dXSARGS; + PERL_UNUSED_ARG(cv); if (items < 2) Perl_croak(aTHX_ "Usage class->find(name[,load])"); else { @@ -1284,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); @@ -1616,18 +1627,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)); } @@ -2261,6 +2278,8 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) if (self->Getarg) arg = (*self->Getarg)(aTHX_ o, param, flags); f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); + if (PerlIOBase(o)->flags & PERLIO_F_UTF8) + PerlIOBase(f)->flags |= PERLIO_F_UTF8; if (arg) SvREFCNT_dec(arg); } @@ -2405,22 +2424,36 @@ PerlIO_cleanup(pTHX) } } -void PerlIO_teardown(pTHX) /* Call only from PERL_SYS_TERM(). */ +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]) - PerlIO_debug("PerlIO_cleanup: fd %d refcnt=%d\n", - i, PL_perlio_fd_refcnt[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. */ @@ -2872,6 +2905,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; @@ -3096,7 +3130,10 @@ PerlIOStdio_close(pTHX_ PerlIO *f) int invalidate = 0; IV result = 0; int saveerr = 0; - int dupfd = 0; + int dupfd = -1; +#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() @@ -3122,8 +3159,37 @@ PerlIOStdio_close(pTHX_ PerlIO *f) result = PerlIO_flush(f); saveerr = 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 + } } result = PerlSIO_fclose(stdio); /* We treat error from stdio as success if we invalidated @@ -3137,9 +3203,12 @@ PerlIOStdio_close(pTHX_ PerlIO *f) /* 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; } @@ -3372,9 +3441,7 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) #ifdef STDIO_PTR_LVALUE 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)) /* @@ -3419,9 +3486,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))) @@ -3538,6 +3611,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; } @@ -3555,6 +3629,7 @@ FILE * PerlIO_findFILE(PerlIO *f) { PerlIOl *l = *f; + FILE *stdio; while (l) { if (l->tab == &PerlIO_stdio) { PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); @@ -3563,7 +3638,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. */ @@ -3577,6 +3664,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; } @@ -4048,13 +4138,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; } @@ -5016,16 +5107,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); @@ -5080,8 +5171,8 @@ 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(); @@ -5108,30 +5199,30 @@ const char * Perl_PerlIO_context_layers(pTHX_ const char *mode) { dVAR; - const char *type = NULL; + const char *direction = NULL; + SV *layers; /* * Need to supply default layer info from open.pm */ - if (PL_curcop && PL_curcop->cop_hints & HINT_LEXICAL_IO) { - SV * const layers - = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0, - "open", 4, 0, 0); - assert(layers); - if (SvOK(layers)) { - STRLEN len; - type = SvPV_const(layers, len); - if (type && mode && mode[0] != 'r') { - /* - * Skip to write part, which is separated by a '\0' - */ - STRLEN read_len = strlen(type); - if (read_len < len) { - type += read_len + 1; - } - } - } + + 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<"; } - return type; + 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; }