X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=57a61d92f43db898a90f5c2379e37e0acc93e612;hb=16433fdef2daba65e1e735ef7c169894b2ce7b6a;hp=466dd13ee0b639ad224f238280de1b6d0a74fee8;hpb=1129b882ced9d5881a47214405219a2e6e332a92;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perlio.c b/perlio.c index 466dd13..57a61d9 100644 --- a/perlio.c +++ b/perlio.c @@ -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); @@ -805,19 +805,18 @@ 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); + SAVEBOOL(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++; + PL_in_load_module = TRUE; /* * The two SVs are magically freed by load_module */ Perl_load_module(aTHX_ 0, pkgsv, NULL, layer, NULL); - PL_in_load_module--; LEAVE; return PerlIO_find_layer(aTHX_ name, len, 0); } @@ -832,7 +831,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", @@ -845,7 +844,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", @@ -884,7 +883,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; @@ -979,10 +978,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; } @@ -1016,10 +1014,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: /* @@ -1038,13 +1035,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; } } @@ -1458,8 +1453,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; } @@ -1564,8 +1559,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); } } @@ -1771,10 +1765,7 @@ PerlIO_has_base(PerlIO *f) if (tab) return (tab->Get_base != NULL); - SETERRNO(EINVAL, LIB_INVARG); } - else - SETERRNO(EBADF, SS_IVCHAN); return 0; } @@ -1782,15 +1773,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; } @@ -1803,10 +1793,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; } @@ -1819,10 +1806,7 @@ PerlIO_canset_cnt(PerlIO *f) if (tab) return (tab->Set_ptrcnt != NULL); - SETERRNO(EINVAL, LIB_INVARG); } - else - SETERRNO(EBADF, SS_IVCHAN); return 0; } @@ -2280,8 +2264,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; } @@ -3031,7 +3014,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; } @@ -3129,8 +3114,8 @@ PerlIOStdio_close(pTHX_ PerlIO *f) const int fd = fileno(stdio); int invalidate = 0; IV result = 0; - int saveerr = 0; int dupfd = -1; + dSAVEDERRNO; #ifdef USE_ITHREADS dVAR; #endif @@ -3144,8 +3129,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 */ @@ -3157,7 +3149,7 @@ 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) { #ifdef USE_ITHREADS @@ -3190,13 +3182,15 @@ PerlIOStdio_close(pTHX_ PerlIO *f) } #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 @@ -3358,9 +3352,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; @@ -4115,7 +4109,7 @@ PerlIOBuf_get_base(pTHX_ PerlIO *f) if (!b->buf) { if (!b->bufsiz) b->bufsiz = 4096; - b->buf = Newxz(b->buf,b->bufsiz, STDCHAR); + Newxz(b->buf,b->bufsiz, STDCHAR); if (!b->buf) { b->buf = (STDCHAR *) & b->oneword; b->bufsiz = sizeof(b->oneword); @@ -4631,9 +4625,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; @@ -5161,16 +5153,29 @@ 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 * sv; /* * I have no idea how portable mkstemp() is ... NI-S */ - const int fd = mkstemp(SvPVX(sv)); + if (tmpdir && *tmpdir) { + /* if TMPDIR is set and not empty, we try that first */ + sv = newSVpv(tmpdir, 0); + sv_catpv(sv, tempname + 4); + fd = mkstemp(SvPVX(sv)); + } + if (fd < 0) { + sv = NULL; + /* 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(). */