X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9bab90c0f28bfa909019e7c256fe9c7dfb6ca308..47369ecd8eb3c98b9f75d1e3203e8b85f78eaaec:/perlio.c diff --git a/perlio.c b/perlio.c index ed829e4..963c3e8 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, 2009, 2010, 2011 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 @@ -68,6 +70,12 @@ int mkstemp(char*); #endif +#ifdef VMS +#include +#endif + +#define PerlIO_lockcnt(f) (((PerlIOl*)(f))->head->flags) + /* Call the callback or PerlIOBase, and return failure. */ #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \ if (PerlIOValid(f)) { \ @@ -133,17 +141,6 @@ 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__) - PERL_UNUSED_ARG(iotype); - if (!fflush(fp)) { - if (mode & O_BINARY) - ((FILE *) fp)->_flag |= _IOBIN; - else - ((FILE *) fp)->_flag &= ~_IOBIN; - return 1; - } - return 0; -# else dTHX; PERL_UNUSED_ARG(iotype); #ifdef NETWARE @@ -151,28 +148,10 @@ perlsio_binmode(FILE *fp, int iotype, int mode) #else if (PerlLIO_setmode(fileno(fp), mode) != -1) { #endif -# if defined(WIN32) && defined(__BORLANDC__) - /* - * The translation mode of the stream is maintained independent -of - * the translation mode of the fd in the Borland RTL (heavy - * digging through their runtime sources reveal). User has to -set - * the mode explicitly for the stream (though they don't -document - * this anywhere). GSAR 97-5-24 - */ - fseek(fp, 0L, 0); - if (mode & O_BINARY) - fp->flags |= _F_BIN; - else - fp->flags &= ~_F_BIN; -# endif return 1; } else return 0; -# endif #else # if defined(USEMYBINMODE) dTHX; @@ -331,6 +310,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, return PerlIO_tmpfile(); else { const char *name = SvPV_nolen_const(*args); + if (!IS_SAFE_PATHNAME(*args, "open")) + return NULL; + if (*mode == IoTYPE_NUMERIC) { fd = PerlLIO_open3(name, imode, perm); if (fd >= 0) @@ -464,17 +446,6 @@ PerlIO_findFILE(PerlIO *pio) #include "perliol.h" -/* - * We _MUST_ have if we are using lseek() and may have large - * files - */ -#ifdef I_UNISTD -#include -#endif -#ifdef HAS_MMAP -#include -#endif - void PerlIO_debug(const char *fmt, ...) { @@ -482,7 +453,9 @@ PerlIO_debug(const char *fmt, ...) dSYS; va_start(ap, fmt); if (!PL_perlio_debug_fd) { - if (!PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) { + if (!TAINTING_get && + PerlProc_getuid() == PerlProc_geteuid() && + PerlProc_getgid() == PerlProc_getegid()) { const char * const s = PerlEnv_getenv("PERLIO_DEBUG"); if (s && *s) PL_perlio_debug_fd @@ -496,7 +469,6 @@ PerlIO_debug(const char *fmt, ...) } } if (PL_perlio_debug_fd > 0) { - dTHX; #ifdef USE_ITHREADS const char * const s = CopFILE(PL_curcop); /* Use fixed buffer as sv_catpvf etc. needs SVs */ @@ -525,11 +497,47 @@ PerlIO_debug(const char *fmt, ...) * Inner level routines */ +/* check that the head field of each layer points back to the head */ + +#ifdef DEBUGGING +# define VERIFY_HEAD(f) PerlIO_verify_head(aTHX_ f) +static void +PerlIO_verify_head(pTHX_ PerlIO *f) +{ + PerlIOl *head, *p; + int seen = 0; + if (!PerlIOValid(f)) + return; + p = head = PerlIOBase(f)->head; + assert(p); + do { + assert(p->head == head); + if (p == (PerlIOl*)f) + seen = 1; + p = p->next; + } while (p); + assert(seen); +} +#else +# define VERIFY_HEAD(f) +#endif + + /* * Table of pointers to the PerlIO structs (malloc'ed) */ #define PERLIO_TABLE_SIZE 64 +static void +PerlIO_init_table(pTHX) +{ + if (PL_perlio) + return; + Newxz(PL_perlio, PERLIO_TABLE_SIZE, PerlIOl); +} + + + PerlIO * PerlIO_allocate(pTHX) { @@ -537,24 +545,30 @@ PerlIO_allocate(pTHX) /* * Find a free slot in the table, allocating new table as necessary */ - PerlIO **last; - PerlIO *f; + PerlIOl **last; + PerlIOl *f; last = &PL_perlio; while ((f = *last)) { int i; - last = (PerlIO **) (f); + last = (PerlIOl **) (f); for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (!*++f) { - return f; + if (!((++f)->next)) { + f->flags = 0; /* lockcnt */ + f->tab = NULL; + f->head = f; + return (PerlIO *)f; } } } - Newxz(f,PERLIO_TABLE_SIZE,PerlIO); + Newxz(f,PERLIO_TABLE_SIZE,PerlIOl); if (!f) { return NULL; } - *last = f; - return f + 1; + *last = (PerlIOl*) f++; + f->flags = 0; /* lockcnt */ + f->tab = NULL; + f->head = f; + return (PerlIO*) f; } #undef PerlIO_fdupopen @@ -577,16 +591,16 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) } void -PerlIO_cleantable(pTHX_ PerlIO **tablep) +PerlIO_cleantable(pTHX_ PerlIOl **tablep) { - PerlIO * const table = *tablep; + PerlIOl * const table = *tablep; if (table) { int i; - PerlIO_cleantable(aTHX_(PerlIO **) & (table[0])); + PerlIO_cleantable(aTHX_(PerlIOl **) & (table[0])); for (i = PERLIO_TABLE_SIZE - 1; i > 0; i--) { - PerlIO * const f = table + i; - if (*f) { - PerlIO_close(f); + PerlIOl * const f = table + i; + if (f->next) { + PerlIO_close(&(f->next)); } } Safefree(table); @@ -612,10 +626,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); @@ -669,19 +681,19 @@ void PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param) { #ifdef USE_ITHREADS - PerlIO **table = &proto->Iperlio; - PerlIO *f; + PerlIOl **table = &proto->Iperlio; + PerlIOl *f; PL_perlio = NULL; PL_known_layers = PerlIO_clone_list(aTHX_ proto->Iknown_layers, param); PL_def_layerlist = PerlIO_clone_list(aTHX_ proto->Idef_layerlist, param); - PerlIO_allocate(aTHX); /* root slot is never used */ + PerlIO_init_table(aTHX); PerlIO_debug("Clone %p from %p\n",(void*)aTHX,(void*)proto); while ((f = *table)) { int i; - table = (PerlIO **) (f++); + table = (PerlIOl **) (f++); for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (*f) { - (void) fp_dup(f, 0, param); + if (f->next) { + (void) fp_dup(&(f->next), 0, param); } f++; } @@ -697,19 +709,19 @@ void PerlIO_destruct(pTHX) { dVAR; - PerlIO **table = &PL_perlio; - PerlIO *f; + PerlIOl **table = &PL_perlio; + PerlIOl *f; #ifdef USE_ITHREADS PerlIO_debug("Destruct %p\n",(void*)aTHX); #endif while ((f = *table)) { int i; - table = (PerlIO **) (f++); + table = (PerlIOl **) (f++); for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - PerlIO *x = f; + PerlIO *x = &(f->next); const PerlIOl *l; while ((l = *x)) { - if (l->tab->kind & PERLIO_K_DESTRUCT) { + if (l->tab && l->tab->kind & PERLIO_K_DESTRUCT) { PerlIO_debug("Destruct popping %s\n", l->tab->name); PerlIO_flush(x); PerlIO_pop(aTHX_ x); @@ -727,9 +739,11 @@ void PerlIO_pop(pTHX_ PerlIO *f) { const PerlIOl *l = *f; + VERIFY_HEAD(f); if (l) { - PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, l->tab->name); - if (l->tab->Popped) { + PerlIO_debug("PerlIO_pop f=%p %s\n", (void*)f, + l->tab ? l->tab->name : "(Null)"); + if (l->tab && l->tab->Popped) { /* * If popped returns non-zero do not free its layer structure * it has either done so itself, or it is shared and still in @@ -738,8 +752,16 @@ PerlIO_pop(pTHX_ PerlIO *f) if ((*l->tab->Popped) (aTHX_ f) != 0) return; } - *f = l->next; - Safefree(l); + if (PerlIO_lockcnt(f)) { + /* we're in use; defer freeing the structure */ + PerlIOBase(f)->flags = PERLIO_F_CLEARED; + PerlIOBase(f)->tab = NULL; + } + else { + *f = l->next; + Safefree(l); + } + } } @@ -792,7 +814,8 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) len = strlen(name); for (i = 0; i < PL_known_layers->cur; i++) { PerlIO_funcs * const f = PL_known_layers->array[i].funcs; - if (memEQ(f->name, name, len) && f->name[len] == 0) { + const STRLEN this_len = strlen(f->name); + if (this_len == len && memEQ(f->name, name, len)) { PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f); return f; } @@ -805,19 +828,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 +854,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 +867,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 +906,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; @@ -918,7 +940,7 @@ PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab) XS(XS_PerlIO__Layer__NoWarnings) { - /* This is used as a %SIG{__WARN__} handler to supress warnings + /* This is used as a %SIG{__WARN__} handler to suppress warnings during loading of layers. */ dVAR; @@ -979,16 +1001,15 @@ 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; } do { e++; - } while (isALNUM(*e)); + } while (isWORDCHAR(*e)); llen = e - s; if (*e == '(') { int nesting = 1; @@ -1016,10 +1037,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 +1058,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; } } @@ -1111,7 +1129,7 @@ PERLIO_FUNCS_DECL(PerlIO_remove) = { PERLIO_K_DUMMY | PERLIO_K_UTF8, PerlIOPop_pushed, NULL, - NULL, + PerlIOBase_open, NULL, NULL, NULL, @@ -1140,7 +1158,7 @@ PerlIO_default_layers(pTHX) { dVAR; if (!PL_def_layerlist) { - const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO"); + const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO"); PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix; PL_def_layerlist = PerlIO_list_alloc(aTHX); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix)); @@ -1154,9 +1172,6 @@ PerlIO_default_layers(pTHX) PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_perlio)); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_stdio)); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_crlf)); -#ifdef HAS_MMAP - PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_mmap)); -#endif PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_utf8)); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_remove)); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_byte)); @@ -1205,7 +1220,7 @@ PerlIO_stdstreams(pTHX) { dVAR; if (!PL_perlio) { - PerlIO_allocate(aTHX); + PerlIO_init_table(aTHX); PerlIO_fdopen(0, "Ir" PERLIO_STDTEXT); PerlIO_fdopen(1, "Iw" PERLIO_STDTEXT); PerlIO_fdopen(2, "Iw" PERLIO_STDTEXT); @@ -1215,14 +1230,20 @@ PerlIO_stdstreams(pTHX) PerlIO * PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) { + VERIFY_HEAD(f); if (tab->fsize != sizeof(PerlIO_funcs)) { - mismatch: - Perl_croak(aTHX_ "Layer does not match this perl"); + Perl_croak( aTHX_ + "%s (%"UVuf") does not match %s (%"UVuf")", + "PerlIO layer function table size", (UV)tab->fsize, + "size expected by this perl", (UV)sizeof(PerlIO_funcs) ); } if (tab->size) { PerlIOl *l; if (tab->size < sizeof(PerlIOl)) { - goto mismatch; + Perl_croak( aTHX_ + "%s (%"UVuf") smaller than %s (%"UVuf")", + "PerlIO layer instance size", (UV)tab->size, + "size expected by this perl", (UV)sizeof(PerlIOl) ); } /* Real layer with a data area */ if (f) { @@ -1232,6 +1253,7 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) if (l) { l->next = *f; l->tab = (PerlIO_funcs*) tab; + l->head = ((PerlIOl*)f)->head; *f = l; PerlIO_debug("PerlIO_push f=%p %s %s %p\n", (void*)f, tab->name, @@ -1259,12 +1281,30 @@ PerlIO_push(pTHX_ PerlIO *f, PERLIO_FUNCS_DECL(*tab), const char *mode, SV *arg) return f; } +PerlIO * +PerlIOBase_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, + IV n, const char *mode, int fd, int imode, int perm, + PerlIO *old, int narg, SV **args) +{ + PerlIO_funcs * const tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_layer(aTHX_ 0)); + if (tab && tab->Open) { + PerlIO* ret = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, old, narg, args); + if (ret && PerlIO_push(aTHX_ ret, self, mode, PerlIOArg) == NULL) { + PerlIO_close(ret); + return NULL; + } + return ret; + } + SETERRNO(EINVAL, LIB_INVARG); + return NULL; +} + IV PerlIOBase_binmode(pTHX_ PerlIO *f) { if (PerlIOValid(f)) { /* Is layer suitable for raw stream ? */ - if (PerlIOBase(f)->tab->kind & PERLIO_K_RAW) { + if (PerlIOBase(f)->tab && PerlIOBase(f)->tab->kind & PERLIO_K_RAW) { /* Yes - turn off UTF-8-ness, to undo UTF-8 locale effects */ PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; } @@ -1293,9 +1333,9 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) */ t = f; while (t && (l = *t)) { - if (l->tab->Binmode) { + if (l->tab && 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); @@ -1311,7 +1351,8 @@ PerlIORaw_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) } } if (PerlIOValid(f)) { - PerlIO_debug(":raw f=%p :%s\n", (void*)f, PerlIOBase(f)->tab->name); + PerlIO_debug(":raw f=%p :%s\n", (void*)f, + PerlIOBase(f)->tab ? PerlIOBase(f)->tab->name : "(Null)"); return 0; } } @@ -1340,6 +1381,8 @@ int PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) { int code = 0; + ENTER; + save_scalar(PL_errgv); if (f && names) { PerlIO_list_t * const layers = PerlIO_list_alloc(aTHX); code = PerlIO_parse_layers(aTHX_ layers, names); @@ -1348,6 +1391,7 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) } PerlIO_list_free(aTHX_ layers); } + LEAVE; return code; } @@ -1361,7 +1405,8 @@ int PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) { PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", (void*)f, - (PerlIOBase(f)) ? PerlIOBase(f)->tab->name : "(Null)", + (PerlIOBase(f) && PerlIOBase(f)->tab) ? + PerlIOBase(f)->tab->name : "(Null)", iotype, mode, (names) ? names : "(Null)"); if (names) { @@ -1388,7 +1433,9 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) /* Perhaps we should turn on bottom-most aware layer e.g. Ilya's idea that UNIX TTY could serve */ - if (PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) { + if (PerlIOBase(f)->tab && + PerlIOBase(f)->tab->kind & PERLIO_K_CANCRLF) + { if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) { /* Not in text mode - flush any pending stuff and flip it */ PerlIO_flush(f); @@ -1435,6 +1482,9 @@ Perl_PerlIO_close(pTHX_ PerlIO *f) const int code = PerlIO__close(aTHX_ f); while (PerlIOValid(f)) { PerlIO_pop(aTHX_ f); + if (PerlIO_lockcnt(f)) + /* we're in use; the 'pop' deferred freeing the structure */ + f = PerlIONext(f); } return code; } @@ -1454,12 +1504,13 @@ PerlIO_layer_from_ref(pTHX_ SV *sv) /* * For any scalar type load the handler which is bundled with perl */ - if (SvTYPE(sv) < SVt_PVAV) { + if (SvTYPE(sv) < SVt_PVAV && (!isGV_with_GP(sv) || SvFAKE(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) + /* diag_listed_as: Unknown PerlIO layer "%s" */ + Perl_ck_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"scalar\""); return f; } @@ -1560,12 +1611,11 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, layera = PerlIO_list_alloc(aTHX); while (l) { SV *arg = NULL; - if (l->tab->Getarg) + if (l->tab && l->tab->Getarg) 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); } } @@ -1682,20 +1732,21 @@ Perl_PerlIO_flush(pTHX_ PerlIO *f) else { /* * Is it good API design to do flush-all on NULL, a potentially - * errorneous input? Maybe some magical value (PerlIO* + * erroneous input? Maybe some magical value (PerlIO* * PERLIO_FLUSH_ALL = (PerlIO*)-1;)? Yes, stdio does similar * things on fflush(NULL), but should we be bound by their design * decisions? --jhi */ - PerlIO **table = &PL_perlio; + PerlIOl **table = &PL_perlio; + PerlIOl *ff; int code = 0; - while ((f = *table)) { + while ((ff = *table)) { int i; - table = (PerlIO **) (f++); + table = (PerlIOl **) (ff++); for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (*f && PerlIO_flush(f) != 0) + if (ff->next && PerlIO_flush(&(ff->next)) != 0) code = -1; - f++; + ff++; } } return code; @@ -1706,17 +1757,17 @@ void PerlIOBase_flush_linebuf(pTHX) { dVAR; - PerlIO **table = &PL_perlio; - PerlIO *f; + PerlIOl **table = &PL_perlio; + PerlIOl *f; while ((f = *table)) { int i; - table = (PerlIO **) (f++); + table = (PerlIOl **) (f++); for (i = 1; i < PERLIO_TABLE_SIZE; i++) { - if (*f - && (PerlIOBase(f)-> + if (f->next + && (PerlIOBase(&(f->next))-> flags & (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) == (PERLIO_F_LINEBUF | PERLIO_F_CANWRITE)) - PerlIO_flush(f); + PerlIO_flush(&(f->next)); f++; } } @@ -1771,10 +1822,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 +1830,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 +1850,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 +1863,7 @@ PerlIO_canset_cnt(PerlIO *f) if (tab) return (tab->Set_ptrcnt != NULL); - SETERRNO(EINVAL, LIB_INVARG); } - else - SETERRNO(EBADF, SS_IVCHAN); return 0; } @@ -1876,7 +1917,7 @@ PerlIOUtf8_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PERL_UNUSED_ARG(mode); PERL_UNUSED_ARG(arg); if (PerlIOValid(f)) { - if (tab->kind & PERLIO_K_UTF8) + if (tab && tab->kind & PERLIO_K_UTF8) PerlIOBase(f)->flags |= PERLIO_F_UTF8; else PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; @@ -1889,10 +1930,10 @@ PERLIO_FUNCS_DECL(PerlIO_utf8) = { sizeof(PerlIO_funcs), "utf8", 0, - PERLIO_K_DUMMY | PERLIO_K_UTF8, + PERLIO_K_DUMMY | PERLIO_K_UTF8 | PERLIO_K_MULTIARG, PerlIOUtf8_pushed, NULL, - NULL, + PerlIOBase_open, NULL, NULL, NULL, @@ -1920,10 +1961,10 @@ PERLIO_FUNCS_DECL(PerlIO_byte) = { sizeof(PerlIO_funcs), "bytes", 0, - PERLIO_K_DUMMY, + PERLIO_K_DUMMY | PERLIO_K_MULTIARG, PerlIOUtf8_pushed, NULL, - NULL, + PerlIOBase_open, NULL, NULL, NULL, @@ -1947,20 +1988,6 @@ PERLIO_FUNCS_DECL(PerlIO_byte) = { NULL, /* set_ptrcnt */ }; -PerlIO * -PerlIORaw_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, - IV n, const char *mode, int fd, int imode, int perm, - PerlIO *old, int narg, SV **args) -{ - PerlIO_funcs * const tab = PerlIO_default_btm(); - PERL_UNUSED_ARG(self); - if (tab && tab->Open) - return (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm, - old, narg, args); - SETERRNO(EINVAL, LIB_INVARG); - return NULL; -} - PERLIO_FUNCS_DECL(PerlIO_raw) = { sizeof(PerlIO_funcs), "raw", @@ -1968,7 +1995,7 @@ PERLIO_FUNCS_DECL(PerlIO_raw) = { PERLIO_K_DUMMY, PerlIORaw_pushed, PerlIOBase_popped, - PerlIORaw_open, + PerlIOBase_open, NULL, NULL, NULL, @@ -2045,7 +2072,7 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) l->flags &= ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_TRUNCATE | PERLIO_F_APPEND); - if (tab->Set_ptrcnt != NULL) + if (tab && tab->Set_ptrcnt != NULL) l->flags |= PERLIO_F_FASTGETS; if (mode) { if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT) @@ -2132,7 +2159,7 @@ PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) SSize_t avail = PerlIO_get_cnt(f); SSize_t take = 0; if (avail > 0) - take = ((SSize_t)count < avail) ? (SSize_t)count : avail; + take = (((SSize_t) count >= 0) && ((SSize_t)count < avail)) ? (SSize_t)count : avail; if (take > 0) { STDCHAR *ptr = PerlIO_get_ptr(f); Copy(ptr, buf, take, STDCHAR); @@ -2274,14 +2301,14 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) SV *arg = NULL; char buf[8]; PerlIO_debug("PerlIOBase_dup %s f=%p o=%p param=%p\n", - self->name, (void*)f, (void*)o, (void*)param); - if (self->Getarg) + self ? self->name : "(Null)", + (void*)f, (void*)o, (void*)param); + if (self && 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); + SvREFCNT_dec(arg); } return f; } @@ -2313,10 +2340,7 @@ S_more_refcounted_fds(pTHX_ const int new_fd) { #ifdef USE_ITHREADS MUTEX_UNLOCK(&PL_perlio_mutex); #endif - /* Can't use PerlIO to write as it allocates memory */ - PerlLIO_write(PerlIO_fileno(Perl_error_log), - PL_no_mem, strlen(PL_no_mem)); - my_exit(1); + croak_no_mem(); } PL_perlio_fd_refcnt_size = new_max; @@ -2352,6 +2376,7 @@ PerlIOUnix_refcnt_inc(int fd) PL_perlio_fd_refcnt[fd]++; if (PL_perlio_fd_refcnt[fd] <= 0) { + /* diag_listed_as: refcnt_inc: fd %d%s */ Perl_croak(aTHX_ "refcnt_inc: fd %d: %d <= 0\n", fd, PL_perlio_fd_refcnt[fd]); } @@ -2362,6 +2387,7 @@ PerlIOUnix_refcnt_inc(int fd) MUTEX_UNLOCK(&PL_perlio_mutex); #endif } else { + /* diag_listed_as: refcnt_inc: fd %d%s */ Perl_croak(aTHX_ "refcnt_inc: fd %d < 0\n", fd); } } @@ -2369,7 +2395,6 @@ PerlIOUnix_refcnt_inc(int fd) int PerlIOUnix_refcnt_dec(int fd) { - dTHX; int cnt = 0; if (fd >= 0) { dVAR; @@ -2377,11 +2402,13 @@ PerlIOUnix_refcnt_dec(int fd) MUTEX_LOCK(&PL_perlio_mutex); #endif if (fd >= PL_perlio_fd_refcnt_size) { - Perl_croak(aTHX_ "refcnt_dec: fd %d >= refcnt_size %d\n", + /* diag_listed_as: refcnt_dec: fd %d%s */ + Perl_croak_nocontext("refcnt_dec: fd %d >= refcnt_size %d\n", fd, PL_perlio_fd_refcnt_size); } if (PL_perlio_fd_refcnt[fd] <= 0) { - Perl_croak(aTHX_ "refcnt_dec: fd %d: %d <= 0\n", + /* diag_listed_as: refcnt_dec: fd %d%s */ + Perl_croak_nocontext("refcnt_dec: fd %d: %d <= 0\n", fd, PL_perlio_fd_refcnt[fd]); } cnt = --PL_perlio_fd_refcnt[fd]; @@ -2390,7 +2417,39 @@ PerlIOUnix_refcnt_dec(int fd) MUTEX_UNLOCK(&PL_perlio_mutex); #endif } else { - Perl_croak(aTHX_ "refcnt_dec: fd %d < 0\n", fd); + /* diag_listed_as: refcnt_dec: fd %d%s */ + Perl_croak_nocontext("refcnt_dec: fd %d < 0\n", fd); + } + return cnt; +} + +int +PerlIOUnix_refcnt(int fd) +{ + dTHX; + int cnt = 0; + if (fd >= 0) { + dVAR; +#ifdef USE_ITHREADS + MUTEX_LOCK(&PL_perlio_mutex); +#endif + if (fd >= PL_perlio_fd_refcnt_size) { + /* diag_listed_as: refcnt: fd %d%s */ + Perl_croak(aTHX_ "refcnt: fd %d >= refcnt_size %d\n", + fd, PL_perlio_fd_refcnt_size); + } + if (PL_perlio_fd_refcnt[fd] <= 0) { + /* diag_listed_as: refcnt: fd %d%s */ + Perl_croak(aTHX_ "refcnt: fd %d: %d <= 0\n", + fd, PL_perlio_fd_refcnt[fd]); + } + cnt = PL_perlio_fd_refcnt[fd]; +#ifdef USE_ITHREADS + MUTEX_UNLOCK(&PL_perlio_mutex); +#endif + } else { + /* diag_listed_as: refcnt: fd %d%s */ + Perl_croak(aTHX_ "refcnt: fd %d < 0\n", fd); } return cnt; } @@ -2475,6 +2534,41 @@ typedef struct { int oflags; /* open/fcntl flags */ } PerlIOUnix; +static void +S_lockcnt_dec(pTHX_ const void* f) +{ + PerlIO_lockcnt((PerlIO*)f)--; +} + + +/* call the signal handler, and if that handler happens to clear + * this handle, free what we can and return true */ + +static bool +S_perlio_async_run(pTHX_ PerlIO* f) { + ENTER; + SAVEDESTRUCTOR_X(S_lockcnt_dec, (void*)f); + PerlIO_lockcnt(f)++; + PERL_ASYNC_CHECK(); + if ( !(PerlIOBase(f)->flags & PERLIO_F_CLEARED) ) { + LEAVE; + return 0; + } + /* we've just run some perl-level code that could have done + * anything, including closing the file or clearing this layer. + * If so, free any lower layers that have already been + * cleared, then return an error. */ + while (PerlIOValid(f) && + (PerlIOBase(f)->flags & PERLIO_F_CLEARED)) + { + const PerlIOl *l = *f; + *f = l->next; + Safefree(l); + } + LEAVE; + return 1; +} + int PerlIOUnix_oflags(const char *mode) { @@ -2520,10 +2614,15 @@ PerlIOUnix_oflags(const char *mode) oflags &= ~O_BINARY; mode++; } - /* - * Always open in binary mode - */ - oflags |= O_BINARY; + else { +#ifdef PERLIO_USING_CRLF + /* + * If neither "t" nor "b" was specified, open the file + * in O_BINARY mode. + */ + oflags |= O_BINARY; +#endif + } if (*mode || oflags == -1) { SETERRNO(EINVAL, LIB_INVARG); oflags = -1; @@ -2607,7 +2706,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, int perm, PerlIO *f, int narg, SV **args) { if (PerlIOValid(f)) { - if (PerlIOBase(f)->flags & PERLIO_F_OPEN) + if (PerlIOBase(f)->tab && PerlIOBase(f)->flags & PERLIO_F_OPEN) (*PerlIOBase(f)->tab->Close)(aTHX_ f); } if (narg > 0) { @@ -2615,10 +2714,16 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, mode++; else { imode = PerlIOUnix_oflags(mode); +#ifdef VMS + perm = 0777; /* preserve RMS defaults, ACL inheritance, etc. */ +#else perm = 0666; +#endif } if (imode != -1) { const char *path = SvPV_nolen_const(*args); + if (!IS_SAFE_PATHNAME(*args, "open")) + return NULL; fd = PerlLIO_open3(path, imode, perm); } } @@ -2674,7 +2779,10 @@ SSize_t PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { dVAR; - const int fd = PerlIOSelf(f, PerlIOUnix)->fd; + int fd; + if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ + return -1; + fd = PerlIOSelf(f, PerlIOUnix)->fd; #ifdef PERLIO_STD_SPECIAL if (fd == 0) return PERLIO_STD_IN(fd, vbuf, count); @@ -2697,7 +2805,9 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) } return len; } - PERL_ASYNC_CHECK(); + /* EINTR */ + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; } /*NOTREACHED*/ } @@ -2706,7 +2816,10 @@ SSize_t PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { dVAR; - const int fd = PerlIOSelf(f, PerlIOUnix)->fd; + int fd; + if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ + return -1; + fd = PerlIOSelf(f, PerlIOUnix)->fd; #ifdef PERLIO_STD_SPECIAL if (fd == 1 || fd == 2) return PERLIO_STD_OUT(fd, vbuf, count); @@ -2721,7 +2834,9 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) } return len; } - PERL_ASYNC_CHECK(); + /* EINTR */ + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; } /*NOTREACHED*/ } @@ -2756,7 +2871,9 @@ PerlIOUnix_close(pTHX_ PerlIO *f) code = -1; break; } - PERL_ASYNC_CHECK(); + /* EINTR */ + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; } if (code == 0) { PerlIOBase(f)->flags &= ~PERLIO_F_OPEN; @@ -2921,6 +3038,8 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, const char * const path = SvPV_nolen_const(*args); PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio); FILE *stdio; + if (!IS_SAFE_PATHNAME(*args, "open")) + return NULL; PerlIOUnix_refcnt_dec(fileno(s->stdio)); stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)), s->stdio); @@ -2933,6 +3052,8 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, else { if (narg > 0) { const char * const path = SvPV_nolen_const(*args); + if (!IS_SAFE_PATHNAME(*args, "open")) + return NULL; if (*mode == IoTYPE_NUMERIC) { mode++; fd = PerlLIO_open3(path, imode, perm); @@ -3031,7 +3152,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; } @@ -3095,9 +3218,7 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) f->_file = -1; return 1; # elif defined(WIN32) -# if defined(__BORLANDC__) - f->fd = PerlLIO_dup(fileno(f)); -# elif defined(UNDER_CE) +# if defined(UNDER_CE) /* WIN_CE does not have access to FILE internals, it hardly has FILE structure at all */ @@ -3129,8 +3250,11 @@ 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 #ifdef SOCKS5_VERSION_NAME /* Socks lib overrides close() but stdio isn't linked to that library (though we are) - so we must call close() @@ -3141,8 +3265,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 */ @@ -3154,25 +3285,25 @@ 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 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). + /* 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 duraction of this little manoeuver. 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. + 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. */ @@ -3187,13 +3318,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 @@ -3215,8 +3348,11 @@ SSize_t PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { dVAR; - FILE * const s = PerlIOSelf(f, PerlIOStdio)->stdio; + FILE * s; SSize_t got = 0; + if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ + return -1; + s = PerlIOSelf(f, PerlIOStdio)->stdio; for (;;) { if (count == 1) { STDCHAR *buf = (STDCHAR *) vbuf; @@ -3236,7 +3372,8 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) got = -1; if (got >= 0 || errno != EINTR) break; - PERL_ASYNC_CHECK(); + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; SETERRNO(0,0); /* just in case */ } return got; @@ -3305,12 +3442,15 @@ PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { dVAR; SSize_t got; + if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ + return -1; for (;;) { got = PerlSIO_fwrite(vbuf, 1, count, PerlIOSelf(f, PerlIOStdio)->stdio); if (got >= 0 || errno != EINTR) break; - PERL_ASYNC_CHECK(); + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; SETERRNO(0,0); /* just in case */ } return got; @@ -3355,9 +3495,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; @@ -3472,9 +3612,12 @@ PerlIOStdio_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) IV PerlIOStdio_fill(pTHX_ PerlIO *f) { - FILE * const stdio = PerlIOSelf(f, PerlIOStdio)->stdio; + FILE * stdio; int c; PERL_UNUSED_CONTEXT; + if (PerlIO_lockcnt(f)) /* in use: abort ungracefully */ + return -1; + stdio = PerlIOSelf(f, PerlIOStdio)->stdio; /* * fflush()ing read-only streams can cause trouble on some stdio-s @@ -3489,7 +3632,8 @@ PerlIOStdio_fill(pTHX_ PerlIO *f) break; if (! PerlSIO_ferror(stdio) || errno != EINTR) return EOF; - PERL_ASYNC_CHECK(); + if (PL_sig_pending && S_perlio_async_run(aTHX_ f)) + return -1; SETERRNO(0,0); } @@ -3637,7 +3781,7 @@ PerlIO_findFILE(PerlIO *f) /* Uses fallback "mode" via PerlIO_modestr() in PerlIO_exportFILE */ /* 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 + So we need to undo its reference 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. */ @@ -3659,12 +3803,14 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f) while ((l = *p)) { if (l->tab == &PerlIO_stdio) { PerlIOStdio *s = PerlIOSelf(&l, PerlIOStdio); - if (s->stdio == f) { - dTHX; + if (s->stdio == f) { /* not in a loop */ const int fd = fileno(f); if (fd >= 0) PerlIOUnix_refcnt_dec(fd); - PerlIO_pop(aTHX_ p); + { + dTHX; + PerlIO_pop(aTHX_ p); + } return; } } @@ -3752,6 +3898,21 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, */ PerlLIO_setmode(fd, O_BINARY); #endif +#ifdef VMS + /* Enable line buffering with record-oriented regular files + * so we don't introduce an extraneous record boundary when + * the buffer fills up. + */ + if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { + Stat_t st; + if (PerlLIO_fstat(fd, &st) == 0 + && S_ISREG(st.st_mode) + && (st.st_fab_rfm == FAB$C_VAR + || st.st_fab_rfm == FAB$C_VFC)) { + PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; + } + } +#endif } } } @@ -3940,7 +4101,7 @@ PerlIOBuf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) */ b->posn -= b->bufsiz; } - if (avail > (SSize_t) count) { + if ((SSize_t) count >= 0 && avail > (SSize_t) count) { /* * If we have space for more than count, just move count */ @@ -3990,7 +4151,7 @@ PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) } while (count > 0) { SSize_t avail = b->bufsiz - (b->ptr - b->buf); - if ((SSize_t) count < avail) + if ((SSize_t) count >= 0 && (SSize_t) count < avail) avail = count; if (flushptr > buf && flushptr <= buf + avail) avail = flushptr - buf; @@ -4005,7 +4166,8 @@ PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) PerlIO_flush(f); } if (b->ptr >= (b->buf + b->bufsiz)) - PerlIO_flush(f); + if (PerlIO_flush(f) == -1) + return -1; } if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) PerlIO_flush(f); @@ -4111,8 +4273,8 @@ PerlIOBuf_get_base(pTHX_ PerlIO *f) if (!b->buf) { if (!b->bufsiz) - b->bufsiz = 4096; - b->buf = Newxz(b->buf,b->bufsiz, STDCHAR); + b->bufsiz = PERLIOBUF_DEFAULT_BUFSIZ; + Newxz(b->buf,b->bufsiz, STDCHAR); if (!b->buf) { b->buf = (STDCHAR *) & b->oneword; b->bufsiz = sizeof(b->oneword); @@ -4264,7 +4426,7 @@ PerlIOPending_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { SSize_t avail = PerlIO_get_cnt(f); SSize_t got = 0; - if ((SSize_t)count < avail) + if ((SSize_t) count >= 0 && (SSize_t)count < avail) avail = count; if (avail > 0) got = PerlIOBuf_read(aTHX_ f, vbuf, avail); @@ -4358,12 +4520,10 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) PerlIOBase(f)->flags); #endif { - /* Enable the first CRLF capable layer you can find, but if none - * found, the one we just pushed is fine. This results in at - * any given moment at most one CRLF-capable layer being enabled - * in the whole layer stack. */ + /* If the old top layer is a CRLF layer, reactivate it (if + * necessary) and remove this new layer from the stack */ PerlIO *g = PerlIONext(f); - while (PerlIOValid(g)) { + if (PerlIOValid(g)) { PerlIOl *b = PerlIOBase(g); if (b && b->tab == &PerlIO_crlf) { if (!(b->flags & PERLIO_F_CRLF)) @@ -4371,8 +4531,7 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) S_inherit_utf8_flag(g); PerlIO_pop(aTHX_ f); return code; - } - g = PerlIONext(g); + } } } S_inherit_utf8_flag(f); @@ -4427,6 +4586,8 @@ PerlIOCrlf_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) } } } + if (count > 0) + unread += PerlIOBase_unread(aTHX_ f, (const STDCHAR *) vbuf + unread, count); return unread; } } @@ -4515,7 +4676,7 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) if (c->nl) { ptr = c->nl + 1; if (ptr == b->end && *c->nl == 0xd) { - /* Defered CR at end of buffer case - we lied about count */ + /* Deferred CR at end of buffer case - we lied about count */ ptr--; } } @@ -4533,7 +4694,7 @@ PerlIOCrlf_set_ptrcnt(pTHX_ PerlIO *f, STDCHAR * ptr, SSize_t cnt) IV flags = PerlIOBase(f)->flags; STDCHAR *chk = (c->nl) ? (c->nl+1) : b->end; if (ptr+cnt == c->nl && c->nl+1 == b->end && *c->nl == 0xd) { - /* Defered CR at end of buffer case - we lied about count */ + /* Deferred CR at end of buffer case - we lied about count */ chk--; } chk -= cnt; @@ -4628,9 +4789,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; @@ -4667,297 +4826,6 @@ PERLIO_FUNCS_DECL(PerlIO_crlf) = { PerlIOCrlf_set_ptrcnt, }; -#ifdef HAS_MMAP -/*--------------------------------------------------------------------------------------*/ -/* - * mmap as "buffer" layer - */ - -typedef struct { - PerlIOBuf base; /* PerlIOBuf stuff */ - Mmap_t mptr; /* Mapped address */ - Size_t len; /* mapped length */ - STDCHAR *bbuf; /* malloced buffer if map fails */ -} PerlIOMmap; - -IV -PerlIOMmap_map(pTHX_ PerlIO *f) -{ - dVAR; - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - const IV flags = PerlIOBase(f)->flags; - IV code = 0; - if (m->len) - abort(); - if (flags & PERLIO_F_CANREAD) { - PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); - const int fd = PerlIO_fileno(f); - Stat_t st; - code = Fstat(fd, &st); - if (code == 0 && S_ISREG(st.st_mode)) { - SSize_t len = st.st_size - b->posn; - if (len > 0) { - Off_t posn; - if (PL_mmap_page_size <= 0) - Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, - PL_mmap_page_size); - if (b->posn < 0) { - /* - * This is a hack - should never happen - open should - * have set it ! - */ - b->posn = PerlIO_tell(PerlIONext(f)); - } - posn = (b->posn / PL_mmap_page_size) * PL_mmap_page_size; - len = st.st_size - posn; - m->mptr = (Mmap_t)mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn); - if (m->mptr && m->mptr != (Mmap_t) - 1) { -#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL) - madvise(m->mptr, len, MADV_SEQUENTIAL); -#endif -#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED) - madvise(m->mptr, len, MADV_WILLNEED); -#endif - PerlIOBase(f)->flags = - (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF; - b->end = ((STDCHAR *) m->mptr) + len; - b->buf = ((STDCHAR *) m->mptr) + (b->posn - posn); - b->ptr = b->buf; - m->len = len; - } - else { - b->buf = NULL; - } - } - else { - PerlIOBase(f)->flags = - flags | PERLIO_F_EOF | PERLIO_F_RDBUF; - b->buf = NULL; - b->ptr = b->end = b->ptr; - code = -1; - } - } - } - return code; -} - -IV -PerlIOMmap_unmap(pTHX_ PerlIO *f) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - IV code = 0; - if (m->len) { - PerlIOBuf * const b = &m->base; - if (b->buf) { - /* The munmap address argument is tricky: depending on the - * standard it is either "void *" or "caddr_t" (which is - * usually "char *" (signed or unsigned). If we cast it - * to "void *", those that have it caddr_t and an uptight - * C++ compiler, will freak out. But casting it as char* - * should work. Maybe. (Using Mmap_t figured out by - * Configure doesn't always work, apparently.) */ - code = munmap((char*)m->mptr, m->len); - b->buf = NULL; - m->len = 0; - m->mptr = NULL; - if (PerlIO_seek(PerlIONext(f), b->posn, SEEK_SET) != 0) - code = -1; - } - b->ptr = b->end = b->buf; - PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); - } - return code; -} - -STDCHAR * -PerlIOMmap_get_base(pTHX_ PerlIO *f) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - PerlIOBuf * const b = &m->base; - if (b->buf && (PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { - /* - * Already have a readbuffer in progress - */ - return b->buf; - } - if (b->buf) { - /* - * We have a write buffer or flushed PerlIOBuf read buffer - */ - m->bbuf = b->buf; /* save it in case we need it again */ - b->buf = NULL; /* Clear to trigger below */ - } - if (!b->buf) { - PerlIOMmap_map(aTHX_ f); /* Try and map it */ - if (!b->buf) { - /* - * Map did not work - recover PerlIOBuf buffer if we have one - */ - b->buf = m->bbuf; - } - } - b->ptr = b->end = b->buf; - if (b->buf) - return b->buf; - return PerlIOBuf_get_base(aTHX_ f); -} - -SSize_t -PerlIOMmap_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - PerlIOBuf * const b = &m->base; - if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) - PerlIO_flush(f); - if (b->ptr && (b->ptr - count) >= b->buf - && memEQ(b->ptr - count, vbuf, count)) { - b->ptr -= count; - PerlIOBase(f)->flags &= ~PERLIO_F_EOF; - return count; - } - if (m->len) { - /* - * Loose the unwritable mapped buffer - */ - PerlIO_flush(f); - /* - * If flush took the "buffer" see if we have one from before - */ - if (!b->buf && m->bbuf) - b->buf = m->bbuf; - if (!b->buf) { - PerlIOBuf_get_base(aTHX_ f); - m->bbuf = b->buf; - } - } - return PerlIOBuf_unread(aTHX_ f, vbuf, count); -} - -SSize_t -PerlIOMmap_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - PerlIOBuf * const b = &m->base; - - if (!b->buf || !(PerlIOBase(f)->flags & PERLIO_F_WRBUF)) { - /* - * No, or wrong sort of, buffer - */ - if (m->len) { - if (PerlIOMmap_unmap(aTHX_ f) != 0) - return 0; - } - /* - * If unmap took the "buffer" see if we have one from before - */ - if (!b->buf && m->bbuf) - b->buf = m->bbuf; - if (!b->buf) { - PerlIOBuf_get_base(aTHX_ f); - m->bbuf = b->buf; - } - } - return PerlIOBuf_write(aTHX_ f, vbuf, count); -} - -IV -PerlIOMmap_flush(pTHX_ PerlIO *f) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - PerlIOBuf * const b = &m->base; - IV code = PerlIOBuf_flush(aTHX_ f); - /* - * Now we are "synced" at PerlIOBuf level - */ - if (b->buf) { - if (m->len) { - /* - * Unmap the buffer - */ - if (PerlIOMmap_unmap(aTHX_ f) != 0) - code = -1; - } - else { - /* - * We seem to have a PerlIOBuf buffer which was not mapped - * remember it in case we need one later - */ - m->bbuf = b->buf; - } - } - return code; -} - -IV -PerlIOMmap_fill(pTHX_ PerlIO *f) -{ - PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf); - IV code = PerlIO_flush(f); - if (code == 0 && !b->buf) { - code = PerlIOMmap_map(aTHX_ f); - } - if (code == 0 && !(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { - code = PerlIOBuf_fill(aTHX_ f); - } - return code; -} - -IV -PerlIOMmap_close(pTHX_ PerlIO *f) -{ - PerlIOMmap * const m = PerlIOSelf(f, PerlIOMmap); - PerlIOBuf * const b = &m->base; - IV code = PerlIO_flush(f); - if (m->bbuf) { - b->buf = m->bbuf; - m->bbuf = NULL; - b->ptr = b->end = b->buf; - } - if (PerlIOBuf_close(aTHX_ f) != 0) - code = -1; - return code; -} - -PerlIO * -PerlIOMmap_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) -{ - return PerlIOBase_dup(aTHX_ f, o, param, flags); -} - - -PERLIO_FUNCS_DECL(PerlIO_mmap) = { - sizeof(PerlIO_funcs), - "mmap", - sizeof(PerlIOMmap), - PERLIO_K_BUFFERED|PERLIO_K_RAW, - PerlIOBuf_pushed, - PerlIOBuf_popped, - PerlIOBuf_open, - PerlIOBase_binmode, /* binmode */ - NULL, - PerlIOBase_fileno, - PerlIOMmap_dup, - PerlIOBuf_read, - PerlIOMmap_unread, - PerlIOMmap_write, - PerlIOBuf_seek, - PerlIOBuf_tell, - PerlIOBuf_close, - PerlIOMmap_flush, - PerlIOMmap_fill, - PerlIOBase_eof, - PerlIOBase_error, - PerlIOBase_clearerr, - PerlIOBase_setlinebuf, - PerlIOMmap_get_base, - PerlIOBuf_bufsiz, - PerlIOBuf_get_ptr, - PerlIOBuf_get_cnt, - PerlIOBuf_set_ptrcnt, -}; - -#endif /* HAS_MMAP */ - PerlIO * Perl_PerlIO_stdin(pTHX) { @@ -4965,7 +4833,7 @@ Perl_PerlIO_stdin(pTHX) if (!PL_perlio) { PerlIO_stdstreams(aTHX); } - return &PL_perlio[1]; + return (PerlIO*)&PL_perlio[1]; } PerlIO * @@ -4975,7 +4843,7 @@ Perl_PerlIO_stdout(pTHX) if (!PL_perlio) { PerlIO_stdstreams(aTHX); } - return &PL_perlio[2]; + return (PerlIO*)&PL_perlio[2]; } PerlIO * @@ -4985,7 +4853,7 @@ Perl_PerlIO_stderr(pTHX) if (!PL_perlio) { PerlIO_stdstreams(aTHX); } - return &PL_perlio[3]; + return (PerlIO*)&PL_perlio[3]; } /*--------------------------------------------------------------------------------------*/ @@ -4993,8 +4861,8 @@ Perl_PerlIO_stderr(pTHX) char * PerlIO_getname(PerlIO *f, char *buf) { - dTHX; #ifdef VMS + dTHX; char *name = NULL; bool exported = FALSE; FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; @@ -5010,7 +4878,7 @@ PerlIO_getname(PerlIO *f, char *buf) #else PERL_UNUSED_ARG(f); PERL_UNUSED_ARG(buf); - Perl_croak(aTHX_ "Don't know how to get file name"); + Perl_croak_nocontext("Don't know how to get file name"); return NULL; #endif } @@ -5150,7 +5018,9 @@ PerlIO_stdoutf(const char *fmt, ...) PerlIO * PerlIO_tmpfile(void) { +#ifndef WIN32 dTHX; +#endif PerlIO *f = NULL; #ifdef WIN32 const int fd = win32_tmpfd(); @@ -5158,16 +5028,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 = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR"); + SV * sv = NULL; /* * 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(). */ @@ -5215,8 +5098,7 @@ Perl_PerlIO_context_layers(pTHX_ const char *mode) if (!direction) return NULL; - layers = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, - 0, direction, 5, 0, 0); + layers = cop_hints_fetch_pvn(PL_curcop, direction, 5, 0, 0); assert(layers); return SvOK(layers) ? SvPV_nolen_const(layers) : NULL; @@ -5228,9 +5110,9 @@ Perl_PerlIO_context_layers(pTHX_ const char *mode) int PerlIO_setpos(PerlIO *f, SV *pos) { - dTHX; if (SvOK(pos)) { STRLEN len; + dTHX; const Off_t * const posn = (Off_t *) SvPV(pos, len); if (f && len == sizeof(Off_t)) return PerlIO_seek(f, *posn, SEEK_SET); @@ -5342,8 +5224,8 @@ PerlIO_sprintf(char *s, int n, const char *fmt, ...) * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */