X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=466bd17d5d54138e68d35f1575dfbd983ec45b15;hb=8dd2f9d43efcb9beb9eed67526a7688deb2a8269;hp=2e11ab6d70d2ad4ee3d384cf7c618996b53bb216;hpb=ad67ff794f974abe591ae9d905453c24e3677bb6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perlio.c b/perlio.c index 2e11ab6..466bd17 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-2004, 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); @@ -430,6 +441,11 @@ PerlIO_findFILE(PerlIO *pio) #include #endif +/* + * Why is this here - not in perlio.h? RMB + */ +void PerlIO_debug(const char *fmt, ...) + __attribute__format__(__printf__, 1, 2); void PerlIO_debug(const char *fmt, ...) @@ -730,7 +746,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; } @@ -911,7 +927,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; @@ -948,7 +964,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: @@ -971,7 +987,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; } @@ -1017,27 +1033,6 @@ PerlIO_layer_fetch(pTHX_ PerlIO_list_t *av, IV n, PerlIO_funcs *def) return def; } -PerlIO * -PerlIO_syslayer(pTHX_ PerlIO *f) -{ - if (PerlIOValid(f)) { - PerlIOl *l; - while (*PerlIONext(f)) { - f = PerlIONext(f); - } - l = *f; -#if 0 - Perl_warn(aTHX_ "syslayer %s",l->tab->name); -#endif - return f; - } - else { - SETERRNO(EBADF, SS_IVCHAN); - return NULL; - } -} - - IV PerlIOPop_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) { @@ -1086,7 +1081,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; @@ -1976,7 +1971,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': @@ -2021,10 +2016,6 @@ PerlIOBase_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) f, PerlIOBase(f)->tab->name, (omode) ? omode : "(Null)", l->flags, PerlIO_modestr(f, temp)); #endif - if (l->next) { - l->flags |= l->next->flags & - (PERLIO_F_TTY | PERLIO_F_NOTREG | PERLIO_F_SOCKET); - } return 0; } @@ -2053,8 +2044,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; @@ -2293,7 +2287,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': @@ -2355,16 +2349,9 @@ static void PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode) { PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix); - -#if 1 || defined(WIN32) || defined(HAS_SOCKET) && \ - (defined(PERL_SOCK_SYSREAD_IS_RECV) || \ - defined(PERL_SOCK_SYSWRITE_IS_SEND)) +#if defined(WIN32) Stat_t st; if (PerlLIO_fstat(fd, &st) == 0) { -#if defined(WIN32) - /* WIN32 needs to know about non-regular files - as only regular files can be lseek()ed - */ if (!S_ISREG(st.st_mode)) { PerlIO_debug("%d is not regular file\n",fd); PerlIOBase(f)->flags |= PERLIO_F_NOTREG; @@ -2372,32 +2359,8 @@ PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode) else { PerlIO_debug("%d _is_ a regular file\n",fd); } -#endif - /* If read/write are to be mapped to recv/send we need - to know this is a socket. - Lifted from code in doio.c that handles socket detection on dup - */ -#ifndef PERL_MICRO - if (S_ISSOCK(st.st_mode)) - PerlIOBase(f)->flags |= PERLIO_F_SOCKET; - else if ( -#ifdef S_IFMT - !(st.st_mode & S_IFMT) -#else - !st.st_mode -#endif - ) { - char tmpbuf[256]; - Sock_size_t buflen = sizeof tmpbuf; - if (PerlSock_getsockname(fd, (struct sockaddr *)tmpbuf, &buflen) >= 0 - || errno != ENOTSOCK) - PerlIOBase(f)->flags |= PERLIO_F_SOCKET; /* some OS's return 0 on fstat()ed socket */ - /* but some return 0 for streams too, sigh */ - } -#endif /* !PERL_MICRO */ } -#endif /* HAS_SOCKET ... */ - +#endif s->fd = fd; s->oflags = imode; PerlIOUnix_refcnt_inc(fd); @@ -2423,6 +2386,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, @@ -2434,7 +2419,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); @@ -2445,7 +2430,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); @@ -2457,6 +2442,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 { @@ -2498,16 +2485,7 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) return 0; } while (1) { - SSize_t len; -#ifdef PERL_SOCK_SYSREAD_IS_RECV - if (PerlIOBase(f)->flags & PERLIO_F_SOCKET) { - len = PerlSock_recv(fd, vbuf, count, 0); - } - else -#endif - { - len = PerlLIO_read(fd, vbuf, count); - } + SSize_t len = PerlLIO_read(fd, vbuf, count); if (len >= 0 || errno != EINTR) { if (len < 0) { if (errno != EAGAIN) { @@ -2542,28 +2520,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) { @@ -2663,10 +2619,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'; @@ -2762,20 +2720,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)); @@ -2790,7 +2756,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++; } @@ -2915,6 +2881,10 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) */ 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 @@ -3037,6 +3007,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(); @@ -3383,10 +3355,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; @@ -3464,9 +3437,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; } @@ -3474,14 +3450,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) { /* @@ -3718,6 +3697,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); @@ -3728,32 +3708,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); @@ -4086,6 +4060,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; } @@ -4728,9 +4719,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 @@ -4877,45 +4875,39 @@ PerlIO_tmpfile(void) dTHX; PerlIO *f = NULL; int fd = -1; - SV *sv = Nullsv; - 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 (sv) { - if (f) - PerlIOBase(f)->flags |= PERLIO_F_TEMP; - PerlLIO_unlink(SvPVX(sv)); - SvREFCNT_dec(sv); - } + if (f) + 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; } @@ -5053,4 +5045,3 @@ PerlIO_sprintf(char *s, int n, const char *fmt, ...) -