X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=9f12be62735db4bc0c470dedcbac7e9828675adb;hb=918426be7f3660c63cebe082bf8eac82a38bf756;hp=c55b6810aa6b12f81e8de406ef60bd00fedd43bc;hpb=88b61e10dfef3b0642d1458a9fff93e5000f86b0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perlio.c b/perlio.c index c55b681..9f12be6 100644 --- a/perlio.c +++ b/perlio.c @@ -1,6 +1,6 @@ /* perlio.c * - * Copyright (c) 1996-2000, Nick Ing-Simmons + * Copyright (c) 1996-2001, 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. @@ -28,6 +28,58 @@ #define PERL_IN_PERLIO_C #include "perl.h" +#undef PerlMemShared_calloc +#define PerlMemShared_calloc(x,y) calloc(x,y) +#undef PerlMemShared_free +#define PerlMemShared_free(x) free(x) + +int +perlsio_binmode(FILE *fp, int iotype, int mode) +{ +/* This used to be contents of do_binmode in doio.c */ +#ifdef DOSISH +# if defined(atarist) || defined(__MINT__) + if (!fflush(fp)) { + if (mode & O_BINARY) + ((FILE*)fp)->_flag |= _IOBIN; + else + ((FILE*)fp)->_flag &= ~ _IOBIN; + return 1; + } + return 0; +# else + dTHX; + if (PerlLIO_setmode(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 + */ + fseek(fp,0L,0); + if (mode & O_BINARY) + fp->flags |= _F_BIN; + else + 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 +} + #ifndef PERLIO_LAYERS int PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) @@ -40,9 +92,15 @@ 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) +{ + return perlsio_binmode(fp,iotype,mode); +} + #endif -#if !defined(PERL_IMPLICIT_SYS) #ifdef PERLIO_IS_STDIO @@ -119,6 +177,7 @@ void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2))); void PerlIO_debug(const char *fmt,...) { + dTHX; static int dbg = 0; va_list ap; va_start(ap,fmt); @@ -158,11 +217,12 @@ PerlIO *_perlio = NULL; #define PERLIO_TABLE_SIZE 64 PerlIO * -PerlIO_allocate(void) +PerlIO_allocate(pTHX) { /* Find a free slot in the table, allocating new table as necessary */ - PerlIO **last = &_perlio; + PerlIO **last; PerlIO *f; + last = &_perlio; while ((f = *last)) { int i; @@ -175,28 +235,32 @@ PerlIO_allocate(void) } } } - Newz('I',f,PERLIO_TABLE_SIZE,PerlIO); + f = PerlMemShared_calloc(PERLIO_TABLE_SIZE,sizeof(PerlIO)); if (!f) - return NULL; + { + return NULL; + } *last = f; return f+1; } void -PerlIO_cleantable(PerlIO **tablep) +PerlIO_cleantable(pTHX_ PerlIO **tablep) { PerlIO *table = *tablep; if (table) { int i; - PerlIO_cleantable((PerlIO **) &(table[0])); + PerlIO_cleantable(aTHX_ (PerlIO **) &(table[0])); for (i=PERLIO_TABLE_SIZE-1; i > 0; i--) { PerlIO *f = table+i; if (*f) - PerlIO_close(f); + { + PerlIO_close(f); + } } - Safefree(table); + PerlMemShared_free(table); *tablep = NULL; } } @@ -205,20 +269,24 @@ HV *PerlIO_layer_hv; AV *PerlIO_layer_av; void -PerlIO_cleanup(void) +PerlIO_cleanup() { - PerlIO_cleantable(&_perlio); + dTHX; + PerlIO_cleantable(aTHX_ &_perlio); } void PerlIO_pop(PerlIO *f) { + dTHX; PerlIOl *l = *f; if (l) { - (*l->tab->Popped)(f); + PerlIO_debug("PerlIO_pop f=%p %s\n",f,l->tab->name); + if (l->tab->Popped) + (*l->tab->Popped)(f); *f = l->next; - Safefree(l); + PerlMemShared_free(l); } } @@ -251,7 +319,7 @@ PerlIO_find_layer(const char *name, STRLEN len) dTHX; SV **svp; SV *sv; - if (len <= 0) + if ((SSize_t) len <= 0) len = strlen(name); svp = hv_fetch(PerlIO_layer_hv,name,len,0); if (svp && (sv = *svp) && SvROK(sv)) @@ -269,7 +337,7 @@ perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) PerlIO *ifp = IoIFP(io); PerlIO *ofp = IoOFP(io); AV *av = (AV *) mg->mg_obj; - Perl_warn(aTHX_ "set %_ %p %p %p",sv,io,ifp,ofp); + Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp); } return 0; } @@ -283,7 +351,7 @@ perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) PerlIO *ifp = IoIFP(io); PerlIO *ofp = IoOFP(io); AV *av = (AV *) mg->mg_obj; - Perl_warn(aTHX_ "get %_ %p %p %p",sv,io,ifp,ofp); + Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp); } return 0; } @@ -291,14 +359,14 @@ perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) static int perlio_mg_clear(pTHX_ SV *sv, MAGIC *mg) { - Perl_warn(aTHX_ "clear %_",sv); + Perl_warn(aTHX_ "clear %"SVf,sv); return 0; } static int perlio_mg_free(pTHX_ SV *sv, MAGIC *mg) { - Perl_warn(aTHX_ "free %_",sv); + Perl_warn(aTHX_ "free %"SVf,sv); return 0; } @@ -323,7 +391,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) mg = mg_find(sv,'~'); mg->mg_virtual = &perlio_vtab; mg_magical(sv); - Perl_warn(aTHX_ "attrib %_",sv); + Perl_warn(aTHX_ "attrib %"SVf,sv); for (i=2; i < items; i++) { STRLEN len; @@ -349,9 +417,34 @@ PerlIO_define_layer(PerlIO_funcs *tab) dTHX; HV *stash = gv_stashpv("perlio::Layer", TRUE); SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash); + if (!PerlIO_layer_hv) + { + PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI); + } hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0); + PerlIO_debug("define %s %p\n",tab->name,tab); +} + +void +PerlIO_default_buffer(pTHX) +{ + PerlIO_funcs *tab = &PerlIO_perlio; + if (O_BINARY != O_TEXT) + { + tab = &PerlIO_crlf; + } + else + { + if (PerlIO_stdio.Set_ptrcnt) + { + tab = &PerlIO_stdio; + } + } + PerlIO_debug("Pushing %s\n",tab->name); + av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(tab->name,0))); } + PerlIO_funcs * PerlIO_default_layer(I32 n) { @@ -360,16 +453,16 @@ PerlIO_default_layer(I32 n) SV *layer; PerlIO_funcs *tab = &PerlIO_stdio; int len; - if (!PerlIO_layer_hv) + if (!PerlIO_layer_av) { const char *s = PerlEnv_getenv("PERLIO"); + PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI); newXS("perlio::import",XS_perlio_import,__FILE__); newXS("perlio::unimport",XS_perlio_unimport,__FILE__); #if 0 newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__); #endif - PerlIO_layer_hv = get_hv("open::layers",GV_ADD|GV_ADDMULTI); - PerlIO_layer_av = get_av("open::layers",GV_ADD|GV_ADDMULTI); + PerlIO_define_layer(&PerlIO_raw); PerlIO_define_layer(&PerlIO_unix); PerlIO_define_layer(&PerlIO_perlio); PerlIO_define_layer(&PerlIO_stdio); @@ -377,9 +470,12 @@ PerlIO_default_layer(I32 n) #ifdef HAS_MMAP PerlIO_define_layer(&PerlIO_mmap); #endif + PerlIO_define_layer(&PerlIO_utf8); + PerlIO_define_layer(&PerlIO_byte); av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0))); if (s) { + IV buffered = 0; while (*s) { while (*s && isSPACE((unsigned char)*s)) @@ -395,8 +491,15 @@ PerlIO_default_layer(I32 n) layer = PerlIO_find_layer(s,e-s); if (layer) { + PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer))); + if ((tab->kind & PERLIO_K_DUMMY) && (tab->kind & PERLIO_K_BUFFERED)) + { + if (!buffered) + PerlIO_default_buffer(aTHX); + } PerlIO_debug("Pushing %.*s\n",(e-s),s); av_push(PerlIO_layer_av,SvREFCNT_inc(layer)); + buffered |= (tab->kind & PERLIO_K_BUFFERED); } else Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s); @@ -408,14 +511,7 @@ PerlIO_default_layer(I32 n) len = av_len(PerlIO_layer_av); if (len < 1) { - if (PerlIO_stdio.Set_ptrcnt) - { - av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_stdio.name,0))); - } - else - { - av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_perlio.name,0))); - } + PerlIO_default_buffer(aTHX); len = av_len(PerlIO_layer_av); } if (n < 0) @@ -429,6 +525,90 @@ 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) + { + dTHX; + PerlIO_allocate(aTHX); + PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT); + PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT); + PerlIO_fdopen(2,"Iw" PERLIO_STDTEXT); + } +} + +PerlIO * +PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len) +{ + dTHX; + PerlIOl *l = NULL; + l = PerlMemShared_calloc(tab->size,sizeof(char)); + if (l) + { + Zero(l,tab->size,char); + l->next = *f; + l->tab = tab; + *f = l; + PerlIO_debug("PerlIO_push f=%p %s %s '%.*s'\n", + f,tab->name,(mode) ? mode : "(Null)",(int) len,arg); + if ((*l->tab->Pushed)(f,mode,arg,len) != 0) + { + PerlIO_pop(f); + return NULL; + } + } + return f; +} + +IV +PerlIOPop_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +{ + PerlIO_pop(f); + if (*f) + { + PerlIO_flush(f); + PerlIO_pop(f); + return 0; + } + return -1; +} + +IV +PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +{ + /* Remove the dummy layer */ + PerlIO_pop(f); + /* Pop back to bottom layer */ + if (f && *f) + { + int code = 0; + PerlIO_flush(f); + while (!(PerlIOBase(f)->tab->kind & PERLIO_K_RAW)) + { + if (*PerlIONext(f)) + { + PerlIO_pop(f); + } + else + { + /* Nothing bellow - push unix on top then remove it */ + if (PerlIO_push(f,PerlIO_default_btm(),mode,arg,len)) + { + PerlIO_pop(PerlIONext(f)); + } + break; + } + } + PerlIO_debug(":raw f=%p :%s\n",f,PerlIOBase(f)->tab->name); + return 0; + } + return -1; +} + int PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) { @@ -437,30 +617,77 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) const char *s = names; while (*s) { - while (isSPACE(*s)) - s++; - if (*s == ':') + while (isSPACE(*s) || *s == ':') s++; if (*s) { + STRLEN llen = 0; const char *e = s; - while (*e && *e != ':' && !isSPACE(*e)) - e++; + const char *as = Nullch; + STRLEN alen = 0; + if (!isIDFIRST(*s)) + { + /* Message is consistent with how attribute lists are passed. + Even though this means "foo : : bar" is seen as an invalid separator + character. */ + char q = ((*s == '\'') ? '"' : '\''); + Perl_warn(aTHX_ "perlio: invalid separator character %c%c%c in layer specification list", q, *s, q); + return -1; + } + do + { + e++; + } while (isALNUM(*e)); + llen = e-s; + if (*e == '(') + { + int nesting = 1; + as = ++e; + while (nesting) + { + switch (*e++) + { + case ')': + if (--nesting == 0) + alen = (e-1)-as; + break; + case '(': + ++nesting; + break; + case '\\': + /* It's a nul terminated string, not allowed to \ the terminating null. + Anything other character is passed over. */ + if (*e++) + { + break; + } + /* Drop through */ + case '\0': + e--; + Perl_warn(aTHX_ "perlio: argument list not closed for layer \"%.*s\"",(int)(e - s),s); + return -1; + default: + /* boring. */ + break; + } + } + } if (e > s) { - SV *layer = PerlIO_find_layer(s,e-s); + SV *layer = PerlIO_find_layer(s,llen); if (layer) { PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer))); if (tab) { - PerlIO *new = PerlIO_push(f,tab,mode); - if (!new) + if (!PerlIO_push(f,tab,mode,as,alen)) return -1; } } - else - Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(e-s),s); + else { + Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s); + return -1; + } } s = e; } @@ -469,44 +696,56 @@ 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() + +/*--------------------------------------------------------------------------------------*/ +/* Given the abstraction above the public API functions */ + +int +PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) { - if (!_perlio) + PerlIO_debug("PerlIO_binmode f=%p %s %c %x %s\n", + f,PerlIOBase(f)->tab->name,iotype,mode, (names) ? names : "(Null)"); + if (!names && (O_TEXT != O_BINARY && (mode & O_BINARY))) { - PerlIO_allocate(); - PerlIO_fdopen(0,"Ir"); - PerlIO_fdopen(1,"Iw"); - PerlIO_fdopen(2,"Iw"); + PerlIO *top = f; + PerlIOl *l; + while (l = *top) + { + if (PerlIOBase(top)->tab == &PerlIO_crlf) + { + PerlIO_flush(top); + PerlIOBase(top)->flags &= ~PERLIO_F_CRLF; + break; + } + top = PerlIONext(top); + } } + return PerlIO_apply_layers(aTHX_ f, NULL, names) == 0 ? TRUE : FALSE; } +#undef PerlIO__close +int +PerlIO__close(PerlIO *f) +{ + return (*PerlIOBase(f)->tab->Close)(f); +} + +#undef PerlIO_fdupopen PerlIO * -PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode) +PerlIO_fdupopen(pTHX_ PerlIO *f) { - PerlIOl *l = NULL; - Newc('L',l,tab->size,char,PerlIOl); - if (l) + char buf[8]; + int fd = PerlLIO_dup(PerlIO_fileno(f)); + PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf)); + if (new) { - 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; - } + Off_t posn = PerlIO_tell(f); + PerlIO_seek(new,posn,SEEK_SET); } - return f; + return new; } -/*--------------------------------------------------------------------------------------*/ -/* Given the abstraction above the public API functions */ - #undef PerlIO_close int PerlIO_close(PerlIO *f) @@ -557,7 +796,7 @@ PerlIO_reopen(const char *path, const char *mode, PerlIO *f) PerlIO_flush(f); if ((*PerlIOBase(f)->tab->Reopen)(path,mode,f) == 0) { - if ((*PerlIOBase(f)->tab->Pushed)(f,mode) == 0) + if ((*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) == 0) return f; } return NULL; @@ -607,7 +846,17 @@ PerlIO_flush(PerlIO *f) { if (f) { - return (*PerlIOBase(f)->tab->Flush)(f); + PerlIO_funcs *tab = PerlIOBase(f)->tab; + if (tab && tab->Flush) + { + return (*tab->Flush)(f); + } + else + { + PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name); + errno = EINVAL; + return -1; + } } else { @@ -660,7 +909,8 @@ PerlIO_error(PerlIO *f) void PerlIO_clearerr(PerlIO *f) { - (*PerlIOBase(f)->tab->Clearerr)(f); + if (f && *f) + (*PerlIOBase(f)->tab->Clearerr)(f); } #undef PerlIO_setlinebuf @@ -685,10 +935,10 @@ PerlIO_has_base(PerlIO *f) int PerlIO_fast_gets(PerlIO *f) { - if (f && *f) + if (f && *f && (PerlIOBase(f)->flags & PERLIO_F_FASTGETS)) { - PerlIOl *l = PerlIOBase(f); - return (l->tab->Set_ptrcnt != NULL); + PerlIO_funcs *tab = PerlIOBase(f)->tab; + return (tab->Set_ptrcnt != NULL); } return 0; } @@ -735,14 +985,20 @@ PerlIO_get_bufsiz(PerlIO *f) STDCHAR * PerlIO_get_ptr(PerlIO *f) { - return (*PerlIOBase(f)->tab->Get_ptr)(f); + PerlIO_funcs *tab = PerlIOBase(f)->tab; + if (tab->Get_ptr == NULL) + return NULL; + return (*tab->Get_ptr)(f); } #undef PerlIO_get_cnt int PerlIO_get_cnt(PerlIO *f) { - return (*PerlIOBase(f)->tab->Get_cnt)(f); + PerlIO_funcs *tab = PerlIOBase(f)->tab; + if (tab->Get_cnt == NULL) + return 0; + return (*tab->Get_cnt)(f); } #undef PerlIO_set_cnt @@ -756,106 +1012,311 @@ PerlIO_set_cnt(PerlIO *f,int cnt) void PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) { + PerlIO_funcs *tab = PerlIOBase(f)->tab; + if (tab->Set_ptrcnt == NULL) + { + dTHX; + Perl_croak(aTHX_ "PerlIO buffer snooping abuse"); + } (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt); } /*--------------------------------------------------------------------------------------*/ -/* "Methods" of the "base class" */ - -IV -PerlIOBase_fileno(PerlIO *f) -{ - return PerlIO_fileno(PerlIONext(f)); -} +/* utf8 and raw dummy layers */ IV -PerlIOBase_pushed(PerlIO *f, const char *mode) +PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) { - PerlIOl *l = PerlIOBase(f); - l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE| - PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY); - if (mode) - { - switch (*mode++) - { - case 'r': - l->flags = PERLIO_F_CANREAD; - break; - case 'a': - l->flags = PERLIO_F_APPEND|PERLIO_F_CANWRITE; - break; - case 'w': - l->flags = PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE; - break; - default: - errno = EINVAL; - return -1; - } - while (*mode) - { - switch (*mode++) - { - case '+': - l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE; - break; - case 'b': - l->flags |= PERLIO_F_BINARY; - break; - default: - errno = EINVAL; - return -1; - } - } - } - else + if (PerlIONext(f)) { - if (l->next) - { - l->flags |= l->next->flags & - (PERLIO_F_CANREAD|PERLIO_F_CANWRITE| - PERLIO_F_TRUNCATE|PERLIO_F_APPEND|PERLIO_F_BINARY); - } + PerlIO_funcs *tab = PerlIOBase(f)->tab; + PerlIO_pop(f); + if (tab->kind & PERLIO_K_UTF8) + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + else + PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; + return 0; } - return 0; + return -1; } -IV -PerlIOBase_popped(PerlIO *f) +PerlIO * +PerlIOUtf8_fdopen(PerlIO_funcs *self, int fd,const char *mode) { - return 0; + PerlIO_funcs *tab = PerlIO_default_layer(-2); + PerlIO *f = (*tab->Fdopen)(tab,fd,mode); + if (f) + { + PerlIOl *l = PerlIOBase(f); + if (tab->kind & PERLIO_K_UTF8) + l->flags |= PERLIO_F_UTF8; + else + l->flags &= ~PERLIO_F_UTF8; + } + return f; } -SSize_t -PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count) +PerlIO * +PerlIOUtf8_open(PerlIO_funcs *self, const char *path,const char *mode) { - Off_t old = PerlIO_tell(f); - if (PerlIO_seek(f,-((Off_t)count),SEEK_CUR) == 0) + PerlIO_funcs *tab = PerlIO_default_layer(-2); + PerlIO *f = (*tab->Open)(tab,path,mode); + if (f) { - Off_t new = PerlIO_tell(f); - return old - new; + PerlIOl *l = PerlIOBase(f); + if (tab->kind & PERLIO_K_UTF8) + l->flags |= PERLIO_F_UTF8; + else + l->flags &= ~PERLIO_F_UTF8; } - return 0; -} - -IV -PerlIOBase_noop_ok(PerlIO *f) -{ - return 0; + return f; } -IV -PerlIOBase_noop_fail(PerlIO *f) -{ - return -1; +PerlIO_funcs PerlIO_utf8 = { + "utf8", + sizeof(PerlIOl), + PERLIO_K_DUMMY|PERLIO_F_UTF8, + NULL, + PerlIOUtf8_fdopen, + PerlIOUtf8_open, + NULL, + PerlIOUtf8_pushed, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, /* flush */ + NULL, /* fill */ + NULL, + NULL, + NULL, + NULL, + NULL, /* get_base */ + NULL, /* get_bufsiz */ + NULL, /* get_ptr */ + NULL, /* get_cnt */ + NULL, /* set_ptrcnt */ +}; + +PerlIO_funcs PerlIO_byte = { + "bytes", + sizeof(PerlIOl), + PERLIO_K_DUMMY, + NULL, + PerlIOUtf8_fdopen, + PerlIOUtf8_open, + NULL, + PerlIOUtf8_pushed, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, /* flush */ + NULL, /* fill */ + NULL, + NULL, + NULL, + NULL, + NULL, /* get_base */ + NULL, /* get_bufsiz */ + NULL, /* get_ptr */ + NULL, /* get_cnt */ + NULL, /* set_ptrcnt */ +}; + +PerlIO * +PerlIORaw_fdopen(PerlIO_funcs *self, int fd,const char *mode) +{ + PerlIO_funcs *tab = PerlIO_default_btm(); + return (*tab->Fdopen)(tab,fd,mode); +} + +PerlIO * +PerlIORaw_open(PerlIO_funcs *self, const char *path,const char *mode) +{ + PerlIO_funcs *tab = PerlIO_default_btm(); + return (*tab->Open)(tab,path,mode); +} + +PerlIO_funcs PerlIO_raw = { + "raw", + sizeof(PerlIOl), + PERLIO_K_DUMMY, + NULL, + PerlIORaw_fdopen, + PerlIORaw_open, + NULL, + PerlIORaw_pushed, + PerlIOBase_popped, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, /* flush */ + NULL, /* fill */ + NULL, + NULL, + NULL, + NULL, + NULL, /* get_base */ + NULL, /* get_bufsiz */ + NULL, /* get_ptr */ + NULL, /* get_cnt */ + NULL, /* set_ptrcnt */ +}; +/*--------------------------------------------------------------------------------------*/ +/*--------------------------------------------------------------------------------------*/ +/* "Methods" of the "base class" */ + +IV +PerlIOBase_fileno(PerlIO *f) +{ + return PerlIO_fileno(PerlIONext(f)); +} + +char * +PerlIO_modestr(PerlIO *f,char *buf) +{ + char *s = buf; + IV flags = PerlIOBase(f)->flags; + if (flags & PERLIO_F_APPEND) + { + *s++ = 'a'; + if (flags & PERLIO_F_CANREAD) + { + *s++ = '+'; + } + } + else if (flags & PERLIO_F_CANREAD) + { + *s++ = 'r'; + if (flags & PERLIO_F_CANWRITE) + *s++ = '+'; + } + else if (flags & PERLIO_F_CANWRITE) + { + *s++ = 'w'; + if (flags & PERLIO_F_CANREAD) + { + *s++ = '+'; + } + } +#if O_TEXT != O_BINARY + if (!(flags & PERLIO_F_CRLF)) + *s++ = 'b'; +#endif + *s = '\0'; + return buf; +} + +IV +PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +{ + PerlIOl *l = PerlIOBase(f); + const char *omode = mode; + char temp[8]; + PerlIO_funcs *tab = PerlIOBase(f)->tab; + l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE| + PERLIO_F_TRUNCATE|PERLIO_F_APPEND); + if (tab->Set_ptrcnt != NULL) + l->flags |= PERLIO_F_FASTGETS; + if (mode) + { + switch (*mode++) + { + case 'r': + l->flags |= PERLIO_F_CANREAD; + break; + case 'a': + l->flags |= PERLIO_F_APPEND|PERLIO_F_CANWRITE; + break; + case 'w': + l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE; + break; + default: + errno = EINVAL; + return -1; + } + while (*mode) + { + switch (*mode++) + { + case '+': + l->flags |= PERLIO_F_CANREAD|PERLIO_F_CANWRITE; + break; + case 'b': + l->flags &= ~PERLIO_F_CRLF; + break; + case 't': + l->flags |= PERLIO_F_CRLF; + break; + default: + errno = EINVAL; + return -1; + } + } + } + else + { + if (l->next) + { + l->flags |= l->next->flags & + (PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_TRUNCATE|PERLIO_F_APPEND); + } + } +#if 0 + PerlIO_debug("PerlIOBase_pushed f=%p %s %s fl=%08"UVxf" (%s)\n", + f,PerlIOBase(f)->tab->name,(omode) ? omode : "(Null)", + l->flags,PerlIO_modestr(f,temp)); +#endif + return 0; +} + +IV +PerlIOBase_popped(PerlIO *f) +{ + return 0; +} + +SSize_t +PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count) +{ + Off_t old = PerlIO_tell(f); + SSize_t done; + PerlIO_push(f,&PerlIO_pending,"r",Nullch,0); + done = PerlIOBuf_unread(f,vbuf,count); + PerlIOSelf(f,PerlIOBuf)->posn = old - done; + return done; +} + +IV +PerlIOBase_noop_ok(PerlIO *f) +{ + return 0; +} + +IV +PerlIOBase_noop_fail(PerlIO *f) +{ + return -1; } IV PerlIOBase_close(PerlIO *f) { IV code = 0; + PerlIO *n = PerlIONext(f); if (PerlIO_flush(f) != 0) code = -1; - if (PerlIO_close(PerlIONext(f)) != 0) + if (n && (*PerlIOBase(n)->tab->Close)(n) != 0) code = -1; PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN); return code; @@ -886,7 +1347,10 @@ PerlIOBase_clearerr(PerlIO *f) { if (f && *f) { - PerlIOBase(f)->flags &= ~PERLIO_F_ERROR; + PerlIO *n = PerlIONext(f); + PerlIOBase(f)->flags &= ~(PERLIO_F_ERROR|PERLIO_F_EOF); + if (n) + PerlIO_clearerr(n); } } @@ -943,6 +1407,20 @@ PerlIOUnix_oflags(const char *mode) oflags |= O_WRONLY; break; } + if (*mode == 'b') + { + oflags |= O_BINARY; + oflags &= ~O_TEXT; + mode++; + } + else if (*mode == 't') + { + oflags |= O_TEXT; + oflags &= ~O_BINARY; + mode++; + } + /* Always open in binary mode */ + oflags |= O_BINARY; if (*mode || oflags == -1) { errno = EINVAL; @@ -957,9 +1435,24 @@ PerlIOUnix_fileno(PerlIO *f) return PerlIOSelf(f,PerlIOUnix)->fd; } +IV +PerlIOUnix_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +{ + IV code = PerlIOBase_pushed(f,mode,arg,len); + if (*PerlIONext(f)) + { + PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix); + s->fd = PerlIO_fileno(PerlIONext(f)); + s->oflags = PerlIOUnix_oflags(mode); + } + PerlIOBase(f)->flags |= PERLIO_F_OPEN; + return code; +} + PerlIO * PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode) { + dTHX; PerlIO *f = NULL; if (*mode == 'I') mode++; @@ -968,10 +1461,9 @@ PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode) int oflags = PerlIOUnix_oflags(mode); if (oflags != -1) { - PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix); + PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix); s->fd = fd; s->oflags = oflags; - PerlIOBase(f)->flags |= PERLIO_F_OPEN; } } return f; @@ -980,6 +1472,7 @@ PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode) PerlIO * PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode) { + dTHX; PerlIO *f = NULL; int oflags = PerlIOUnix_oflags(mode); if (oflags != -1) @@ -987,7 +1480,7 @@ PerlIOUnix_open(PerlIO_funcs *self, const char *path,const char *mode) int fd = PerlLIO_open3(path,oflags,0666); if (fd >= 0) { - PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOUnix); + PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix); s->fd = fd; s->oflags = oflags; PerlIOBase(f)->flags |= PERLIO_F_OPEN; @@ -1005,6 +1498,7 @@ PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f) (*PerlIOBase(f)->tab->Close)(f); if (oflags != -1) { + dTHX; int fd = PerlLIO_open3(path,oflags,0666); if (fd >= 0) { @@ -1020,6 +1514,7 @@ PerlIOUnix_reopen(const char *path, const char *mode, PerlIO *f) SSize_t PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count) { + dTHX; int fd = PerlIOSelf(f,PerlIOUnix)->fd; if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) return 0; @@ -1034,12 +1529,14 @@ PerlIOUnix_read(PerlIO *f, void *vbuf, Size_t count) PerlIOBase(f)->flags |= PERLIO_F_EOF; return len; } + PERL_ASYNC_CHECK(); } } SSize_t PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count) { + dTHX; int fd = PerlIOSelf(f,PerlIOUnix)->fd; while (1) { @@ -1050,12 +1547,14 @@ PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count) PerlIOBase(f)->flags |= PERLIO_F_ERROR; return len; } + PERL_ASYNC_CHECK(); } } IV PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence) { + dTHX; Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence); PerlIOBase(f)->flags &= ~PERLIO_F_EOF; return (new == (Off_t) -1) ? -1 : 0; @@ -1064,12 +1563,15 @@ PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence) Off_t PerlIOUnix_tell(PerlIO *f) { + dTHX; + Off_t posn = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR); return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR); } IV PerlIOUnix_close(PerlIO *f) { + dTHX; int fd = PerlIOSelf(f,PerlIOUnix)->fd; int code = 0; while (PerlLIO_close(fd) != 0) @@ -1079,6 +1581,7 @@ PerlIOUnix_close(PerlIO *f) code = -1; break; } + PERL_ASYNC_CHECK(); } if (code == 0) { @@ -1090,12 +1593,12 @@ PerlIOUnix_close(PerlIO *f) PerlIO_funcs PerlIO_unix = { "unix", sizeof(PerlIOUnix), - 0, + PERLIO_K_RAW, PerlIOUnix_fileno, PerlIOUnix_fdopen, PerlIOUnix_open, PerlIOUnix_reopen, - PerlIOBase_pushed, + PerlIOUnix_pushed, PerlIOBase_noop_ok, PerlIOUnix_read, PerlIOBase_unread, @@ -1128,15 +1631,33 @@ typedef struct IV PerlIOStdio_fileno(PerlIO *f) { - return fileno(PerlIOSelf(f,PerlIOStdio)->stdio); + dTHX; + return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio); } +char * +PerlIOStdio_mode(const char *mode,char *tmode) +{ + char *ret = tmode; + while (*mode) + { + *tmode++ = *mode++; + } + if (O_BINARY != O_TEXT) + { + *tmode++ = 'b'; + } + *tmode = '\0'; + return ret; +} PerlIO * PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode) { + dTHX; PerlIO *f = NULL; int init = 0; + char tmode[8]; if (*mode == 'I') { init = 1; @@ -1150,35 +1671,56 @@ PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode) switch(fd) { case 0: - stdio = stdin; + stdio = PerlSIO_stdin; break; case 1: - stdio = stdout; + stdio = PerlSIO_stdout; break; case 2: - stdio = stderr; + stdio = PerlSIO_stderr; break; } } else - stdio = fdopen(fd,mode); + { + stdio = PerlSIO_fdopen(fd,mode = PerlIOStdio_mode(mode,tmode)); + } if (stdio) { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio); + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio); s->stdio = stdio; } } return f; } +/* This isn't used yet ... */ +IV +PerlIOStdio_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +{ + dTHX; + if (*PerlIONext(f)) + { + PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio); + char tmode[8]; + FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode)); + if (stdio) + s->stdio = stdio; + else + return -1; + } + return PerlIOBase_pushed(f,mode,arg,len); +} + #undef PerlIO_importFILE PerlIO * PerlIO_importFILE(FILE *stdio, int fl) { + dTHX; PerlIO *f = NULL; if (stdio) { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),&PerlIO_stdio,"r+"),PerlIOStdio); + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio); s->stdio = stdio; } return f; @@ -1187,11 +1729,15 @@ PerlIO_importFILE(FILE *stdio, int fl) PerlIO * PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode) { + dTHX; PerlIO *f = NULL; - FILE *stdio = fopen(path,mode); + FILE *stdio = PerlSIO_fopen(path,mode); if (stdio) { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(),self,mode),PerlIOStdio); + char tmode[8]; + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self, + (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0), + PerlIOStdio); s->stdio = stdio; } return f; @@ -1200,8 +1746,10 @@ PerlIOStdio_open(PerlIO_funcs *self, const char *path,const char *mode) int PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f) { + dTHX; PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio); - FILE *stdio = freopen(path,mode,s->stdio); + char tmode[8]; + FILE *stdio = PerlSIO_freopen(path,(mode = PerlIOStdio_mode(mode,tmode)),s->stdio); if (!s->stdio) return -1; s->stdio = stdio; @@ -1211,6 +1759,7 @@ PerlIOStdio_reopen(const char *path, const char *mode, PerlIO *f) SSize_t PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count) { + dTHX; FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio; SSize_t got = 0; if (count == 1) @@ -1219,7 +1768,7 @@ PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count) /* Perl is expecting PerlIO_getc() to fill the buffer * Linux's stdio does not do that for fread() */ - int ch = fgetc(s); + int ch = PerlSIO_fgetc(s); if (ch != EOF) { *buf = ch; @@ -1227,20 +1776,21 @@ PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count) } } else - got = fread(vbuf,1,count,s); + got = PerlSIO_fread(vbuf,1,count,s); return got; } SSize_t PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count) { + dTHX; FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio; STDCHAR *buf = ((STDCHAR *)vbuf)+count-1; SSize_t unread = 0; while (count > 0) { int ch = *buf-- & 0xff; - if (ungetc(ch,s) != ch) + if (PerlSIO_ungetc(ch,s) != ch) break; unread++; count--; @@ -1251,36 +1801,54 @@ PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count) SSize_t PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count) { - return fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio); + dTHX; + return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio); } IV PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence) { + dTHX; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; - return fseek(stdio,offset,whence); + return PerlSIO_fseek(stdio,offset,whence); } Off_t PerlIOStdio_tell(PerlIO *f) { + dTHX; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; - return ftell(stdio); + return PerlSIO_ftell(stdio); } IV PerlIOStdio_close(PerlIO *f) { - return fclose(PerlIOSelf(f,PerlIOStdio)->stdio); + dTHX; +#ifdef HAS_SOCKET + int optval, optlen = sizeof(int); +#endif + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + return( +#ifdef HAS_SOCKET + (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ? + PerlSIO_fclose(stdio) : + close(PerlIO_fileno(f)) +#else + PerlSIO_fclose(stdio) +#endif + ); + } IV PerlIOStdio_flush(PerlIO *f) { + dTHX; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { - return fflush(stdio); + return PerlSIO_fflush(stdio); } else { @@ -1292,7 +1860,7 @@ PerlIOStdio_flush(PerlIO *f) */ /* Not writeable - sync by attempting a seek */ int err = errno; - if (fseek(stdio,(Off_t) 0, SEEK_CUR) != 0) + if (PerlSIO_fseek(stdio,(Off_t) 0, SEEK_CUR) != 0) errno = err; #endif } @@ -1302,12 +1870,17 @@ PerlIOStdio_flush(PerlIO *f) IV PerlIOStdio_fill(PerlIO *f) { + dTHX; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; int c; - if (fflush(stdio) != 0) - return EOF; - c = fgetc(stdio); - if (c == EOF || ungetc(c,stdio) != c) + /* fflush()ing read-only streams can cause trouble on some stdio-s */ + if ((PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) + { + if (PerlSIO_fflush(stdio) != 0) + return EOF; + } + c = PerlSIO_fgetc(stdio); + if (c == EOF || PerlSIO_ungetc(c,stdio) != c) return EOF; return 0; } @@ -1315,28 +1888,32 @@ PerlIOStdio_fill(PerlIO *f) IV PerlIOStdio_eof(PerlIO *f) { - return feof(PerlIOSelf(f,PerlIOStdio)->stdio); + dTHX; + return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio); } IV PerlIOStdio_error(PerlIO *f) { - return ferror(PerlIOSelf(f,PerlIOStdio)->stdio); + dTHX; + return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio); } void PerlIOStdio_clearerr(PerlIO *f) { - clearerr(PerlIOSelf(f,PerlIOStdio)->stdio); + dTHX; + PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio); } void PerlIOStdio_setlinebuf(PerlIO *f) { + dTHX; #ifdef HAS_SETLINEBUF - setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio); + PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio); #else - setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0); + PerlSIO_setvbuf(PerlIOSelf(f,PerlIOStdio)->stdio, Nullch, _IOLBF, 0); #endif } @@ -1344,15 +1921,17 @@ PerlIOStdio_setlinebuf(PerlIO *f) STDCHAR * PerlIOStdio_get_base(PerlIO *f) { + dTHX; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; - return FILE_base(stdio); + return PerlSIO_get_base(stdio); } Size_t PerlIOStdio_get_bufsiz(PerlIO *f) { + dTHX; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; - return FILE_bufsiz(stdio); + return PerlSIO_get_bufsiz(stdio); } #endif @@ -1360,30 +1939,33 @@ PerlIOStdio_get_bufsiz(PerlIO *f) STDCHAR * PerlIOStdio_get_ptr(PerlIO *f) { + dTHX; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; - return FILE_ptr(stdio); + return PerlSIO_get_ptr(stdio); } SSize_t PerlIOStdio_get_cnt(PerlIO *f) { + dTHX; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; - return FILE_cnt(stdio); + return PerlSIO_get_cnt(stdio); } void PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt) { + dTHX; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; if (ptr != NULL) { #ifdef STDIO_PTR_LVALUE - FILE_ptr(stdio) = ptr; + PerlSIO_set_ptr(stdio,ptr); #ifdef STDIO_PTR_LVAL_SETS_CNT - if (FILE_cnt(stdio) != (cnt)) + if (PerlSIO_get_cnt(stdio) != (cnt)) { dTHX; - assert(FILE_cnt(stdio) == (cnt)); + assert(PerlSIO_get_cnt(stdio) == (cnt)); } #endif #if (!defined(STDIO_PTR_LVAL_NOCHANGE_CNT)) @@ -1391,17 +1973,17 @@ PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt) return; #endif #else /* STDIO_PTR_LVALUE */ - abort(); + PerlProc_abort(); #endif /* STDIO_PTR_LVALUE */ } /* Now (or only) set cnt */ #ifdef STDIO_CNT_LVALUE - FILE_cnt(stdio) = cnt; + PerlSIO_set_cnt(stdio,cnt); #else /* STDIO_CNT_LVALUE */ #if (defined(STDIO_PTR_LVALUE) && defined(STDIO_PTR_LVAL_SETS_CNT)) - FILE_ptr(stdio) = FILE_ptr(stdio)+(FILE_cnt(stdio)-cnt); + PerlSIO_set_ptr(stdio,PerlSIO_get_ptr(stdio)+(PerlSIO_get_cnt(stdio)-cnt)); #else /* STDIO_PTR_LVAL_SETS_CNT */ - abort(); + PerlProc_abort(); #endif /* STDIO_PTR_LVAL_SETS_CNT */ #endif /* STDIO_CNT_LVALUE */ } @@ -1411,7 +1993,7 @@ PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt) PerlIO_funcs PerlIO_stdio = { "stdio", sizeof(PerlIOStdio), - 0, + PERLIO_K_BUFFERED, PerlIOStdio_fileno, PerlIOStdio_fdopen, PerlIOStdio_open, @@ -1456,15 +2038,31 @@ PerlIO_funcs PerlIO_stdio = { FILE * PerlIO_exportFILE(PerlIO *f, int fl) { + FILE *stdio; PerlIO_flush(f); - /* Should really push stdio discipline when we have them */ - return fdopen(PerlIO_fileno(f),"r+"); + stdio = fdopen(PerlIO_fileno(f),"r+"); + if (stdio) + { + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio); + s->stdio = stdio; + } + return stdio; } #undef PerlIO_findFILE FILE * PerlIO_findFILE(PerlIO *f) { + PerlIOl *l = *f; + while (l) + { + if (l->tab == &PerlIO_stdio) + { + PerlIOStdio *s = PerlIOSelf(&l,PerlIOStdio); + return s->stdio; + } + l = *PerlIONext(&l); + } return PerlIO_exportFILE(f,0); } @@ -1477,9 +2075,18 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f) /*--------------------------------------------------------------------------------------*/ /* perlio buffer layer */ +IV +PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + b->posn = PerlIO_tell(PerlIONext(f)); + return PerlIOBase_pushed(f,mode,arg,len); +} + PerlIO * PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode) { + dTHX; PerlIO_funcs *tab = PerlIO_default_btm(); int init = 0; PerlIO *f; @@ -1488,15 +2095,23 @@ PerlIOBuf_fdopen(PerlIO_funcs *self, int fd, const char *mode) init = 1; mode++; } +#if O_BINARY != O_TEXT + /* do something about failing setmode()? --jhi */ + PerlLIO_setmode(fd, O_BINARY); +#endif f = (*tab->Fdopen)(tab,fd,mode); if (f) { - /* Initial stderr is unbuffered */ - if (!init || fd != 2) + PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf); + if (init && fd == 2) { - PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf); - b->posn = PerlIO_tell(PerlIONext(f)); + /* Initial stderr is unbuffered */ + PerlIOBase(f)->flags |= PERLIO_F_UNBUF; } +#if 0 + PerlIO_debug("PerlIOBuf_fdopen %s f=%p fd=%d m=%s fl=%08"UVxf"\n", + self->name,f,fd,mode,PerlIOBase(f)->flags); +#endif } return f; } @@ -1508,8 +2123,7 @@ PerlIOBuf_open(PerlIO_funcs *self, const char *path, const char *mode) PerlIO *f = (*tab->Open)(tab,path,mode); if (f) { - PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,NULL),PerlIOBuf); - b->posn = PerlIO_tell(PerlIONext(f)); + PerlIO_push(f,self,mode,Nullch,0); } return f; } @@ -1520,12 +2134,7 @@ PerlIOBuf_reopen(const char *path, const char *mode, PerlIO *f) PerlIO *next = PerlIONext(f); int code = (*PerlIOBase(next)->tab->Reopen)(path,mode,next); if (code = 0) - code = (*PerlIOBase(f)->tab->Pushed)(f,mode); - if (code == 0) - { - PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); - b->posn = PerlIO_tell(PerlIONext(f)); - } + code = (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0); return code; } @@ -1540,28 +2149,30 @@ PerlIOBuf_flush(PerlIO *f) if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) { /* write() the buffer */ - STDCHAR *p = b->buf; - int count; + STDCHAR *buf = b->buf; + STDCHAR *p = buf; + PerlIO *n = PerlIONext(f); while (p < b->ptr) { - count = PerlIO_write(PerlIONext(f),p,b->ptr - p); + SSize_t count = PerlIO_write(n,p,b->ptr - p); if (count > 0) { p += count; } - else if (count < 0) + else if (count < 0 || PerlIO_error(n)) { PerlIOBase(f)->flags |= PERLIO_F_ERROR; code = -1; break; } } - b->posn += (p - b->buf); + b->posn += (p - buf); } else if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { + STDCHAR *buf = PerlIO_get_base(f); /* Note position change */ - b->posn += (b->ptr - b->buf); + b->posn += (b->ptr - buf); if (b->ptr < b->end) { /* We did not consume all of it */ @@ -1596,6 +2207,9 @@ PerlIOBuf_fill(PerlIO *f) if (PerlIO_flush(f) != 0) return -1; + if (!b->buf) + PerlIO_get_base(f); /* allocate via vtable */ + b->ptr = b->end = b->buf; if (PerlIO_fast_gets(n)) { @@ -1646,35 +2260,33 @@ PerlIOBuf_fill(PerlIO *f) SSize_t PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count) { - PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); - STDCHAR *buf = (STDCHAR *) vbuf; + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + STDCHAR *buf = (STDCHAR *) vbuf; if (f) { - Size_t got = 0; if (!b->ptr) PerlIO_get_base(f); if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) return 0; while (count > 0) { - SSize_t avail = (b->end - b->ptr); - if ((SSize_t) count < avail) - avail = count; - if (avail > 0) + SSize_t avail = PerlIO_get_cnt(f); + SSize_t take = (count < avail) ? count : avail; + if (take > 0) { - Copy(b->ptr,buf,avail,STDCHAR); - got += avail; - b->ptr += avail; - count -= avail; - buf += avail; + STDCHAR *ptr = PerlIO_get_ptr(f); + Copy(ptr,buf,take,STDCHAR); + PerlIO_set_ptrcnt(f,ptr+take,(avail -= take)); + count -= take; + buf += take; } - if (count && (b->ptr >= b->end)) + if (count > 0 && avail <= 0) { if (PerlIO_fill(f) != 0) break; } } - return got; + return (buf - (STDCHAR *) vbuf); } return 0; } @@ -1695,19 +2307,20 @@ PerlIOBuf_unread(PerlIO *f, const void *vbuf, Size_t count) if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { avail = (b->ptr - b->buf); - if (avail > (SSize_t) count) - avail = count; - b->ptr -= avail; } else { avail = b->bufsiz; - if (avail > (SSize_t) count) - avail = count; - b->end = b->ptr + avail; + b->end = b->buf + avail; + b->ptr = b->end; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; + b->posn -= b->bufsiz; } + if (avail > (SSize_t) count) + avail = count; if (avail > 0) { + b->ptr -= avail; buf -= avail; if (buf != b->ptr) { @@ -1767,16 +2380,18 @@ PerlIOBuf_write(PerlIO *f, const void *vbuf, Size_t count) if (b->ptr >= (b->buf + b->bufsiz)) PerlIO_flush(f); } + if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) + PerlIO_flush(f); return written; } IV PerlIOBuf_seek(PerlIO *f, Off_t offset, int whence) { - PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); - int code = PerlIO_flush(f); - if (code == 0) + IV code; + if ((code = PerlIO_flush(f)) == 0) { + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); PerlIOBase(f)->flags &= ~PERLIO_F_EOF; code = PerlIO_seek(PerlIONext(f),offset,whence); if (code == 0) @@ -1800,11 +2415,12 @@ PerlIOBuf_tell(PerlIO *f) IV PerlIOBuf_close(PerlIO *f) { + dTHX; IV code = PerlIOBase_close(f); PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); if (b->buf && b->buf != (STDCHAR *) &b->oneword) { - Safefree(b->buf); + PerlMemShared_free(b->buf); } b->buf = NULL; b->ptr = b->end = b->buf; @@ -1847,9 +2463,10 @@ PerlIOBuf_get_base(PerlIO *f) PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); if (!b->buf) { + dTHX; if (!b->bufsiz) b->bufsiz = 4096; - New('B',b->buf,b->bufsiz,STDCHAR); + b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR)); if (!b->buf) { b->buf = (STDCHAR *)&b->oneword; @@ -1889,12 +2506,12 @@ PerlIOBuf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) PerlIO_funcs PerlIO_perlio = { "perlio", sizeof(PerlIOBuf), - 0, + PERLIO_K_BUFFERED, PerlIOBase_fileno, PerlIOBuf_fdopen, PerlIOBuf_open, PerlIOBuf_reopen, - PerlIOBase_pushed, + PerlIOBuf_pushed, PerlIOBase_noop_ok, PerlIOBuf_read, PerlIOBuf_unread, @@ -1916,27 +2533,413 @@ PerlIO_funcs PerlIO_perlio = { }; /*--------------------------------------------------------------------------------------*/ -/* crlf - translation currently just a copy of perlio to prove - that extra buffering which real one will do is not an issue. +/* Temp layer to hold unread chars when cannot do it any other way */ + +IV +PerlIOPending_fill(PerlIO *f) +{ + /* Should never happen */ + PerlIO_flush(f); + return 0; +} + +IV +PerlIOPending_close(PerlIO *f) +{ + /* A tad tricky - flush pops us, then we close new top */ + PerlIO_flush(f); + return PerlIO_close(f); +} + +IV +PerlIOPending_seek(PerlIO *f, Off_t offset, int whence) +{ + /* A tad tricky - flush pops us, then we seek new top */ + PerlIO_flush(f); + return PerlIO_seek(f,offset,whence); +} + + +IV +PerlIOPending_flush(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (b->buf && b->buf != (STDCHAR *) &b->oneword) + { + dTHX; + PerlMemShared_free(b->buf); + b->buf = NULL; + } + PerlIO_pop(f); + return 0; +} + +void +PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) +{ + if (cnt <= 0) + { + PerlIO_flush(f); + } + else + { + PerlIOBuf_set_ptrcnt(f,ptr,cnt); + } +} + +IV +PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len) +{ + IV code = PerlIOBase_pushed(f,mode,arg,len); + PerlIOl *l = PerlIOBase(f); + /* Our PerlIO_fast_gets must match what we are pushed on, + or sv_gets() etc. get muddled when it changes mid-string + when we auto-pop. + */ + l->flags = (l->flags & ~(PERLIO_F_FASTGETS|PERLIO_F_UTF8)) | + (PerlIOBase(PerlIONext(f))->flags & (PERLIO_F_FASTGETS|PERLIO_F_UTF8)); + return code; +} + +SSize_t +PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count) +{ + SSize_t avail = PerlIO_get_cnt(f); + SSize_t got = 0; + if (count < avail) + avail = count; + if (avail > 0) + got = PerlIOBuf_read(f,vbuf,avail); + if (got < count) + got += PerlIO_read(f,((STDCHAR *) vbuf)+got,count-got); + return got; +} + + +PerlIO_funcs PerlIO_pending = { + "pending", + sizeof(PerlIOBuf), + PERLIO_K_BUFFERED, + PerlIOBase_fileno, + NULL, + NULL, + NULL, + PerlIOPending_pushed, + PerlIOBase_noop_ok, + PerlIOPending_read, + PerlIOBuf_unread, + PerlIOBuf_write, + PerlIOPending_seek, + PerlIOBuf_tell, + PerlIOPending_close, + PerlIOPending_flush, + PerlIOPending_fill, + PerlIOBase_eof, + PerlIOBase_error, + PerlIOBase_clearerr, + PerlIOBuf_setlinebuf, + PerlIOBuf_get_base, + PerlIOBuf_bufsiz, + PerlIOBuf_get_ptr, + PerlIOBuf_get_cnt, + PerlIOPending_set_ptrcnt, +}; + + + +/*--------------------------------------------------------------------------------------*/ +/* 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. + On write translate "\n" to CR,LF */ +typedef struct +{ + PerlIOBuf base; /* PerlIOBuf stuff */ + STDCHAR *nl; /* Position of crlf we "lied" about in the buffer */ +} PerlIOCrlf; + +IV +PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len) +{ + IV code; + PerlIOBase(f)->flags |= PERLIO_F_CRLF; + code = PerlIOBuf_pushed(f,mode,arg,len); +#if 0 + PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n", + f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)", + PerlIOBase(f)->flags); +#endif + return code; +} + + +SSize_t +PerlIOCrlf_unread(PerlIO *f, const void *vbuf, Size_t count) +{ + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); + if (c->nl) + { + *(c->nl) = 0xd; + c->nl = NULL; + } + if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) + return PerlIOBuf_unread(f,vbuf,count); + else + { + const STDCHAR *buf = (const STDCHAR *) vbuf+count; + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + SSize_t unread = 0; + if (PerlIOBase(f)->flags & PERLIO_F_WRBUF) + PerlIO_flush(f); + if (!b->buf) + PerlIO_get_base(f); + if (b->buf) + { + if (!(PerlIOBase(f)->flags & PERLIO_F_RDBUF)) + { + b->end = b->ptr = b->buf + b->bufsiz; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; + b->posn -= b->bufsiz; + } + while (count > 0 && b->ptr > b->buf) + { + int ch = *--buf; + if (ch == '\n') + { + if (b->ptr - 2 >= b->buf) + { + *--(b->ptr) = 0xa; + *--(b->ptr) = 0xd; + unread++; + count--; + } + else + { + buf++; + break; + } + } + else + { + *--(b->ptr) = ch; + unread++; + count--; + } + } + } + return unread; + } +} + +SSize_t +PerlIOCrlf_get_cnt(PerlIO *f) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + if (!b->buf) + PerlIO_get_base(f); + if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) + { + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); + if ((PerlIOBase(f)->flags & PERLIO_F_CRLF) && !c->nl) + { + STDCHAR *nl = b->ptr; + scan: + while (nl < b->end && *nl != 0xd) + nl++; + if (nl < b->end && *nl == 0xd) + { + test: + if (nl+1 < b->end) + { + if (nl[1] == 0xa) + { + *nl = '\n'; + c->nl = nl; + } + else + { + /* Not CR,LF but just CR */ + nl++; + goto scan; + } + } + else + { + /* 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); + } + else + { + int code; + dTHX; + b->ptr++; /* say we have read it as far as flush() is concerned */ + b->buf++; /* Leave space an front of buffer */ + b->bufsiz--; /* Buffer is thus smaller */ + code = PerlIO_fill(f); /* Fetch some more */ + b->bufsiz++; /* Restore size for next time */ + b->buf--; /* Point at space */ + 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) + goto test; /* fill() call worked */ + /* CR at EOF - just fall through */ + } + } + } + } + return (((c->nl) ? (c->nl+1) : b->end) - b->ptr); + } + return 0; +} + +void +PerlIOCrlf_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) +{ + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); + IV flags = PerlIOBase(f)->flags; + if (!b->buf) + PerlIO_get_base(f); + if (!ptr) + { + if (c->nl) + ptr = c->nl+1; + else + { + ptr = b->end; + if ((flags & PERLIO_F_CRLF) && ptr > b->buf && ptr[-1] == 0xd) + ptr--; + } + ptr -= cnt; + } + else + { + /* Test code - delete when it works ... */ + STDCHAR *chk; + if (c->nl) + chk = c->nl+1; + else + { + chk = b->end; + if ((flags & PERLIO_F_CRLF) && chk > b->buf && chk[-1] == 0xd) + chk--; + } + chk -= cnt; + + if (ptr != chk) + { + dTHX; + Perl_croak(aTHX_ "ptr wrong %p != %p fl=%08"UVxf" nl=%p e=%p for %d", + ptr, chk, flags, c->nl, b->end, cnt); + } + } + if (c->nl) + { + if (ptr > c->nl) + { + /* They have taken what we lied about */ + *(c->nl) = 0xd; + c->nl = NULL; + ptr++; + } + } + b->ptr = ptr; + PerlIOBase(f)->flags |= PERLIO_F_RDBUF; +} + +SSize_t +PerlIOCrlf_write(PerlIO *f, const void *vbuf, Size_t count) +{ + if (!(PerlIOBase(f)->flags & PERLIO_F_CRLF)) + return PerlIOBuf_write(f,vbuf,count); + else + { + PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); + const STDCHAR *buf = (const STDCHAR *) vbuf; + const STDCHAR *ebuf = buf+count; + if (!b->buf) + PerlIO_get_base(f); + if (!(PerlIOBase(f)->flags & PERLIO_F_CANWRITE)) + return 0; + while (buf < ebuf) + { + STDCHAR *eptr = b->buf+b->bufsiz; + PerlIOBase(f)->flags |= PERLIO_F_WRBUF; + while (buf < ebuf && b->ptr < eptr) + { + if (*buf == '\n') + { + if ((b->ptr + 2) > eptr) + { + /* Not room for both */ + 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 + { + int ch = *buf++; + *(b->ptr)++ = ch; + } + if (b->ptr >= eptr) + { + PerlIO_flush(f); + break; + } + } + } + if (PerlIOBase(f)->flags & PERLIO_F_UNBUF) + PerlIO_flush(f); + return (buf - (STDCHAR *) vbuf); + } +} + +IV +PerlIOCrlf_flush(PerlIO *f) +{ + PerlIOCrlf *c = PerlIOSelf(f,PerlIOCrlf); + if (c->nl) + { + *(c->nl) = 0xd; + c->nl = NULL; + } + return PerlIOBuf_flush(f); +} + PerlIO_funcs PerlIO_crlf = { "crlf", - sizeof(PerlIOBuf), - 0, + sizeof(PerlIOCrlf), + PERLIO_K_BUFFERED|PERLIO_K_CANCRLF, PerlIOBase_fileno, PerlIOBuf_fdopen, PerlIOBuf_open, PerlIOBuf_reopen, - PerlIOBase_pushed, - PerlIOBase_noop_ok, - PerlIOBuf_read, - PerlIOBuf_unread, - PerlIOBuf_write, + PerlIOCrlf_pushed, + PerlIOBase_noop_ok, /* popped */ + PerlIOBuf_read, /* generic read works with ptr/cnt lies ... */ + PerlIOCrlf_unread, /* Put CR,LF in buffer for each '\n' */ + PerlIOCrlf_write, /* Put CR,LF in buffer for each '\n' */ PerlIOBuf_seek, PerlIOBuf_tell, PerlIOBuf_close, - PerlIOBuf_flush, + PerlIOCrlf_flush, PerlIOBuf_fill, PerlIOBase_eof, PerlIOBase_error, @@ -1945,8 +2948,8 @@ PerlIO_funcs PerlIO_crlf = { PerlIOBuf_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, - PerlIOBuf_get_cnt, - PerlIOBuf_set_ptrcnt, + PerlIOCrlf_get_cnt, + PerlIOCrlf_set_ptrcnt, }; #ifdef HAS_MMAP @@ -1959,7 +2962,6 @@ typedef struct Mmap_t mptr; /* Mapped address */ Size_t len; /* mapped length */ STDCHAR *bbuf; /* malloced buffer if map fails */ - } PerlIOMmap; static size_t page_size = 0; @@ -2027,12 +3029,15 @@ PerlIOMmap_map(PerlIO *f) } posn = (b->posn / page_size) * page_size; len = st.st_size - posn; - m->mptr = mmap(NULL, len, PROT_READ, MAP_PRIVATE, fd, posn); + m->mptr = mmap(NULL, len, PROT_READ, MAP_SHARED, fd, posn); if (m->mptr && m->mptr != (Mmap_t) -1) { -#if defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL) +#if 0 && defined(HAS_MADVISE) && defined(MADV_SEQUENTIAL) madvise(m->mptr, len, MADV_SEQUENTIAL); #endif +#if 0 && defined(HAS_MADVISE) && defined(MADV_WILLNEED) + madvise(m->mptr, len, MADV_WILLNEED); +#endif PerlIOBase(f)->flags = (flags & ~PERLIO_F_EOF) | PERLIO_F_RDBUF; b->end = ((STDCHAR *)m->mptr) + len; b->buf = ((STDCHAR *)m->mptr) + (b->posn - posn); @@ -2136,7 +3141,7 @@ PerlIOMmap_unread(PerlIO *f, const void *vbuf, Size_t count) m->bbuf = b->buf; } } - return PerlIOBuf_unread(f,vbuf,count); +return PerlIOBuf_unread(f,vbuf,count); } SSize_t @@ -2227,12 +3232,12 @@ PerlIOMmap_close(PerlIO *f) PerlIO_funcs PerlIO_mmap = { "mmap", sizeof(PerlIOMmap), - 0, + PERLIO_K_BUFFERED, PerlIOBase_fileno, PerlIOBuf_fdopen, PerlIOBuf_open, PerlIOBuf_reopen, - PerlIOBase_pushed, + PerlIOBuf_pushed, PerlIOBase_noop_ok, PerlIOBuf_read, PerlIOMmap_unread, @@ -2260,10 +3265,14 @@ PerlIO_init(void) { if (!_perlio) { +#ifndef WIN32 atexit(&PerlIO_cleanup); +#endif } } + + #undef PerlIO_stdin PerlIO * PerlIO_stdin(void) @@ -2366,7 +3375,13 @@ PerlIO_vprintf(PerlIO *f, const char *fmt, va_list ap) SV *sv = newSVpvn("",0); char *s; STRLEN len; +#ifdef NEED_VA_COPY + va_list apc; + Perl_va_copy(ap, apc); + sv_vcatpvf(sv, fmt, &apc); +#else sv_vcatpvf(sv, fmt, &ap); +#endif s = SvPV(sv,len); return PerlIO_write(f,s,len); } @@ -2399,8 +3414,19 @@ PerlIO_stdoutf(const char *fmt,...) PerlIO * PerlIO_tmpfile(void) { - dTHX; /* I have no idea how portable mkstemp() is ... */ +#if defined(WIN32) || !defined(HAVE_MKSTEMP) + dTHX; + PerlIO *f = NULL; + FILE *stdio = PerlSIO_tmpfile(); + if (stdio) + { + PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio); + s->stdio = stdio; + } + return f; +#else + dTHX; SV *sv = newSVpv("/tmp/PerlIO_XXXXXX",0); int fd = mkstemp(SvPVX(sv)); PerlIO *f = NULL; @@ -2415,6 +3441,7 @@ PerlIO_tmpfile(void) SvREFCNT_dec(sv); } return f; +#endif } #undef HAS_FSETPOS @@ -2431,47 +3458,70 @@ PerlIO_tmpfile(void) #ifndef HAS_FSETPOS #undef PerlIO_setpos int -PerlIO_setpos(PerlIO *f, const Fpos_t *pos) +PerlIO_setpos(PerlIO *f, SV *pos) { - return PerlIO_seek(f,*pos,0); + dTHX; + if (SvOK(pos)) + { + STRLEN len; + Off_t *posn = (Off_t *) SvPV(pos,len); + if (f && len == sizeof(Off_t)) + return PerlIO_seek(f,*posn,SEEK_SET); + } + errno = EINVAL; + return -1; } #else -#ifndef PERLIO_IS_STDIO #undef PerlIO_setpos int -PerlIO_setpos(PerlIO *f, const Fpos_t *pos) +PerlIO_setpos(PerlIO *f, SV *pos) { + dTHX; + if (SvOK(pos)) + { + STRLEN len; + Fpos_t *fpos = (Fpos_t *) SvPV(pos,len); + if (f && len == sizeof(Fpos_t)) + { #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) - return fsetpos64(f, pos); + return fsetpos64(f, fpos); #else - return fsetpos(f, pos); + return fsetpos(f, fpos); #endif + } + } + errno = EINVAL; + return -1; } #endif -#endif #ifndef HAS_FGETPOS #undef PerlIO_getpos int -PerlIO_getpos(PerlIO *f, Fpos_t *pos) +PerlIO_getpos(PerlIO *f, SV *pos) { - *pos = PerlIO_tell(f); - return *pos == -1 ? -1 : 0; + dTHX; + Off_t posn = PerlIO_tell(f); + sv_setpvn(pos,(char *)&posn,sizeof(posn)); + return (posn == (Off_t)-1) ? -1 : 0; } #else -#ifndef PERLIO_IS_STDIO #undef PerlIO_getpos int -PerlIO_getpos(PerlIO *f, Fpos_t *pos) +PerlIO_getpos(PerlIO *f, SV *pos) { + dTHX; + Fpos_t fpos; + int code; #if defined(USE_64_BIT_STDIO) && defined(USE_FSETPOS64) - return fgetpos64(f, pos); + code = fgetpos64(f, &fpos); #else - return fgetpos(f, pos); + code = fgetpos(f, &fpos); #endif + sv_setpvn(pos,(char *)&fpos,sizeof(fpos)); + return code; } #endif -#endif #if (defined(PERLIO_IS_STDIO) || !defined(USE_SFIO)) && !defined(HAS_VPRINTF) @@ -2523,5 +3573,4 @@ PerlIO_sprintf(char *s, int n, const char *fmt,...) } #endif -#endif /* !PERL_IMPLICIT_SYS */