X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=bb053cc0581314160ca06488f48a825780155fa9;hb=e755722e9001bc986294a4641e1dc2962d0420f1;hp=24927c71a28644e9de65c671b8ac206b01796f05;hpb=210e727c30fedfe36428f457a5e2f9e6176680c4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perlio.c b/perlio.c index 24927c7..bb053cc 100644 --- a/perlio.c +++ b/perlio.c @@ -83,7 +83,6 @@ (*tab->callback) args; \ else \ PerlIOBase_ ## base args; \ - SETERRNO(EINVAL, LIB_INVARG); \ } \ else \ SETERRNO(EBADF, SS_IVCHAN) @@ -94,7 +93,8 @@ PerlIO_funcs *tab = PerlIOBase(f)->tab; \ if (tab && tab->callback) \ (*tab->callback) args; \ - SETERRNO(EINVAL, LIB_INVARG); \ + else \ + SETERRNO(EINVAL, LIB_INVARG); \ } \ else \ SETERRNO(EBADF, SS_IVCHAN) @@ -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, ...) @@ -527,7 +529,9 @@ PerlIO_fdupopen(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags) PerlIO_debug("fdupopen f=%p param=%p\n",(void*)f,(void*)param); if (tab && tab->Dup) return (*tab->Dup)(aTHX_ PerlIO_allocate(aTHX), f, param, flags); - SETERRNO(EINVAL, LIB_INVARG); + else { + return PerlIOBase_dup(aTHX_ PerlIO_allocate(aTHX), f, param, flags); + } } else SETERRNO(EBADF, SS_IVCHAN); @@ -855,7 +859,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 supress warnings during loading of layers. */ dXSARGS; @@ -1066,7 +1070,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; @@ -1325,8 +1329,13 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) int PerlIO__close(pTHX_ PerlIO *f) { - if (PerlIOValid(f)) - return (*PerlIOBase(f)->tab->Close) (aTHX_ f); + if (PerlIOValid(f)) { + PerlIO_funcs *tab = PerlIOBase(f)->tab; + if (tab && tab->Close) + return (*tab->Close)(aTHX_ f); + else + return PerlIOBase_close(aTHX_ f); + } else { SETERRNO(EBADF, SS_IVCHAN); return -1; @@ -1336,21 +1345,10 @@ PerlIO__close(pTHX_ PerlIO *f) int Perl_PerlIO_close(pTHX_ PerlIO *f) { - int code = -1; - - if (PerlIOValid(f)) { - PerlIO_funcs *tab = PerlIOBase(f)->tab; - - if (tab && tab->Close) { - code = (*tab->Close)(aTHX_ f); - while (*f) { - PerlIO_pop(aTHX_ f); - } - } - else - PerlIOBase_close(aTHX_ f); + int code = PerlIO__close(aTHX_ f); + while (PerlIOValid(f)) { + PerlIO_pop(aTHX_ f); } - return code; } @@ -1658,7 +1656,7 @@ PerlIO_isutf8(PerlIO *f) return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; else SETERRNO(EBADF, SS_IVCHAN); - + return -1; } @@ -2035,8 +2033,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; @@ -2074,14 +2075,29 @@ PerlIOBase_noop_fail(pTHX_ PerlIO *f) IV PerlIOBase_close(pTHX_ PerlIO *f) { - IV code = 0; - PerlIO *n = PerlIONext(f); - if (PerlIO_flush(f) != 0) - code = -1; - if (PerlIOValid(n) && (*PerlIOBase(n)->tab->Close)(aTHX_ n) != 0) - code = -1; - PerlIOBase(f)->flags &= - ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); + IV code = -1; + if (PerlIOValid(f)) { + PerlIO *n = PerlIONext(f); + code = PerlIO_flush(f); + PerlIOBase(f)->flags &= + ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); + while (PerlIOValid(n)) { + PerlIO_funcs *tab = PerlIOBase(n)->tab; + if (tab && tab->Close) { + if ((*tab->Close)(aTHX_ n) != 0) + code = -1; + break; + } + else { + PerlIOBase(n)->flags &= + ~(PERLIO_F_CANREAD | PERLIO_F_CANWRITE | PERLIO_F_OPEN); + } + n = PerlIONext(n); + } + } + else { + SETERRNO(EBADF, SS_IVCHAN); + } return code; } @@ -2145,7 +2161,10 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) PerlIO *nexto = PerlIONext(o); if (PerlIOValid(nexto)) { PerlIO_funcs *tab = PerlIOBase(nexto)->tab; - f = (*tab->Dup)(aTHX_ f, nexto, param, flags); + if (tab && tab->Dup) + f = (*tab->Dup)(aTHX_ f, nexto, param, flags); + else + f = PerlIOBase_dup(aTHX_ f, nexto, param, flags); } if (f) { PerlIO_funcs *self = PerlIOBase(o)->tab; @@ -2156,8 +2175,7 @@ PerlIOBase_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *param, int flags) if (self->Getarg) arg = (*self->Getarg)(aTHX_ o, param, flags); else { - arg = Nullsv; - SETERRNO(EINVAL, LIB_INVARG); + arg = Nullsv; } f = PerlIO_push(aTHX_ f, self, PerlIO_modestr(o,buf), arg); if (arg) { @@ -2316,23 +2334,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; } @@ -2358,7 +2397,6 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers, } } if (fd >= 0) { - PerlIOUnix *s; if (*mode == 'I') mode++; if (!f) { @@ -2369,11 +2407,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 { @@ -2398,9 +2433,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; } } @@ -2419,10 +2452,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(); @@ -2436,8 +2474,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(); @@ -2447,10 +2488,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 @@ -2751,11 +2805,11 @@ static int PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) { /* XXX this could use PerlIO_canset_fileno() and - * PerlIO_set_fileno() support from Configure + * PerlIO_set_fileno() support from Configure */ # if defined(__GLIBC__) /* There may be a better way for GLIBC: - - libio.h defines a flag to not close() on cleanup + - libio.h defines a flag to not close() on cleanup */ f->_fileno = -1; return 1; @@ -2767,7 +2821,7 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) * long __pad[16]; * }; * - * It turns out that the fd is stored in the top 32 bits of + * It turns out that the fd is stored in the top 32 bits of * file->__pad[4]. The lower 32 bits contain flags. file->pad[5] appears * to contain a pointer or offset into another structure. All the * remaining fields are zero. @@ -2777,9 +2831,9 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) f->__pad[4] |= 0xffffffff00000000L; assert(fileno(f) == 0xffffffff); # else /* !defined(_LP64) */ - /* _file is just a unsigned char :-( - Not clear why we dup() rather than using -1 - even if that would be treated as 0xFF - so will + /* _file is just a unsigned char :-( + Not clear why we dup() rather than using -1 + even if that would be treated as 0xFF - so will a dup fail ... */ f->_file = PerlLIO_dup(fileno(f)); @@ -2790,24 +2844,24 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) f->__fileL = 0xff; return 1; /* Next one ->_file seems to be a reasonable fallback, i.e. if - your platform does not have special entry try this one. + your platform does not have special entry try this one. [For OSF only have confirmation for Tru64 (alpha) but assume other OSFs will be similar.] - */ + */ # elif defined(_AIX) || defined(__osf__) || defined(__irix__) f->_file = -1; return 1; # elif defined(__FreeBSD__) /* There may be a better way on FreeBSD: - - we could insert a dummy func in the _close function entry - f->_close = (int (*)(void *)) dummy_close; + - we could insert a dummy func in the _close function entry + f->_close = (int (*)(void *)) dummy_close; */ f->_file = -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 - f->_close = (int (*)(void *)) dummy_close; + - we could insert a dummy func in the _close function entry + f->_close = (int (*)(void *)) dummy_close; */ f->_file = -1; return 1; @@ -2824,9 +2878,9 @@ PerlIOStdio_invalidate_fileno(pTHX_ FILE *f) return 1; # else #if 0 - /* Sarathy's code did this - we fall back to a dup/dup2 hack + /* Sarathy's code did this - we fall back to a dup/dup2 hack (which isn't thread safe) instead - */ + */ # error "Don't know how to set FILE.fileno on your platform" #endif return 0; @@ -2849,25 +2903,25 @@ PerlIOStdio_close(pTHX_ PerlIO *f) int saveerr = 0; int dupfd = 0; #ifdef SOCKS5_VERSION_NAME - /* Socks lib overrides close() but stdio isn't linked to - that library (though we are) - so we must call close() - on sockets on stdio's behalf. - */ + /* Socks lib overrides close() but stdio isn't linked to + that library (though we are) - so we must call close() + on sockets on stdio's behalf. + */ int optval; Sock_size_t optlen = sizeof(int); if (getsockopt(fd, SOL_SOCKET, SO_TYPE, (void *) &optval, &optlen) == 0) { socksfd = 1; - invalidate = 1; + invalidate = 1; } #endif if (PerlIOUnix_refcnt_dec(fd) > 0) { /* File descriptor still in use */ invalidate = 1; socksfd = 0; - } + } if (invalidate) { - /* For STD* handles don't close the stdio at all - this is because we have shared the FILE * too + /* For STD* handles don't close the stdio at all + this is because we have shared the FILE * too */ if (stdio == stdin) { /* Some stdios are buggy fflush-ing inputs */ @@ -2876,34 +2930,34 @@ PerlIOStdio_close(pTHX_ PerlIO *f) else if (stdio == stdout || stdio == stderr) { return PerlIO_flush(f); } - /* Tricky - must fclose(stdio) to free memory but not close(fd) - Use Sarathy's trick from maint-5.6 to invalidate the - fileno slot of the FILE * - */ + /* Tricky - must fclose(stdio) to free memory but not close(fd) + Use Sarathy's trick from maint-5.6 to invalidate the + fileno slot of the FILE * + */ result = PerlIO_flush(f); saveerr = errno; if (!(invalidate = PerlIOStdio_invalidate_fileno(aTHX_ stdio))) { dupfd = PerlLIO_dup(fd); } - } + } result = PerlSIO_fclose(stdio); - /* We treat error from stdio as success if we invalidated - errno may NOT be expected EBADF + /* We treat error from stdio as success if we invalidated + errno may NOT be expected EBADF */ if (invalidate && result != 0) { errno = saveerr; result = 0; - } + } if (socksfd) { /* in SOCKS case let close() determine return value */ result = close(fd); } if (dupfd) { PerlLIO_dup2(dupfd,fd); - close(dupfd); + PerlLIO_close(dupfd); } return result; - } + } } SSize_t @@ -2926,10 +2980,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; } @@ -2999,10 +3053,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; } @@ -3272,10 +3326,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; @@ -3353,9 +3408,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; } @@ -3369,8 +3427,11 @@ 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); + 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) { /* @@ -3675,7 +3736,7 @@ PerlIOBuf_tell(pTHX_ PerlIO *f) * b->posn is file position where b->buf was read, or will be written */ Off_t posn = b->posn; - if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) && + if ((PerlIOBase(f)->flags & PERLIO_F_APPEND) && (PerlIOBase(f)->flags & PERLIO_F_WRBUF)) { #if 1 /* As O_APPEND files are normally shared in some sense it is better @@ -3683,7 +3744,7 @@ PerlIOBuf_tell(pTHX_ PerlIO *f) */ PerlIO_flush(f); #else - /* when file is NOT shared then this is sufficient */ + /* when file is NOT shared then this is sufficient */ PerlIO_seek(PerlIONext(f),0, SEEK_END); #endif posn = b->posn = PerlIO_tell(PerlIONext(f)); @@ -4766,45 +4827,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; }