diff options
| -rw-r--r-- | doio.c | 55 | ||||
| -rw-r--r-- | perlio.c | 242 | ||||
| -rw-r--r-- | perlio.h | 5 | ||||
| -rw-r--r-- | pp_sys.c | 14 | ||||
| -rwxr-xr-x | t/lib/io_tell.t | 2 |
5 files changed, 200 insertions, 118 deletions
@@ -1066,7 +1066,11 @@ fail_discipline: end = strchr(s+1, ':'); if (!end) end = s+len; +#ifndef PERLIO_LAYERS Perl_croak(aTHX_ "Unknown discipline '%.*s'", end-s, s); +#else + s = end; +#endif } } } @@ -1076,46 +1080,11 @@ fail_discipline: int Perl_do_binmode(pTHX_ PerlIO *fp, int iotype, int mode) { -#ifdef DOSISH -# if defined(atarist) || defined(__MINT__) - if (!PerlIO_flush(fp)) { - if (mode & O_BINARY) - ((FILE*)fp)->_flag |= _IOBIN; - else - ((FILE*)fp)->_flag &= ~ _IOBIN; - return 1; - } - return 0; -# else - if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) { -# if defined(WIN32) && defined(__BORLANDC__) - /* The translation mode of the stream is maintained independent - * of the translation mode of the fd in the Borland RTL (heavy - * digging through their runtime sources reveal). User has to - * set the mode explicitly for the stream (though they don't - * document this anywhere). GSAR 97-5-24 - */ - PerlIO_seek(fp,0L,0); - if (mode & O_BINARY) - ((FILE*)fp)->flags |= _F_BIN; - else - ((FILE*)fp)->flags &= ~ _F_BIN; -# endif - return 1; - } - else - return 0; -# endif -#else -# if defined(USEMYBINMODE) - if (my_binmode(fp, iotype, mode) != FALSE) - return 1; - else - return 0; -# else - return 1; -# endif -#endif + /* The old body of this is now in non-LAYER part of perlio.c + * This is a stub for any XS code which might have been calling it. + */ + char *name = (O_BINARY != O_TEXT && !(mode & O_BINARY)) ? ":crlf" : ":raw"; + return PerlIO_binmode(aTHX_ fp, iotype, mode, name); } #if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP) @@ -2151,7 +2120,7 @@ static int S_s64_malloc( S64_IOB *ptr) { return( 0); ptr->size += _S64_BUFFER_SIZE; - + return( 1); } @@ -2162,7 +2131,7 @@ static int S_s64_malloc( S64_IOB *ptr) { int Perl_do_s64_getc( PerlIO *f) { S64_IOB *ptr = _s64_get_buffer(f); if( ptr) { - if( ptr->cnt) + if( ptr->cnt) return( ptr->buffer[--ptr->cnt]); } return( getc(f)); @@ -2174,7 +2143,7 @@ int Perl_do_s64_ungetc( int ch, PerlIO *f) { if( !ptr) ptr=_s64_create_buffer(f); if( !ptr) return( EOF); - if( !ptr->buffer || (ptr->buffer && ptr->cnt >= ptr->size)) + if( !ptr->buffer || (ptr->buffer && ptr->cnt >= ptr->size)) if( !_s64_malloc( ptr)) return( EOF); ptr->buffer[ptr->cnt++] = ch; @@ -40,6 +40,56 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) /* NOTREACHED */ return -1; } + +int +PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) +{ +/* This used to be contents of do_binmode in doio.c */ +#ifdef DOSISH +# if defined(atarist) || defined(__MINT__) + if (!PerlIO_flush(fp)) { + if (mode & O_BINARY) + ((FILE*)fp)->_flag |= _IOBIN; + else + ((FILE*)fp)->_flag &= ~ _IOBIN; + return 1; + } + return 0; +# else + if (PerlLIO_setmode(PerlIO_fileno(fp), mode) != -1) { +# if defined(WIN32) && defined(__BORLANDC__) + /* The translation mode of the stream is maintained independent + * of the translation mode of the fd in the Borland RTL (heavy + * digging through their runtime sources reveal). User has to + * set the mode explicitly for the stream (though they don't + * document this anywhere). GSAR 97-5-24 + */ + PerlIO_seek(fp,0L,0); + if (mode & O_BINARY) + ((FILE*)fp)->flags |= _F_BIN; + else + ((FILE*)fp)->flags &= ~ _F_BIN; +# endif + return 1; + } + else + return 0; +# endif +#else +# if defined(USEMYBINMODE) + if (my_binmode(fp, iotype, mode) != FALSE) + return 1; + else + return 0; +# else + return 1; +# endif +#endif +} + + + + #endif #if !defined(PERL_IMPLICIT_SYS) @@ -193,7 +243,7 @@ PerlIO_cleantable(PerlIO **tablep) for (i=PERLIO_TABLE_SIZE-1; i > 0; i--) { PerlIO *f = table+i; - if (*f) + if (*f) { PerlIO_close(f); } @@ -431,6 +481,41 @@ PerlIO_default_layer(I32 n) return tab; } +#define PerlIO_default_top() PerlIO_default_layer(-1) +#define PerlIO_default_btm() PerlIO_default_layer(0) + +void +PerlIO_stdstreams() +{ + if (!_perlio) + { + PerlIO_allocate(); + PerlIO_fdopen(0,"Ir"); + PerlIO_fdopen(1,"Iw"); + PerlIO_fdopen(2,"Iw"); + } +} + +PerlIO * +PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode) +{ + PerlIOl *l = NULL; + Newc('L',l,tab->size,char,PerlIOl); + if (l) + { + Zero(l,tab->size,char); + l->next = *f; + l->tab = tab; + *f = l; + if ((*l->tab->Pushed)(f,mode) != 0) + { + PerlIO_pop(f); + return NULL; + } + } + return f; +} + int PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) { @@ -450,19 +535,34 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) e++; if (e > s) { - SV *layer = PerlIO_find_layer(s,e-s); - if (layer) + if ((e - s) == 3 && strncmp(s,"raw",3) == 0) { - PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer))); - if (tab) + /* Pop back to bottom layer */ + if (PerlIONext(f)) { - PerlIO *new = PerlIO_push(f,tab,mode); - if (!new) - return -1; + PerlIO_flush(f); + while (PerlIONext(f)) + { + PerlIO_pop(f); + } } } else - Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s); + { + SV *layer = PerlIO_find_layer(s,e-s); + if (layer) + { + PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer))); + if (tab) + { + PerlIO *new = PerlIO_push(f,tab,mode); + if (!new) + return -1; + } + } + else + Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)(e-s),s); + } } s = e; } @@ -471,44 +571,32 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) return 0; } -#define PerlIO_default_top() PerlIO_default_layer(-1) -#define PerlIO_default_btm() PerlIO_default_layer(0) -void -PerlIO_stdstreams() -{ - if (!_perlio) - { - PerlIO_allocate(); - PerlIO_fdopen(0,"Ir"); - PerlIO_fdopen(1,"Iw"); - PerlIO_fdopen(2,"Iw"); - } -} -PerlIO * -PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode) +/*--------------------------------------------------------------------------------------*/ +/* Given the abstraction above the public API functions */ + +int +PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) { - PerlIOl *l = NULL; - Newc('L',l,tab->size,char,PerlIOl); - if (l) + if (!names || (O_TEXT != O_BINARY && mode & O_BINARY)) { - Zero(l,tab->size,char); - l->next = *f; - l->tab = tab; - *f = l; - if ((*l->tab->Pushed)(f,mode) != 0) + PerlIO *top = fp; + PerlIOl *l; + while (l = *top) { - PerlIO_pop(f); - return NULL; + if (PerlIOBase(top)->tab == &PerlIO_crlf) + { + PerlIO_flush(top); + PerlIO_pop(top); + break; + } + top = PerlIONext(top); } } - return f; + return PerlIO_apply_layers(aTHX_ fp, NULL, names) == 0 ? TRUE : FALSE; } -/*--------------------------------------------------------------------------------------*/ -/* Given the abstraction above the public API functions */ - #undef PerlIO_close int PerlIO_close(PerlIO *f) @@ -948,8 +1036,8 @@ PerlIOUnix_oflags(const char *mode) if (*mode == 'b') { oflags |= O_BINARY; - mode++; - } + mode++; + } /* Always open in binary mode */ oflags |= O_BINARY; if (*mode || oflags == -1) @@ -1672,7 +1760,7 @@ PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count) while (count > 0) { SSize_t avail = PerlIO_get_cnt(f); - SSize_t take = (count < avail) ? count : avail; + SSize_t take = (count < avail) ? count : avail; if (take > 0) { STDCHAR *ptr = PerlIO_get_ptr(f); @@ -1931,14 +2019,14 @@ PerlIO_funcs PerlIO_perlio = { /*--------------------------------------------------------------------------------------*/ /* crlf - translation On read translate CR,LF to "\n" we do this by overriding ptr/cnt entries - to hand back a line at a time and keeping a record of which nl we "lied" about. + to hand back a line at a time and keeping a record of which nl we "lied" about. On write translate "\n" to CR,LF */ typedef struct { PerlIOBuf base; /* PerlIOBuf stuff */ - STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */ + STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */ } PerlIOCrlf; SSize_t @@ -1946,9 +2034,15 @@ PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count) { const STDCHAR *buf = (const STDCHAR *) vbuf+count; PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); SSize_t unread = 0; if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) PerlIO_flush(f); + if (c->nl) + { + *(c->nl) = 0xd; + c->nl = NULL; + } if (!b->buf) PerlIO_get_base(f); if (b->buf) @@ -1965,8 +2059,8 @@ PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count) { if (b->ptr - 2 >= b->buf) { - *(b->ptr)-- = 0xa; - *(b->ptr)-- = 0xd; + *--(b->ptr) = 0xa; + *--(b->ptr) = 0xd; unread++; count--; } @@ -1978,10 +2072,10 @@ PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count) } else { - *(b->ptr)-- = ch; + *--(b->ptr) = ch; unread++; count--; - } + } } } return unread; @@ -1999,33 +2093,33 @@ PerlIOCrlf_get_cnt(PerlIO *f) if (!c->nl) { STDCHAR *nl = b->ptr; - scan: + scan: while (nl < b->end && *nl != 0xd) nl++; if (nl < b->end && *nl == 0xd) { - test: + test: if (nl+1 < b->end) { if (nl[1] == 0xa) { *nl = '\n'; - c->nl = nl; + c->nl = nl; } - else + else { /* Not CR,LF but just CR */ nl++; - goto scan; + goto scan; } } else { - /* Blast - found CR as last char in buffer */ + /* Blast - found CR as last char in buffer */ if (b->ptr < nl) { /* They may not care, defer work as long as possible */ - return (nl - b->ptr); + return (nl - b->ptr); } else { @@ -2041,13 +2135,13 @@ PerlIOCrlf_get_cnt(PerlIO *f) b->ptr = nl = b->buf; /* Which is what we hand off */ b->posn--; /* Buffer starts here */ *nl = 0xd; /* Fill in the CR */ - if (code == 0) + if (code == 0) goto test; /* fill() call worked */ /* CR at EOF - just fall through */ } } - } - } + } + } return (((c->nl) ? (c->nl+1) : b->end) - b->ptr); } return 0; @@ -2061,7 +2155,14 @@ PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) if (!b->buf) PerlIO_get_base(f); if (!ptr) - ptr = ((c->nl) ? (c->nl+1) : b->end) - cnt; + { + ptr = ((c->nl) ? (c->nl+1) : b->end) - cnt; + } + else + { + if (ptr != (((c->nl) ? (c->nl+1) : b->end) - cnt)) + abort(); + } if (c->nl) { if (ptr > c->nl) @@ -2070,7 +2171,7 @@ PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) *(c->nl) = 0xd; c->nl = NULL; ptr++; - } + } } b->ptr = ptr; PerlIOBase(f)->flags |= PERLIO_F_RDBUF; @@ -2094,19 +2195,22 @@ PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count) { if (*buf == '\n') { - if (b->ptr + 2 >= eptr) + if ((b->ptr + 2) > eptr) { /* Not room for both */ PerlIO_flush(f); break; } - *(b->ptr)++ = 0xd; /* CR */ - *(b->ptr)++ = 0xa; /* LF */ - buf++; - if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) - { - PerlIO_flush(f); - break; + else + { + *(b->ptr)++ = 0xd; /* CR */ + *(b->ptr)++ = 0xa; /* LF */ + buf++; + if (PerlIOBase(f)->flags & PERLIO_F_LINEBUF) + { + PerlIO_flush(f); + break; + } } } else @@ -2130,10 +2234,8 @@ PerlIOCrlf_flush(PerlIO *f) PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); if (c->nl) { - dTHX; - Perl_warn(aTHX_ __FUNCTION__ " f=%p flush with nl@%p",f,c->nl); *(c->nl) = 0xd; - c->nl = NULL; + c->nl = NULL; } return PerlIOBuf_flush(f); } @@ -309,7 +309,10 @@ extern PerlIO * PerlIO_fdupopen (PerlIO *); extern int PerlIO_isutf8 (PerlIO *); #endif #ifndef PerlIO_apply_layers -extern int PerlIO_apply_layers (pTHX_ PerlIO *f,const char *mode, const char *names); +extern int PerlIO_apply_layers (pTHX_ PerlIO *f, const char *mode, const char *names); +#endif +#ifndef PerlIO_binmode +extern int PerlIO_binmode (pTHX_ PerlIO *f, int iotype, int omode, const char *names); #endif extern void PerlIO_debug(const char *fmt,...); @@ -687,11 +687,14 @@ PP(pp_binmode) PerlIO *fp; MAGIC *mg; SV *discp = Nullsv; + STRLEN len = 0; + char *names = NULL; if (MAXARG < 1) RETPUSHUNDEF; - if (MAXARG > 1) + if (MAXARG > 1) { discp = POPs; + } gv = (GV*)POPs; @@ -712,7 +715,12 @@ PP(pp_binmode) if (!(io = GvIO(gv)) || !(fp = IoIFP(io))) RETPUSHUNDEF; - if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp))) + if (discp) { + names = SvPV(discp,len); + } + + if (PerlIO_binmode(aTHX_ fp,IoTYPE(io),mode_from_discipline(discp), + (discp) ? SvPV_nolen(discp) : Nullch)) RETPUSHYES; else RETPUSHUNDEF; @@ -3137,7 +3145,7 @@ PP(pp_fttext) (void)PerlIO_close(fp); RETPUSHUNDEF; } - do_binmode(fp, '<', O_BINARY); + PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch); len = PerlIO_read(fp, tbuf, sizeof(tbuf)); (void)PerlIO_close(fp); if (len <= 0) { diff --git a/t/lib/io_tell.t b/t/lib/io_tell.t index 3aa4b031e1..65c63bdfc9 100755 --- a/t/lib/io_tell.t +++ b/t/lib/io_tell.t @@ -27,7 +27,7 @@ print "1..13\n"; use IO::File; $tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file"); -binmode $tst if ($^O eq 'MSWin32' or $^O eq 'dos'); +binmode $tst; # its a nop unless it matters. Was only if ($^O eq 'MSWin32' or $^O eq 'dos'); if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; } $firstline = <$tst>; |