X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=2f5373c20fab857fa572575a8d409f43fae10f01;hb=e1ec3a884f8d8c64eb7e391b2a363f47cbeed570;hp=ac9887d751f25710374656825f1d7365b0db6efb;hpb=7fc811cca11d30db90c233d254557669191be8d8;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perlio.c b/perlio.c index ac9887d..2f5373c 100644 --- a/perlio.c +++ b/perlio.c @@ -1,5 +1,5 @@ /* - * perlio.c Copyright (c) 1996-2002, Nick Ing-Simmons You may distribute + * perlio.c Copyright (c) 1996-2005, Nick Ing-Simmons You may distribute * under the terms of either the GNU General Public License or the * Artistic License, as specified in the README file. */ @@ -9,6 +9,12 @@ * over passes, and through long dales, and across many streams. */ +/* This file contains the functions needed to implement PerlIO, which + * is Perl's private replacement for the C stdio library. This is used + * by default unless you compile with -Uuseperlio or run with + * PERLIO=:stdio (but don't do this unless you know what you're doing) + */ + /* * If we have ActivePerl-like PERL_IMPLICIT_SYS then we need a dTHX to get * at the dispatch tables, even when we do not need it for other reasons. @@ -50,6 +56,11 @@ #include "XSUB.h" +#ifdef __Lynx__ +/* Missing proto on LynxOS */ +int mkstemp(char*); +#endif + /* Call the callback or PerlIOBase, and return failure. */ #define Perl_PerlIO_or_Base(f, callback, base, failure, args) \ if (PerlIOValid(f)) { \ @@ -288,7 +299,7 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, return PerlIO_tmpfile(); else { char *name = SvPV_nolen(*args); - if (*mode == '#') { + if (*mode == IoTYPE_NUMERIC) { fd = PerlLIO_open3(name, imode, perm); if (fd >= 0) return PerlIO_fdopen(fd, (char *) mode + 1); @@ -443,7 +454,7 @@ PerlIO_debug(const char *fmt, ...) va_list ap; dSYS; va_start(ap, fmt); - if (!dbg) { + if (!dbg && !PL_tainting && PL_uid == PL_euid && PL_gid == PL_egid) { char *s = PerlEnv_getenv("PERLIO_DEBUG"); if (s && *s) dbg = PerlLIO_open3(s, O_WRONLY | O_CREAT | O_APPEND, 0666); @@ -452,21 +463,20 @@ PerlIO_debug(const char *fmt, ...) } if (dbg > 0) { dTHX; + const char *s; #ifdef USE_ITHREADS /* Use fixed buffer as sv_catpvf etc. needs SVs */ char buffer[1024]; - char *s; STRLEN len; s = CopFILE(PL_curcop); if (!s) s = "(none)"; - sprintf(buffer, "%s:%" IVdf " ", s, (IV) CopLINE(PL_curcop)); + sprintf(buffer, "%.40s:%" IVdf " ", s, (IV) CopLINE(PL_curcop)); len = strlen(buffer); vsprintf(buffer+len, fmt, ap); PerlLIO_write(dbg, buffer, strlen(buffer)); #else SV *sv = newSVpvn("", 0); - char *s; STRLEN len; s = CopFILE(PL_curcop); if (!s) @@ -599,7 +609,7 @@ PerlIO_list_push(pTHX_ PerlIO_list_t *list, PerlIO_funcs *funcs, SV *arg) p = &(list->array[list->cur++]); p->funcs = funcs; if ((p->arg = arg)) { - SvREFCNT_inc(arg); + (void)SvREFCNT_inc(arg); } } @@ -735,7 +745,7 @@ 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 *f = PL_known_layers->array[i].funcs; - if (memEQ(f->name, name, len)) { + if (memEQ(f->name, name, len) && f->name[len] == 0) { PerlIO_debug("%.*s => %p\n", (int) len, name, (void*)f); return f; } @@ -916,7 +926,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) char q = ((*s == '\'') ? '"' : '\''); if (ckWARN(WARN_LAYER)) Perl_warner(aTHX_ packWARN(WARN_LAYER), - "perlio: invalid separator character %c%c%c in layer specification list %s", + "Invalid separator character %c%c%c in PerlIO layer specification %s", q, *s, q, s); SETERRNO(EINVAL, LIB_INVARG); return -1; @@ -953,7 +963,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) e--; if (ckWARN(WARN_LAYER)) Perl_warner(aTHX_ packWARN(WARN_LAYER), - "perlio: argument list not closed for layer \"%.*s\"", + "Argument list not closed for PerlIO layer \"%.*s\"", (int) (e - s), s); return -1; default: @@ -976,7 +986,7 @@ PerlIO_parse_layers(pTHX_ PerlIO_list_t *av, const char *names) } else { if (warn_layer) - Perl_warner(aTHX_ packWARN(WARN_LAYER), "perlio: unknown layer \"%.*s\"", + Perl_warner(aTHX_ packWARN(WARN_LAYER), "Unknown PerlIO layer \"%.*s\"", (int) llen, s); return -1; } @@ -1070,7 +1080,7 @@ PerlIO_default_layers(pTHX) PerlIO_funcs *osLayer = &PerlIO_unix; PL_def_layerlist = PerlIO_list_alloc(aTHX); PerlIO_define_layer(aTHX_ & PerlIO_unix); -#if defined(WIN32) && !defined(UNDER_CE) +#if defined(WIN32) PerlIO_define_layer(aTHX_ & PerlIO_win32); #if 0 osLayer = &PerlIO_win32; @@ -1960,7 +1970,7 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) if (tab->Set_ptrcnt != NULL) l->flags |= PERLIO_F_FASTGETS; if (mode) { - if (*mode == '#' || *mode == 'I') + if (*mode == IoTYPE_NUMERIC || *mode == IoTYPE_IMPLICIT) mode++; switch (*mode++) { case 'r': @@ -2033,8 +2043,11 @@ PerlIOBase_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) { STDCHAR *buf = (STDCHAR *) vbuf; if (f) { - if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) + if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + SETERRNO(EBADF, SS_IVCHAN); return 0; + } while (count > 0) { SSize_t avail = PerlIO_get_cnt(f); SSize_t take = 0; @@ -2273,7 +2286,7 @@ int PerlIOUnix_oflags(const char *mode) { int oflags = -1; - if (*mode == 'I' || *mode == '#') + if (*mode == IoTYPE_IMPLICIT || *mode == IoTYPE_NUMERIC) mode++; switch (*mode) { case 'r': @@ -2372,6 +2385,28 @@ PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) return code; } +IV +PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence) +{ + int fd = PerlIOSelf(f, PerlIOUnix)->fd; + Off_t new; + if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) { +#ifdef ESPIPE + SETERRNO(ESPIPE, LIB_INVARG); +#else + SETERRNO(EINVAL, LIB_INVARG); +#endif + return -1; + } + new = PerlLIO_lseek(fd, offset, whence); + if (new == (Off_t) - 1) + { + return -1; + } + PerlIOBase(f)->flags &= ~PERLIO_F_EOF; + return 0; +} + PerlIO * PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, IV n, const char *mode, int fd, int imode, @@ -2383,7 +2418,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, } if (narg > 0) { char *path = SvPV_nolen(*args); - if (*mode == '#') + if (*mode == IoTYPE_NUMERIC) mode++; else { imode = PerlIOUnix_oflags(mode); @@ -2394,7 +2429,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, } } if (fd >= 0) { - if (*mode == 'I') + if (*mode == IoTYPE_IMPLICIT) mode++; if (!f) { f = PerlIO_allocate(aTHX); @@ -2406,6 +2441,8 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, } PerlIOUnix_setfd(aTHX_ f, fd, imode); PerlIOBase(f)->flags |= PERLIO_F_OPEN; + if (*mode == IoTYPE_APPEND) + PerlIOUnix_seek(aTHX_ f, 0, SEEK_END); return f; } else { @@ -2482,28 +2519,6 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) } } -IV -PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence) -{ - int fd = PerlIOSelf(f, PerlIOUnix)->fd; - Off_t new; - if (PerlIOBase(f)->flags & PERLIO_F_NOTREG) { -#ifdef ESPIPE - SETERRNO(ESPIPE, LIB_INVARG); -#else - SETERRNO(EINVAL, LIB_INVARG); -#endif - return -1; - } - new = PerlLIO_lseek(fd, offset, whence); - if (new == (Off_t) - 1) - { - return -1; - } - PerlIOBase(f)->flags &= ~PERLIO_F_EOF; - return 0; -} - Off_t PerlIOUnix_tell(pTHX_ PerlIO *f) { @@ -2603,10 +2618,12 @@ char * PerlIOStdio_mode(const char *mode, char *tmode) { char *ret = tmode; - while (*mode) { - *tmode++ = *mode++; + if (mode) { + while (*mode) { + *tmode++ = *mode++; + } } -#ifdef PERLIO_USING_CRLF +#if defined(PERLIO_USING_CRLF) || defined(__CYGWIN__) *tmode++ = 'b'; #endif *tmode = '\0'; @@ -2702,20 +2719,28 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, else { if (narg > 0) { char *path = SvPV_nolen(*args); - if (*mode == '#') { + if (*mode == IoTYPE_NUMERIC) { mode++; fd = PerlLIO_open3(path, imode, perm); } else { - FILE *stdio = PerlSIO_fopen(path, mode); + FILE *stdio; + bool appended = FALSE; +#ifdef __CYGWIN__ + /* Cygwin wants its 'b' early. */ + appended = TRUE; + mode = PerlIOStdio_mode(mode, tmode); +#endif + stdio = PerlSIO_fopen(path, mode); if (stdio) { PerlIOStdio *s; if (!f) { f = PerlIO_allocate(aTHX); } - if ((f = PerlIO_push(aTHX_ f, self, - (mode = PerlIOStdio_mode(mode, tmode)), - PerlIOArg))) { + if (!appended) + mode = PerlIOStdio_mode(mode, tmode); + f = PerlIO_push(aTHX_ f, self, mode, PerlIOArg); + if (f) { s = PerlIOSelf(f, PerlIOStdio); s->stdio = stdio; PerlIOUnix_refcnt_inc(fileno(s->stdio)); @@ -2730,7 +2755,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, if (fd >= 0) { FILE *stdio = NULL; int init = 0; - if (*mode == 'I') { + if (*mode == IoTYPE_IMPLICIT) { init = 1; mode++; } @@ -2804,7 +2829,11 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) /* XXX this could use PerlIO_canset_fileno() and * PerlIO_set_fileno() support from Configure */ -# if defined(__GLIBC__) +# if defined(__UCLIBC__) + /* uClibc must come before glibc because it defines __GLIBC__ as well. */ + f->__filedes = -1; + return 1; +# elif defined(__GLIBC__) /* There may be a better way for GLIBC: - libio.h defines a flag to not close() on cleanup */ @@ -2855,6 +2884,17 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) */ f->_file = -1; return 1; +# elif defined(__OpenBSD__) + /* There may be a better way on OpenBSD: + - we could insert a dummy func in the _close function entry + f->_close = (int (*)(void *)) dummy_close; + */ + f->_file = -1; + return 1; +# elif defined(__EMX__) + /* f->_flags &= ~_IOOPEN; */ /* Will leak stream->_buffer */ + f->_handle = -1; + return 1; # elif defined(__CYGWIN__) /* There may be a better way on CYGWIN: - we could insert a dummy func in the _close function entry @@ -2977,6 +3017,8 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) } else got = PerlSIO_fread(vbuf, 1, count, s); + if (got == 0 && PerlSIO_ferror(s)) + got = -1; if (got >= 0 || errno != EINTR) break; PERL_ASYNC_CHECK(); @@ -3323,10 +3365,11 @@ PerlIO_exportFILE(PerlIO * f, const char *mode) stdio = PerlSIO_fdopen(PerlIO_fileno(f), mode); if (stdio) { PerlIOl *l = *f; + PerlIO *f2; /* De-link any lower layers so new :stdio sticks */ *f = NULL; - if ((f = PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv))) { - PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio); + if ((f2 = PerlIO_push(aTHX_ f, &PerlIO_stdio, buf, Nullsv))) { + PerlIOStdio *s = PerlIOSelf((f = f2), PerlIOStdio); s->stdio = stdio; /* Link previous lower layers under new one */ *PerlIONext(f) = l; @@ -3404,9 +3447,12 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, { if (PerlIOValid(f)) { PerlIO *next = PerlIONext(f); - PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab); - next = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm, - next, narg, args); + PerlIO_funcs *tab = + PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIOBase(next)->tab); + if (tab && tab->Open) + next = + (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, + next, narg, args); if (!next || (*PerlIOBase(f)->tab->Pushed) (aTHX_ f, mode, PerlIOArg, self) != 0) { return NULL; } @@ -3414,14 +3460,17 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, else { PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n - 1, PerlIO_default_btm()); int init = 0; - if (*mode == 'I') { + if (*mode == IoTYPE_IMPLICIT) { init = 1; /* * mode++; */ } - f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm, - f, narg, args); + if (tab && tab->Open) + f = (*tab->Open)(aTHX_ tab, layers, n - 1, mode, fd, imode, perm, + f, narg, args); + else + SETERRNO(EINVAL, LIB_INVARG); if (f) { if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) { /* @@ -3658,6 +3707,7 @@ PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) { PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); const STDCHAR *buf = (const STDCHAR *) vbuf; + const STDCHAR *flushptr = buf; Size_t written = 0; if (!b->buf) PerlIO_get_base(f); @@ -3668,32 +3718,26 @@ PerlIOBuf_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) return 0; } } + if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { + flushptr = buf + count; + while (flushptr > buf && *(flushptr - 1) != '\n') + --flushptr; + } while (count > 0) { SSize_t avail = b->bufsiz - (b->ptr - b->buf); if ((SSize_t) count < avail) avail = count; + if (flushptr > buf && flushptr <= buf + avail) + avail = flushptr - buf; PerlIOBase(f)->flags |= PERLIO_F_WRBUF; - if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) { - while (avail > 0) { - int ch = *buf++; - *(b->ptr)++ = ch; - count--; - avail--; - written++; - if (ch == '\n') { - PerlIO_flush(f); - break; - } - } - } - else { - if (avail) { - Copy(buf, b->ptr, avail, STDCHAR); - count -= avail; - buf += avail; - written += avail; - b->ptr += avail; - } + if (avail) { + Copy(buf, b->ptr, avail, STDCHAR); + count -= avail; + buf += avail; + written += avail; + b->ptr += avail; + if (buf == flushptr) + PerlIO_flush(f); } if (b->ptr >= (b->buf + b->bufsiz)) PerlIO_flush(f); @@ -4026,6 +4070,23 @@ PerlIOCrlf_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) f, PerlIOBase(f)->tab->name, (mode) ? mode : "(Null)", 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. */ + PerlIO *g = PerlIONext(f); + while (g && *g) { + PerlIOl *b = PerlIOBase(g); + if (b && b->tab == &PerlIO_crlf) { + if (!(b->flags & PERLIO_F_CRLF)) + b->flags |= PERLIO_F_CRLF; + PerlIO_pop(aTHX_ f); + return code; + } + g = PerlIONext(g); + } + } return code; } @@ -4668,9 +4729,16 @@ PerlIO_getname(PerlIO *f, char *buf) dTHX; char *name = NULL; #ifdef VMS + bool exported = FALSE; FILE *stdio = PerlIOSelf(f, PerlIOStdio)->stdio; - if (stdio) + if (!stdio) { + stdio = PerlIO_exportFILE(f,0); + exported = TRUE; + } + if (stdio) { name = fgetname(stdio, buf); + if (exported) PerlIO_releaseFILE(f,stdio); + } #else Perl_croak(aTHX_ "Don't know how to get file name"); #endif @@ -4817,40 +4885,39 @@ PerlIO_tmpfile(void) dTHX; PerlIO *f = NULL; int fd = -1; - GV *gv = gv_fetchpv("File::Temp::tempfile", FALSE, SVt_PVCV); - - if (!gv) { - ENTER; - Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, - newSVpvn("File::Temp", 10), Nullsv, Nullsv, Nullsv); - gv = gv_fetchpv("File::Temp::tempfile", FALSE, SVt_PVCV); - GvIMPORTED_CV_on(gv); - LEAVE; - } - - if (gv && GvCV(gv)) { - dSP; - ENTER; - SAVETMPS; - PUSHMARK(SP); - PUTBACK; - if (call_sv((SV*)GvCV(gv), G_SCALAR)) { - GV *gv = (GV*)SvRV(newSVsv(*PL_stack_sp--)); - IO *io = gv ? GvIO(gv) : 0; - fd = io ? PerlIO_fileno(IoIFP(io)) : -1; - } - SPAGAIN; - PUTBACK; - FREETMPS; - LEAVE; - } - +#ifdef WIN32 + fd = win32_tmpfd(); + if (fd >= 0) + f = PerlIO_fdopen(fd, "w+b"); +#else /* WIN32 */ +# if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2) + SV *sv = newSVpv("/tmp/PerlIO_XXXXXX", 0); + + /* + * I have no idea how portable mkstemp() is ... NI-S + */ + fd = mkstemp(SvPVX(sv)); if (fd >= 0) { f = PerlIO_fdopen(fd, "w+"); if (f) - PerlIOBase(f)->flags |= PERLIO_F_TEMP; + PerlIOBase(f)->flags |= PERLIO_F_TEMP; + PerlLIO_unlink(SvPVX(sv)); + SvREFCNT_dec(sv); } +# else /* !HAS_MKSTEMP, fallback to stdio tmpfile(). */ + FILE *stdio = PerlSIO_tmpfile(); + if (stdio) { + if ((f = PerlIO_push(aTHX_(PerlIO_allocate(aTHX)), + &PerlIO_stdio, "w+", Nullsv))) { + PerlIOStdio *s = PerlIOSelf(f, PerlIOStdio); + + if (s) + s->stdio = stdio; + } + } +# endif /* else HAS_MKSTEMP */ +#endif /* else WIN32 */ return f; }