diff options
| -rw-r--r-- | doio.c | 13 | ||||
| -rw-r--r-- | perlio.c | 87 | ||||
| -rw-r--r-- | perlio.h | 2 |
3 files changed, 82 insertions, 20 deletions
@@ -419,16 +419,16 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, IoTYPE(io) = IoTYPE_RDONLY; /*SUPPRESS 530*/ for (; isSPACE(*name); name++) ; + mode[0] = 'r'; + if (in_raw) + strcat(mode, "b"); + else if (in_crlf) + strcat(mode, "t"); if (strEQ(name,"-")) { fp = PerlIO_stdin(); IoTYPE(io) = IoTYPE_STD; } else { - mode[0] = 'r'; - if (in_raw) - strcat(mode, "b"); - else if (in_crlf) - strcat(mode, "t"); fp = PerlIO_open(name,mode); } } @@ -439,8 +439,7 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open"); goto say_false; } - if (IoTYPE(io) && - IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) { + if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD) { dTHR; if (PerlLIO_fstat(PerlIO_fileno(fp),&PL_statbuf) < 0) { (void)PerlIO_close(fp); @@ -20,7 +20,7 @@ #endif /* * This file provides those parts of PerlIO abstraction - * which are not #defined in iperlsys.h. + * which are not #defined in perlio.h. * Which these are depends on various Configure #ifdef's */ @@ -35,10 +35,10 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) if (!names || !*names || strEQ(names,":crlf") || strEQ(names,":raw")) { return 0; - } + } Perl_croak(aTHX_ "Cannot apply \"%s\" in non-PerlIO perl",names); /* NOTREACHED */ - return -1; + return -1; } #endif @@ -114,12 +114,14 @@ PerlIO_init(void) #include "XSUB.h" -void PerlIO_debug(char *fmt,...) __attribute__((format(__printf__,1,2))); +void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2))); void -PerlIO_debug(char *fmt,...) +PerlIO_debug(const char *fmt,...) { static int dbg = 0; + va_list ap; + va_start(ap,fmt); if (!dbg) { char *s = PerlEnv_getenv("PERLIO_DEBUG"); @@ -131,11 +133,9 @@ PerlIO_debug(char *fmt,...) if (dbg > 0) { dTHX; - va_list ap; SV *sv = newSVpvn("",0); char *s; STRLEN len; - va_start(ap,fmt); s = CopFILE(PL_curcop); if (!s) s = "(none)"; @@ -144,9 +144,9 @@ PerlIO_debug(char *fmt,...) s = SvPV(sv,len); PerlLIO_write(dbg,s,len); - va_end(ap); SvREFCNT_dec(sv); } + va_end(ap); } /*--------------------------------------------------------------------------------------*/ @@ -1278,7 +1278,25 @@ IV PerlIOStdio_flush(PerlIO *f) { FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; - return fflush(stdio); + if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) + { + return fflush(stdio); + } + else + { +#if 0 + /* FIXME: This discards ungetc() and pre-read stuff which is + not right if this is just a "sync" from a layer above + Suspect right design is to do _this_ but not have layer above + flush this layer read-to-read + */ + /* Not writeable - sync by attempting a seek */ + int err = errno; + if (fseek(stdio,(Off_t) 0, SEEK_CUR) != 0) + errno = err; +#endif + } + return 0; } IV @@ -1555,6 +1573,7 @@ PerlIOBuf_flush(PerlIO *f) } b->ptr = b->end = b->buf; PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); + /* FIXME: Is this right for read case ? */ if (PerlIO_flush(PerlIONext(f)) != 0) code = -1; return code; @@ -1564,11 +1583,53 @@ IV PerlIOBuf_fill(PerlIO *f) { PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + PerlIO *n = PerlIONext(f); SSize_t avail; + /* FIXME: doing the down-stream flush is a bad idea if it causes + pre-read data in stdio buffer to be discarded + but this is too simplistic - as it skips _our_ hosekeeping + and breaks tell tests. + if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) + { + } + */ if (PerlIO_flush(f) != 0) return -1; + b->ptr = b->end = b->buf; - avail = PerlIO_read(PerlIONext(f),b->ptr,b->bufsiz); + if (PerlIO_fast_gets(n)) + { + /* Layer below is also buffered + * We do _NOT_ want to call its ->Read() because that will loop + * till it gets what we asked for which may hang on a pipe etc. + * Instead take anything it has to hand, or ask it to fill _once_. + */ + avail = PerlIO_get_cnt(n); + if (avail <= 0) + { + avail = PerlIO_fill(n); + if (avail == 0) + avail = PerlIO_get_cnt(n); + else + { + if (!PerlIO_error(n) && PerlIO_eof(n)) + avail = 0; + } + } + if (avail > 0) + { + STDCHAR *ptr = PerlIO_get_ptr(n); + SSize_t cnt = avail; + if (avail > b->bufsiz) + avail = b->bufsiz; + Copy(ptr,b->buf,avail,STDCHAR); + PerlIO_set_ptrcnt(n,ptr+avail,cnt-avail); + } + } + else + { + avail = PerlIO_read(n,b->ptr,b->bufsiz); + } if (avail <= 0) { if (avail == 0) @@ -1601,7 +1662,7 @@ PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count) avail = count; if (avail > 0) { - Copy(b->ptr,buf,avail,char); + Copy(b->ptr,buf,avail,STDCHAR); got += avail; b->ptr += avail; count -= avail; @@ -1650,7 +1711,7 @@ PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count) buf -= avail; if (buf != b->ptr) { - Copy(buf,b->ptr,avail,char); + Copy(buf,b->ptr,avail,STDCHAR); } count -= avail; unread += avail; @@ -1696,7 +1757,7 @@ PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count) { if (avail) { - Copy(buf,b->ptr,avail,char); + Copy(buf,b->ptr,avail,STDCHAR); count -= avail; buf += avail; written += avail; @@ -312,4 +312,6 @@ extern int PerlIO_isutf8 (PerlIO *); extern int PerlIO_apply_layers (pTHX_ PerlIO *f,const char *mode, const char *names); #endif +extern void PerlIO_debug(const char *fmt,...); + #endif /* _PERLIO_H */ |