X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=7eb7e27c4ed25598b9abc5e23849f974d8a75c07;hb=6ada912ce2ec33f8cd53bfc96056ec8617e4a08e;hp=bbb12db702195fe6d7e7a7d9c81ec28b4e792054;hpb=f0720f70fca1466afb0baffc79f6af7a9e80f428;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perlio.c b/perlio.c index bbb12db..7eb7e27 100644 --- a/perlio.c +++ b/perlio.c @@ -507,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); @@ -760,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 ? @@ -1291,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); @@ -1623,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)); } @@ -2414,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. */ @@ -3106,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() @@ -3132,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 @@ -3147,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; } @@ -3382,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)) /* @@ -3572,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); @@ -3580,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. */ @@ -4068,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; } @@ -5036,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);