X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=38db370b62af516d6344396be82c6d118c6f6df8;hb=18aba96f40a877297fb70961dbd4be7bc6f1c199;hp=657aeefa69c3bb73fe08e6f9d35f3aba11efde29;hpb=37725cdcc38b517ef70773e843427b086c3d89e1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perlio.c b/perlio.c index 657aeef..38db370 100644 --- a/perlio.c +++ b/perlio.c @@ -430,9 +430,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))); + __attribute__format__(__printf__, 1, 2); void PerlIO_debug(const char *fmt, ...) @@ -2329,23 +2331,44 @@ PerlIOUnix_fileno(pTHX_ PerlIO *f) return PerlIOSelf(f, PerlIOUnix)->fd; } +static void +PerlIOUnix_setfd(pTHX_ PerlIO *f, int fd, int imode) +{ + PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix); +#if defined(WIN32) + Stat_t st; + if (PerlLIO_fstat(fd, &st) == 0) { + if (!S_ISREG(st.st_mode)) { + PerlIO_debug("%d is not regular file\n",fd); + PerlIOBase(f)->flags |= PERLIO_F_NOTREG; + } + else { + PerlIO_debug("%d _is_ a regular file\n",fd); + } + } +#endif + s->fd = fd; + s->oflags = imode; + PerlIOUnix_refcnt_inc(fd); +} + IV PerlIOUnix_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg, PerlIO_funcs *tab) { IV code = PerlIOBase_pushed(aTHX_ f, mode, arg, tab); - PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix); if (*PerlIONext(f)) { /* We never call down so do any pending stuff now */ PerlIO_flush(PerlIONext(f)); - s->fd = PerlIO_fileno(PerlIONext(f)); /* * XXX could (or should) we retrieve the oflags from the open file * handle rather than believing the "mode" we are passed in? XXX * Should the value on NULL mode be 0 or -1? */ - s->oflags = mode ? PerlIOUnix_oflags(mode) : -1; + PerlIOUnix_setfd(aTHX_ f, PerlIO_fileno(PerlIONext(f)), + mode ? PerlIOUnix_oflags(mode) : -1); } PerlIOBase(f)->flags |= PERLIO_F_OPEN; + return code; } @@ -2371,7 +2394,6 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, } } if (fd >= 0) { - PerlIOUnix *s; if (*mode == 'I') mode++; if (!f) { @@ -2382,11 +2404,8 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, return NULL; } } - s = PerlIOSelf(f, PerlIOUnix); - s->fd = fd; - s->oflags = imode; + PerlIOUnix_setfd(aTHX_ f, fd, imode); PerlIOBase(f)->flags |= PERLIO_F_OPEN; - PerlIOUnix_refcnt_inc(fd); return f; } else { @@ -2411,9 +2430,7 @@ PerlIOUnix_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) f = PerlIOBase_dup(aTHX_ f, o, param, flags); if (f) { /* If all went well overwrite fd in dup'ed lay with the dup()'ed fd */ - PerlIOUnix *s = PerlIOSelf(f, PerlIOUnix); - s->fd = fd; - PerlIOUnix_refcnt_inc(fd); + PerlIOUnix_setfd(aTHX_ f, fd, os->oflags); return f; } } @@ -2432,10 +2449,15 @@ PerlIOUnix_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) while (1) { SSize_t len = PerlLIO_read(fd, vbuf, count); if (len >= 0 || errno != EINTR) { - if (len < 0) - PerlIOBase(f)->flags |= PERLIO_F_ERROR; - else if (len == 0 && count != 0) + if (len < 0) { + if (errno != EAGAIN) { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + } + } + else if (len == 0 && count != 0) { PerlIOBase(f)->flags |= PERLIO_F_EOF; + SETERRNO(0,0); + } return len; } PERL_ASYNC_CHECK(); @@ -2449,8 +2471,11 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) while (1) { SSize_t len = PerlLIO_write(fd, vbuf, count); if (len >= 0 || errno != EINTR) { - if (len < 0) - PerlIOBase(f)->flags |= PERLIO_F_ERROR; + if (len < 0) { + if (errno != EAGAIN) { + PerlIOBase(f)->flags |= PERLIO_F_ERROR; + } + } return len; } PERL_ASYNC_CHECK(); @@ -2460,10 +2485,23 @@ PerlIOUnix_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) IV PerlIOUnix_seek(pTHX_ PerlIO *f, Off_t offset, int whence) { - Off_t new = - PerlLIO_lseek(PerlIOSelf(f, PerlIOUnix)->fd, offset, 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 (new == (Off_t) - 1) ? -1 : 0; + return 0; } Off_t @@ -2913,7 +2951,7 @@ PerlIOStdio_close(pTHX_ PerlIO *f) } if (dupfd) { PerlLIO_dup2(dupfd,fd); - close(dupfd); + PerlLIO_close(dupfd); } return result; } @@ -2939,10 +2977,10 @@ PerlIOStdio_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) } else got = PerlSIO_fread(vbuf, 1, count, s); - if (got || errno != EINTR) + if (got >= 0 || errno != EINTR) break; PERL_ASYNC_CHECK(); - errno = 0; /* just in case */ + SETERRNO(0,0); /* just in case */ } return got; } @@ -3012,10 +3050,10 @@ PerlIOStdio_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) for (;;) { got = PerlSIO_fwrite(vbuf, 1, count, PerlIOSelf(f, PerlIOStdio)->stdio); - if (got || errno != EINTR) + if (got >= 0 || errno != EINTR) break; PERL_ASYNC_CHECK(); - errno = 0; /* just in case */ + SETERRNO(0,0); /* just in case */ } return got; } @@ -3285,10 +3323,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; @@ -3382,8 +3421,10 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, * mode++; */ } - f = (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm, - f, narg, args); + f = tab && tab->Open ? + (*tab->Open) (aTHX_ tab, layers, n - 1, mode, fd, imode, perm, + f, narg, args) + : Nullfp; if (f) { if (PerlIO_push(aTHX_ f, self, mode, PerlIOArg) == 0) { /* @@ -3412,6 +3453,8 @@ PerlIOBuf_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, #endif } } + else + SETERRNO(EINVAL, SS_IVCHAN); } return f; } @@ -4779,45 +4822,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 */ +# ifdef HAS_MKSTEMP + 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; }