X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=304d106ecb7ef9a979fec7a4625dc73a1057895e;hb=9f2f055aa1e8c86d97b5ea42473ab1747f518f3a;hp=bba198c1026777df056045c9a0981b87ab3cbf9c;hpb=c586124f72c3990bdacc564215636607a575c10f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perlio.c b/perlio.c index bba198c..304d106 100644 --- a/perlio.c +++ b/perlio.c @@ -1,7 +1,7 @@ /* * perlio.c * Copyright (c) 1996-2006, Nick Ing-Simmons - * Copyright (c) 2006, 2007, Larry Wall and others + * 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. @@ -10,6 +10,8 @@ /* * 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 @@ -507,9 +509,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); @@ -760,6 +761,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 ? @@ -806,7 +812,7 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) SAVEINT(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++; /* @@ -828,7 +834,7 @@ 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", @@ -841,7 +847,7 @@ 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", @@ -880,7 +886,7 @@ 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; @@ -1291,7 +1297,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); @@ -1623,18 +1629,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)); } @@ -2268,6 +2280,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); } @@ -2412,22 +2426,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. */ @@ -3104,7 +3132,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() @@ -3115,8 +3146,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 */ @@ -3130,8 +3168,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 @@ -3145,9 +3212,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; } @@ -3380,9 +3450,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)) /* @@ -3552,6 +3620,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; } @@ -3569,6 +3638,7 @@ FILE * PerlIO_findFILE(PerlIO *f) { PerlIOl *l = *f; + FILE *stdio; while (l) { if (l->tab == &PerlIO_stdio) { PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); @@ -3577,7 +3647,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. */ @@ -3591,6 +3673,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; } @@ -4062,13 +4147,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; } @@ -5030,16 +5116,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);