X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=7da7505045ae2ee54119e1de0a4017689a5c4ad4;hb=8622e0e2540f3d8fde9f0f9cd0d094a30ab8a4cf;hp=2ea86aa87d1f4f2cd6ea573528f10483ea703a60;hpb=53ce71d37f27a80bc42faba5c56ff7a3580a11f8;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perlio.c b/perlio.c index 2ea86aa..7da7505 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 @@ -133,7 +135,7 @@ 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) @@ -612,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); @@ -759,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 ? @@ -800,12 +805,12 @@ 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 = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("PerlIO::Layer::NoWarnings"), 0); + CV * const cv = get_cvs("PerlIO::Layer::NoWarnings", 0); ENTER; 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++; /* @@ -827,7 +832,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", @@ -840,7 +845,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", @@ -879,7 +884,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; @@ -974,10 +979,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; } @@ -1011,10 +1015,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: /* @@ -1033,13 +1036,11 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) arg = newSVpvn(as, alen); PerlIO_list_push(aTHX_ av, layer, (arg) ? arg : &PL_sv_undef); - if (arg) - SvREFCNT_dec(arg); + 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; } } @@ -1290,7 +1291,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); @@ -1453,8 +1454,8 @@ PerlIO_layer_from_ref(pTHX_ SV *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 && ckWARN(WARN_LAYER)) - Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\""); + if (!f) + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\""); return f; } @@ -1559,8 +1560,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, 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); + SvREFCNT_dec(arg); l = *PerlIONext(&l); } } @@ -1622,18 +1622,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)); } @@ -1760,10 +1766,7 @@ PerlIO_has_base(PerlIO *f) if (tab) return (tab->Get_base != NULL); - SETERRNO(EINVAL, LIB_INVARG); } - else - SETERRNO(EBADF, SS_IVCHAN); return 0; } @@ -1771,15 +1774,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; } @@ -1792,10 +1794,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; } @@ -1808,10 +1807,7 @@ PerlIO_canset_cnt(PerlIO *f) if (tab) return (tab->Set_ptrcnt != NULL); - SETERRNO(EINVAL, LIB_INVARG); } - else - SETERRNO(EBADF, SS_IVCHAN); return 0; } @@ -2269,8 +2265,7 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int 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); + SvREFCNT_dec(arg); } return f; } @@ -2413,22 +2408,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. */ @@ -3006,7 +3015,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; } @@ -3104,8 +3115,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() @@ -3116,8 +3130,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 */ @@ -3129,26 +3150,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; } @@ -3298,9 +3353,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; @@ -3381,9 +3436,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)) /* @@ -3571,6 +3624,7 @@ FILE * PerlIO_findFILE(PerlIO *f) { PerlIOl *l = *f; + FILE *stdio; while (l) { if (l->tab == &PerlIO_stdio) { PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); @@ -3579,7 +3633,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. */ @@ -4067,13 +4133,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; } @@ -4559,9 +4626,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; @@ -5089,16 +5154,27 @@ 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 * const sv = tmpdir && *tmpdir ? newSVpv(tmpdir, 0) : NULL; /* * I have no idea how portable mkstemp() is ... NI-S */ - const int fd = mkstemp(SvPVX(sv)); + if (sv) { + /* if TMPDIR is set and not empty, we try that first */ + sv_catpv(sv, tempname + 4); + fd = mkstemp(SvPVX(sv)); + } + if (fd < 0) { + /* 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)); + PerlLIO_unlink(sv ? SvPVX_const(sv) : tempname); } SvREFCNT_dec(sv); # else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */