X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perlio.c;h=005e7f81e1e30e722a509cc20abc5904d6c9ae03;hb=19d75edaf35287dfc8bc9b6f13bb73a2ca28b226;hp=d192892a0f4c62e6c76c2cd8cbf1ddf696344168;hpb=ee518936bd3eee0065c20591f5182f733dadd4bd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perlio.c b/perlio.c index d192892..005e7f8 100644 --- a/perlio.c +++ b/perlio.c @@ -7,6 +7,17 @@ * */ +/* If we have ActivePerl-like PERL_IMPLICIT_SYS then we need + a dTHX to get at the dispatch tables, even when we do not + need it for other reasons. + Invent a dSYS macro to abstract this out +*/ +#ifdef PERL_IMPLICIT_SYS +#define dSYS dTHX +#else +#define dSYS dNOOP +#endif + #define VOIDUSED 1 #ifdef PERL_MICRO # include "uconfig.h" @@ -93,10 +104,19 @@ PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) return -1; } +void +PerlIO_destruct(pTHX) +{ +} + int PerlIO_binmode(pTHX_ PerlIO *fp, int iotype, int mode, const char *names) { +#ifdef USE_SFIO + return 1; +#else return perlsio_binmode(fp,iotype,mode); +#endif } /* De-mux PerlIO_openn() into fdopen, freopen and fopen type entries */ @@ -106,25 +126,30 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int { if (narg == 1) { - char *name = SvPV_nolen(*args); - if (*mode == '#') - { - fd = PerlLIO_open3(name,imode,perm); - if (fd >= 0) - return PerlIO_fdopen(fd,mode+1); - } - else if (old) - { - return PerlIO_reopen(name,mode,old); - } + if (*args == &PL_sv_undef) + return PerlIO_tmpfile(); else { - return PerlIO_open(name,mode); + char *name = SvPV_nolen(*args); + if (*mode == '#') + { + fd = PerlLIO_open3(name,imode,perm); + if (fd >= 0) + return PerlIO_fdopen(fd,(char *)mode+1); + } + else if (old) + { + return PerlIO_reopen(name,mode,old); + } + else + { + return PerlIO_open(name,mode); + } } } else { - return PerlIO_fdopen(fd,mode); + return PerlIO_fdopen(fd,(char *)mode); } return NULL; } @@ -185,6 +210,28 @@ PerlIO_init(void) sfset(sfstdout,SF_SHARE,0); } +PerlIO * +PerlIO_importFILE(FILE *stdio, int fl) +{ + int fd = fileno(stdio); + PerlIO *r = PerlIO_fdopen(fd,"r+"); + return r; +} + +FILE * +PerlIO_findFILE(PerlIO *pio) +{ + int fd = PerlIO_fileno(pio); + FILE *f = fdopen(fd,"r+"); + PerlIO_flush(pio); + if (!f && errno == EINVAL) + f = fdopen(fd,"w"); + if (!f && errno == EINVAL) + f = fdopen(fd,"r"); + return f; +} + + #else /* USE_SFIO */ /*======================================================================================*/ /* Implement all the PerlIO interface ourselves. @@ -207,9 +254,9 @@ 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; + dSYS; va_start(ap,fmt); if (!dbg) { @@ -246,6 +293,8 @@ PerlIO_debug(const char *fmt,...) PerlIO *_perlio = NULL; #define PERLIO_TABLE_SIZE 64 + + PerlIO * PerlIO_allocate(pTHX) { @@ -299,6 +348,13 @@ HV *PerlIO_layer_hv; AV *PerlIO_layer_av; void +PerlIO_cleanup_layers(pTHXo_ void *data) +{ + PerlIO_layer_hv = Nullhv; + PerlIO_layer_av = Nullav; +} + +void PerlIO_cleanup() { dTHX; @@ -306,9 +362,39 @@ PerlIO_cleanup() } void -PerlIO_pop(PerlIO *f) +PerlIO_destruct(pTHX) +{ + PerlIO **table = &_perlio; + PerlIO *f; + while ((f = *table)) + { + int i; + table = (PerlIO **)(f++); + for (i=1; i < PERLIO_TABLE_SIZE; i++) + { + PerlIO *x = f; + PerlIOl *l; + while ((l = *x)) + { + if (l->tab->kind & PERLIO_K_DESTRUCT) + { + PerlIO_debug("Destruct popping %s\n",l->tab->name); + PerlIO_flush(x); + PerlIO_pop(aTHX_ x); + } + else + { + x = PerlIONext(x); + } + } + f++; + } + } +} + +void +PerlIO_pop(pTHX_ PerlIO *f) { - dTHX; PerlIOl *l = *f; if (l) { @@ -323,40 +409,34 @@ PerlIO_pop(PerlIO *f) /*--------------------------------------------------------------------------------------*/ /* XS Interface for perl code */ -XS(XS_perlio_import) -{ - dXSARGS; - GV *gv = CvGV(cv); - char *s = GvNAME(gv); - STRLEN l = GvNAMELEN(gv); - PerlIO_debug("%.*s\n",(int) l,s); - XSRETURN_EMPTY; -} - -XS(XS_perlio_unimport) -{ - dXSARGS; - GV *gv = CvGV(cv); - char *s = GvNAME(gv); - STRLEN l = GvNAMELEN(gv); - PerlIO_debug("%.*s\n",(int) l,s); - XSRETURN_EMPTY; -} - SV * -PerlIO_find_layer(const char *name, STRLEN len) +PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load) { - dTHX; SV **svp; SV *sv; if ((SSize_t) len <= 0) len = strlen(name); svp = hv_fetch(PerlIO_layer_hv,name,len,0); - if (svp && (sv = *svp) && SvROK(sv)) - return *svp; - return NULL; + if (!svp && load && PL_subname && PerlIO_layer_av && av_len(PerlIO_layer_av)+1 >= 2) + { + SV *pkgsv = newSVpvn("PerlIO",6); + SV *layer = newSVpvn(name,len); + ENTER; + /* The two SVs are magically freed by load_module */ + Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv); + LEAVE; + /* Say this is lvalue so we get an 'undef' if still not there */ + svp = hv_fetch(PerlIO_layer_hv,name,len,1); + } + if (svp && (sv = *svp)) + { + if (SvROK(sv)) + return *svp; + } + return Nullsv; } +#ifdef USE_ATTRIBUTES_FOR_PERLIO static int perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) @@ -366,7 +446,6 @@ perlio_mg_set(pTHX_ SV *sv, MAGIC *mg) IO *io = GvIOn((GV *)SvRV(sv)); PerlIO *ifp = IoIFP(io); PerlIO *ofp = IoOFP(io); - AV *av = (AV *) mg->mg_obj; Perl_warn(aTHX_ "set %"SVf" %p %p %p",sv,io,ifp,ofp); } return 0; @@ -380,7 +459,6 @@ perlio_mg_get(pTHX_ SV *sv, MAGIC *mg) IO *io = GvIOn((GV *)SvRV(sv)); PerlIO *ifp = IoIFP(io); PerlIO *ofp = IoOFP(io); - AV *av = (AV *) mg->mg_obj; Perl_warn(aTHX_ "get %"SVf" %p %p %p",sv,io,ifp,ofp); } return 0; @@ -404,7 +482,7 @@ MGVTBL perlio_vtab = { perlio_mg_get, perlio_mg_set, NULL, /* len */ - NULL, + perlio_mg_clear, perlio_mg_free }; @@ -416,9 +494,9 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) MAGIC *mg; int count = 0; int i; - sv_magic(sv, (SV *)av, '~', NULL, 0); + sv_magic(sv, (SV *)av, PERL_MAGIC_ext, NULL, 0); SvRMAGICAL_off(sv); - mg = mg_find(sv,'~'); + mg = mg_find(sv, PERL_MAGIC_ext); mg->mg_virtual = &perlio_vtab; mg_magical(sv); Perl_warn(aTHX_ "attrib %"SVf,sv); @@ -426,7 +504,7 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) { STRLEN len; const char *name = SvPV(ST(i),len); - SV *layer = PerlIO_find_layer(name,len); + SV *layer = PerlIO_find_layer(aTHX_ name,len,1); if (layer) { av_push(av,SvREFCNT_inc(layer)); @@ -441,22 +519,112 @@ XS(XS_io_MODIFY_SCALAR_ATTRIBUTES) XSRETURN(count); } -void -PerlIO_define_layer(PerlIO_funcs *tab) +#endif /* USE_ATTIBUTES_FOR_PERLIO */ + +SV * +PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab) { - dTHX; - HV *stash = gv_stashpv("perlio::Layer", TRUE); + HV *stash = gv_stashpv("PerlIO::Layer", TRUE); SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash); + return sv; +} + +void +PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) +{ 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); + hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),PerlIO_tab_sv(aTHX_ tab),0); PerlIO_debug("define %s %p\n",tab->name,tab); } +int +PerlIO_parse_layers(pTHX_ AV *av, const char *names) +{ + if (names) + { + const char *s = names; + while (*s) + { + while (isSPACE(*s) || *s == ':') + s++; + if (*s) + { + STRLEN llen = 0; + const char *e = s; + 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(aTHX_ s,llen,1); + if (layer) + { + av_push(av,SvREFCNT_inc(layer)); + av_push(av,(as) ? newSVpvn(as,alen) : &PL_sv_undef); + } + else { + Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s); + return -1; + } + } + s = e; + } + } + } + return 0; +} + void -PerlIO_default_buffer(pTHX) +PerlIO_default_buffer(pTHX_ AV *av) { PerlIO_funcs *tab = &PerlIO_perlio; if (O_BINARY != O_TEXT) @@ -471,99 +639,94 @@ PerlIO_default_buffer(pTHX) } } PerlIO_debug("Pushing %s\n",tab->name); - av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(tab->name,0))); + av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0,0))); + av_push(av,&PL_sv_undef); } +SV * +PerlIO_arg_fetch(pTHX_ AV *av,IV n) +{ + SV **svp = av_fetch(av,n,FALSE); + return (svp) ? *svp : Nullsv; +} PerlIO_funcs * -PerlIO_default_layer(I32 n) +PerlIO_layer_fetch(pTHX_ AV *av,IV n,PerlIO_funcs *def) { - dTHX; - SV **svp; + SV **svp = av_fetch(av,n,FALSE); SV *layer; - PerlIO_funcs *tab = &PerlIO_stdio; - int len; + if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer)))) + { + /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */ + return INT2PTR(PerlIO_funcs *, SvIV(layer)); + } + if (!def) + Perl_croak(aTHX_ "panic: PerlIO layer array corrupt"); + return def; +} + +AV * +PerlIO_default_layers(pTHX) +{ + IV len; if (!PerlIO_layer_av) { - const char *s = PerlEnv_getenv("PERLIO"); + const char *s = (PL_tainting) ? Nullch : 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 + +#ifdef USE_ATTRIBUTES_FOR_PERLIO newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__); #endif - PerlIO_define_layer(&PerlIO_raw); - PerlIO_define_layer(&PerlIO_unix); - PerlIO_define_layer(&PerlIO_perlio); - PerlIO_define_layer(&PerlIO_stdio); - PerlIO_define_layer(&PerlIO_crlf); + + PerlIO_define_layer(aTHX_ &PerlIO_raw); + PerlIO_define_layer(aTHX_ &PerlIO_unix); + PerlIO_define_layer(aTHX_ &PerlIO_perlio); + PerlIO_define_layer(aTHX_ &PerlIO_stdio); + PerlIO_define_layer(aTHX_ &PerlIO_crlf); #ifdef HAS_MMAP - PerlIO_define_layer(&PerlIO_mmap); + PerlIO_define_layer(aTHX_ &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))); + PerlIO_define_layer(aTHX_ &PerlIO_utf8); + PerlIO_define_layer(aTHX_ &PerlIO_byte); + av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ PerlIO_unix.name,0,0))); + av_push(PerlIO_layer_av,&PL_sv_undef); if (s) { - IV buffered = 0; - while (*s) - { - while (*s && isSPACE((unsigned char)*s)) - s++; - if (*s) - { - const char *e = s; - SV *layer; - while (*e && !isSPACE((unsigned char)*e)) - e++; - if (*s == ':') - s++; - 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); - s = e; - } - } + PerlIO_parse_layers(aTHX_ PerlIO_layer_av,s); + } + else + { + PerlIO_default_buffer(aTHX_ PerlIO_layer_av); } } - len = av_len(PerlIO_layer_av); - if (len < 1) + len = av_len(PerlIO_layer_av)+1; + if (len < 2) { - PerlIO_default_buffer(aTHX); + PerlIO_default_buffer(aTHX_ PerlIO_layer_av); len = av_len(PerlIO_layer_av); } + return PerlIO_layer_av; +} + + +PerlIO_funcs * +PerlIO_default_layer(pTHX_ I32 n) +{ + AV *av = PerlIO_default_layers(aTHX); + n *= 2; if (n < 0) - n += len+1; - svp = av_fetch(PerlIO_layer_av,n,0); - if (svp && (layer = *svp) && SvROK(layer) && SvIOK((layer = SvRV(layer)))) - { - tab = INT2PTR(PerlIO_funcs *, SvIV(layer)); - } - /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */ - return tab; + n += av_len(PerlIO_layer_av)+1; + return PerlIO_layer_fetch(aTHX_ av,n, &PerlIO_stdio); } -#define PerlIO_default_top() PerlIO_default_layer(-1) -#define PerlIO_default_btm() PerlIO_default_layer(0) +#define PerlIO_default_top() PerlIO_default_layer(aTHX_ -1) +#define PerlIO_default_btm() PerlIO_default_layer(aTHX_ 0) void -PerlIO_stdstreams() +PerlIO_stdstreams(pTHX) { if (!_perlio) { - dTHX; PerlIO_allocate(aTHX); PerlIO_fdopen(0,"Ir" PERLIO_STDTEXT); PerlIO_fdopen(1,"Iw" PERLIO_STDTEXT); @@ -572,9 +735,8 @@ PerlIO_stdstreams() } PerlIO * -PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN len) +PerlIO_push(pTHX_ PerlIO *f,PerlIO_funcs *tab,const char *mode,SV *arg) { - dTHX; PerlIOl *l = NULL; l = PerlMemShared_calloc(tab->size,sizeof(char)); if (l) @@ -583,11 +745,11 @@ PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN 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_debug("PerlIO_push f=%p %s %s %p\n",f,tab->name, + (mode) ? mode : "(Null)",arg); + if ((*l->tab->Pushed)(f,mode,arg) != 0) { - PerlIO_pop(f); + PerlIO_pop(aTHX_ f); return NULL; } } @@ -595,40 +757,41 @@ PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN } IV -PerlIOPop_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIOPop_pushed(PerlIO *f, const char *mode, SV *arg) { - PerlIO_pop(f); + dTHX; + PerlIO_pop(aTHX_ f); if (*f) { PerlIO_flush(f); - PerlIO_pop(f); + PerlIO_pop(aTHX_ f); return 0; } return -1; } IV -PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIORaw_pushed(PerlIO *f, const char *mode, SV *arg) { /* Remove the dummy layer */ - PerlIO_pop(f); + dTHX; + PerlIO_pop(aTHX_ 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); + PerlIO_pop(aTHX_ f); } else { /* Nothing bellow - push unix on top then remove it */ - if (PerlIO_push(f,PerlIO_default_btm(),mode,arg,len)) + if (PerlIO_push(aTHX_ f,PerlIO_default_btm(),mode,arg)) { - PerlIO_pop(PerlIONext(f)); + PerlIO_pop(aTHX_ PerlIONext(f)); } break; } @@ -640,92 +803,42 @@ PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) } int -PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) +PerlIO_apply_layera(pTHX_ PerlIO *f, const char *mode, AV *layers, IV n) { - if (names) + IV max = av_len(layers)+1; + int code = 0; + while (n < max) { - const char *s = names; - while (*s) + PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers,n,NULL); + if (tab) { - while (isSPACE(*s) || *s == ':') - s++; - if (*s) + if (!PerlIO_push(aTHX_ f,tab,mode,PerlIOArg)) { - STRLEN llen = 0; - const char *e = s; - 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,llen); - if (layer) - { - PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer))); - if (tab) - { - if (!PerlIO_push(f,tab,mode,as,alen)) - return -1; - } - } - else { - Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s); - return -1; - } - } - s = e; + code = -1; + break; } } + n += 2; } - return 0; + return code; } +int +PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) +{ + int code = 0; + if (names) + { + AV *layers = newAV(); + code = PerlIO_parse_layers(aTHX_ layers,names); + if (code == 0) + { + code = PerlIO_apply_layera(aTHX_ f, mode, layers, 0); + } + SvREFCNT_dec((SV *) layers); + } + return code; +} /*--------------------------------------------------------------------------------------*/ @@ -740,7 +853,7 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) { PerlIO *top = f; PerlIOl *l; - while (l = *top) + while ((l = *top)) { if (PerlIOBase(top)->tab == &PerlIO_crlf) { @@ -758,32 +871,51 @@ PerlIO_binmode(pTHX_ PerlIO *f, int iotype, int mode, const char *names) int PerlIO__close(PerlIO *f) { - return (*PerlIOBase(f)->tab->Close)(f); + if (f && *f) + return (*PerlIOBase(f)->tab->Close)(f); + else + { + SETERRNO(EBADF,SS$_IVCHAN); + return -1; + } } #undef PerlIO_fdupopen PerlIO * PerlIO_fdupopen(pTHX_ PerlIO *f) { - char buf[8]; - int fd = PerlLIO_dup(PerlIO_fileno(f)); - PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf)); - if (new) + if (f && *f) + { + char buf[8]; + int fd = PerlLIO_dup(PerlIO_fileno(f)); + PerlIO *new = PerlIO_fdopen(fd,PerlIO_modestr(f,buf)); + if (new) + { + Off_t posn = PerlIO_tell(f); + PerlIO_seek(new,posn,SEEK_SET); + } + return new; + } + else { - Off_t posn = PerlIO_tell(f); - PerlIO_seek(new,posn,SEEK_SET); + SETERRNO(EBADF,SS$_IVCHAN); + return NULL; } - return new; } #undef PerlIO_close int PerlIO_close(PerlIO *f) { - int code = (*PerlIOBase(f)->tab->Close)(f); - while (*f) + dTHX; + int code = -1; + if (f && *f) { - PerlIO_pop(f); + code = (*PerlIOBase(f)->tab->Close)(f); + while (*f) + { + PerlIO_pop(aTHX_ f); + } } return code; } @@ -792,23 +924,186 @@ PerlIO_close(PerlIO *f) int PerlIO_fileno(PerlIO *f) { - return (*PerlIOBase(f)->tab->Fileno)(f); + if (f && *f) + return (*PerlIOBase(f)->tab->Fileno)(f); + else + { + SETERRNO(EBADF,SS$_IVCHAN); + return -1; + } } -PerlIO_funcs * -PerlIO_top_layer(pTHX_ const char *layers) +static const char * +PerlIO_context_layers(pTHX_ const char *mode) +{ + const char *type = NULL; + /* Need to supply default layer info from open.pm */ + if (PL_curcop) + { + SV *layers = PL_curcop->cop_io; + if (layers) + { + STRLEN len; + type = SvPV(layers,len); + if (type && mode[0] != 'r') + { + /* Skip to write part */ + const char *s = strchr(type,0); + if (s && (s-type) < len) + { + type = s+1; + } + } + } + } + return type; +} + +static SV * +PerlIO_layer_from_ref(pTHX_ SV *sv) +{ + /* For any scalar type load the handler which is bundled with perl */ + if (SvTYPE(sv) < SVt_PVAV) + return PerlIO_find_layer(aTHX_ "Scalar",6, 1); + + /* For other types allow if layer is known but don't try and load it */ + switch (SvTYPE(sv)) + { + case SVt_PVAV: + return PerlIO_find_layer(aTHX_ "Array",5, 0); + case SVt_PVHV: + return PerlIO_find_layer(aTHX_ "Hash",4, 0); + case SVt_PVCV: + return PerlIO_find_layer(aTHX_ "Code",4, 0); + case SVt_PVGV: + return PerlIO_find_layer(aTHX_ "Glob",4, 0); + } + return Nullsv; +} + +AV * +PerlIO_resolve_layers(pTHX_ const char *layers,const char *mode,int narg, SV **args) { - /* FIXME !!! */ - return PerlIO_default_top(); + AV *def = PerlIO_default_layers(aTHX); + int incdef = 1; + if (!_perlio) + PerlIO_stdstreams(aTHX); + if (narg) + { + SV *arg = *args; + /* If it is a reference but not an object see if we have a handler for it */ + if (SvROK(arg) && !sv_isobject(arg)) + { + SV *handler = PerlIO_layer_from_ref(aTHX_ SvRV(arg)); + if (handler) + { + def = newAV(); + av_push(def,SvREFCNT_inc(handler)); + av_push(def,&PL_sv_undef); + incdef = 0; + } + /* Don't fail if handler cannot be found + * :Via(...) etc. may do something sensible + * else we will just stringfy and open resulting string. + */ + } + } + if (!layers) + layers = PerlIO_context_layers(aTHX_ mode); + if (layers && *layers) + { + AV *av; + if (incdef) + { + IV n = av_len(def)+1; + av = newAV(); + while (n-- > 0) + { + SV **svp = av_fetch(def,n,0); + av_store(av,n,(svp) ? SvREFCNT_inc(*svp) : &PL_sv_undef); + } + } + else + { + av = def; + } + PerlIO_parse_layers(aTHX_ av,layers); + return av; + } + else + { + if (incdef) + SvREFCNT_inc(def); + return def; + } } PerlIO * PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { - PerlIO_funcs *tab = (f && *f) ? PerlIOBase(f)->tab : PerlIO_top_layer(aTHX_ layers); - if (!_perlio) - PerlIO_stdstreams(); - return (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,f,narg,args); + if (!f && narg == 1 && *args == &PL_sv_undef) + { + if ((f = PerlIO_tmpfile())) + { + if (!layers) + layers = PerlIO_context_layers(aTHX_ mode); + if (layers && *layers) + PerlIO_apply_layers(aTHX_ f,mode,layers); + } + } + else + { + AV *layera; + IV n; + PerlIO_funcs *tab = NULL; + if (f && *f) + { + /* This is "reopen" - it is not tested as perl does not use it yet */ + PerlIOl *l = *f; + layera = newAV(); + while (l) + { + SV *arg = (l->tab->Getarg) ? (*l->tab->Getarg)(&l) : &PL_sv_undef; + av_unshift(layera,2); + av_store(layera,0,PerlIO_tab_sv(aTHX_ l->tab)); + av_store(layera,1,arg); + l = *PerlIONext(&l); + } + } + else + { + layera = PerlIO_resolve_layers(aTHX_ layers, mode, narg, args); + } + n = av_len(layera)-1; + while (n >= 0) + { + PerlIO_funcs *t = PerlIO_layer_fetch(aTHX_ layera,n,NULL); + if (t && t->Open) + { + tab = t; + break; + } + n -= 2; + } + if (tab) + { + PerlIO_debug("openn(%s,'%s','%s',%d,%x,%o,%p,%d,%p)\n", + tab->name,layers,mode,fd,imode,perm,f,narg,args); + f = (*tab->Open)(aTHX_ tab, layera, n, mode,fd,imode,perm,f,narg,args); + if (f) + { + if (n+2 < av_len(layera)+1) + { + if (PerlIO_apply_layera(aTHX_ f, mode, layera, n+2) != 0) + { + f = NULL; + } + } + } + } + SvREFCNT_dec(layera); + } + return f; } @@ -842,35 +1137,65 @@ PerlIO_reopen(const char *path, const char *mode, PerlIO *f) SSize_t PerlIO_read(PerlIO *f, void *vbuf, Size_t count) { - return (*PerlIOBase(f)->tab->Read)(f,vbuf,count); + if (f && *f) + return (*PerlIOBase(f)->tab->Read)(f,vbuf,count); + else + { + SETERRNO(EBADF,SS$_IVCHAN); + return -1; + } } #undef PerlIO_unread SSize_t PerlIO_unread(PerlIO *f, const void *vbuf, Size_t count) { - return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count); + if (f && *f) + return (*PerlIOBase(f)->tab->Unread)(f,vbuf,count); + else + { + SETERRNO(EBADF,SS$_IVCHAN); + return -1; + } } #undef PerlIO_write SSize_t PerlIO_write(PerlIO *f, const void *vbuf, Size_t count) { - return (*PerlIOBase(f)->tab->Write)(f,vbuf,count); + if (f && *f) + return (*PerlIOBase(f)->tab->Write)(f,vbuf,count); + else + { + SETERRNO(EBADF,SS$_IVCHAN); + return -1; + } } #undef PerlIO_seek int PerlIO_seek(PerlIO *f, Off_t offset, int whence) { - return (*PerlIOBase(f)->tab->Seek)(f,offset,whence); + if (f && *f) + return (*PerlIOBase(f)->tab->Seek)(f,offset,whence); + else + { + SETERRNO(EBADF,SS$_IVCHAN); + return -1; + } } #undef PerlIO_tell Off_t PerlIO_tell(PerlIO *f) { - return (*PerlIOBase(f)->tab->Tell)(f); + if (f && *f) + return (*PerlIOBase(f)->tab->Tell)(f); + else + { + SETERRNO(EBADF,SS$_IVCHAN); + return -1; + } } #undef PerlIO_flush @@ -879,20 +1204,35 @@ PerlIO_flush(PerlIO *f) { if (f) { - PerlIO_funcs *tab = PerlIOBase(f)->tab; - if (tab && tab->Flush) + if (*f) { - return (*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); + SETERRNO(EBADF,SS$_IVCHAN); + return -1; + } } else { - PerlIO_debug("Cannot flush f=%p :%s\n",f,tab->name); - errno = EINVAL; + PerlIO_debug("Cannot flush f=%p\n",f); + SETERRNO(EBADF,SS$_IVCHAN); return -1; } } else { + /* Is it good API design to do flush-all on NULL, + * a potentially errorneous input? Maybe some magical + * value (PerlIO* PERLIO_FLUSH_ALL = (PerlIO*)-1;)? + * Yes, stdio does similar things on fflush(NULL), + * but should we be bound by their design decisions? + * --jhi */ PerlIO **table = &_perlio; int code = 0; while ((f = *table)) @@ -910,32 +1250,75 @@ PerlIO_flush(PerlIO *f) } } +void +PerlIOBase_flush_linebuf() +{ + PerlIO **table = &_perlio; + PerlIO *f; + while ((f = *table)) + { + int i; + table = (PerlIO **)(f++); + for (i=1; i < PERLIO_TABLE_SIZE; i++) + { + if (*f && (PerlIOBase(f)->flags & (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE)) + == (PERLIO_F_LINEBUF|PERLIO_F_CANWRITE)) + PerlIO_flush(f); + f++; + } + } +} + #undef PerlIO_fill int PerlIO_fill(PerlIO *f) { - return (*PerlIOBase(f)->tab->Fill)(f); + if (f && *f) + return (*PerlIOBase(f)->tab->Fill)(f); + else + { + SETERRNO(EBADF,SS$_IVCHAN); + return -1; + } } #undef PerlIO_isutf8 int PerlIO_isutf8(PerlIO *f) { - return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; + if (f && *f) + return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; + else + { + SETERRNO(EBADF,SS$_IVCHAN); + return -1; + } } #undef PerlIO_eof int PerlIO_eof(PerlIO *f) { - return (*PerlIOBase(f)->tab->Eof)(f); + if (f && *f) + return (*PerlIOBase(f)->tab->Eof)(f); + else + { + SETERRNO(EBADF,SS$_IVCHAN); + return -1; + } } #undef PerlIO_error int PerlIO_error(PerlIO *f) { - return (*PerlIOBase(f)->tab->Error)(f); + if (f && *f) + return (*PerlIOBase(f)->tab->Error)(f); + else + { + SETERRNO(EBADF,SS$_IVCHAN); + return -1; + } } #undef PerlIO_clearerr @@ -944,23 +1327,25 @@ PerlIO_clearerr(PerlIO *f) { if (f && *f) (*PerlIOBase(f)->tab->Clearerr)(f); + else + SETERRNO(EBADF,SS$_IVCHAN); } #undef PerlIO_setlinebuf void PerlIO_setlinebuf(PerlIO *f) { - (*PerlIOBase(f)->tab->Setlinebuf)(f); + if (f && *f) + (*PerlIOBase(f)->tab->Setlinebuf)(f); + else + SETERRNO(EBADF,SS$_IVCHAN); } #undef PerlIO_has_base int PerlIO_has_base(PerlIO *f) { - if (f && *f) - { - return (PerlIOBase(f)->tab->Get_base != NULL); - } + if (f && *f) { return (PerlIOBase(f)->tab->Get_base != NULL); } return 0; } @@ -1004,14 +1389,18 @@ PerlIO_canset_cnt(PerlIO *f) STDCHAR * PerlIO_get_base(PerlIO *f) { - return (*PerlIOBase(f)->tab->Get_base)(f); + if (f && *f) + return (*PerlIOBase(f)->tab->Get_base)(f); + return NULL; } #undef PerlIO_get_bufsiz int PerlIO_get_bufsiz(PerlIO *f) { - return (*PerlIOBase(f)->tab->Get_bufsiz)(f); + if (f && *f) + return (*PerlIOBase(f)->tab->Get_bufsiz)(f); + return 0; } #undef PerlIO_get_ptr @@ -1058,12 +1447,13 @@ PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) /* utf8 and raw dummy layers */ IV -PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIOUtf8_pushed(PerlIO *f, const char *mode, SV *arg) { if (PerlIONext(f)) { + dTHX; PerlIO_funcs *tab = PerlIOBase(f)->tab; - PerlIO_pop(f); + PerlIO_pop(aTHX_ f); if (tab->kind & PERLIO_K_UTF8) PerlIOBase(f)->flags |= PERLIO_F_UTF8; else @@ -1073,28 +1463,10 @@ PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) return -1; } -PerlIO * -PerlIOUtf8_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args) -{ - PerlIO_funcs *tab = PerlIO_default_layer(-2); - PerlIO *f = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,old,narg,args); - 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; -} - PerlIO_funcs PerlIO_utf8 = { "utf8", sizeof(PerlIOl), PERLIO_K_DUMMY|PERLIO_F_UTF8, - NULL, - PerlIOUtf8_open, PerlIOUtf8_pushed, NULL, NULL, @@ -1103,6 +1475,9 @@ PerlIO_funcs PerlIO_utf8 = { NULL, NULL, NULL, + NULL, + NULL, + NULL, NULL, /* flush */ NULL, /* fill */ NULL, @@ -1120,8 +1495,6 @@ PerlIO_funcs PerlIO_byte = { "bytes", sizeof(PerlIOl), PERLIO_K_DUMMY, - NULL, - PerlIOUtf8_open, PerlIOUtf8_pushed, NULL, NULL, @@ -1130,6 +1503,9 @@ PerlIO_funcs PerlIO_byte = { NULL, NULL, NULL, + NULL, + NULL, + NULL, NULL, /* flush */ NULL, /* fill */ NULL, @@ -1144,20 +1520,21 @@ PerlIO_funcs PerlIO_byte = { }; PerlIO * -PerlIORaw_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args) +PerlIORaw_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n,const char *mode, int fd, int imode, int perm, PerlIO *old, int narg, SV **args) { PerlIO_funcs *tab = PerlIO_default_btm(); - return (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,old,narg,args); + return (*tab->Open)(aTHX_ tab,layers,n-2,mode,fd,imode,perm,old,narg,args); } PerlIO_funcs PerlIO_raw = { "raw", sizeof(PerlIOl), PERLIO_K_DUMMY, - NULL, - PerlIORaw_open, PerlIORaw_pushed, PerlIOBase_popped, + PerlIORaw_open, + NULL, + NULL, NULL, NULL, NULL, @@ -1222,11 +1599,13 @@ PerlIO_modestr(PerlIO *f,char *buf) } IV -PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIOBase_pushed(PerlIO *f, const char *mode, SV *arg) { PerlIOl *l = PerlIOBase(f); +#if 0 const char *omode = mode; char temp[8]; +#endif PerlIO_funcs *tab = PerlIOBase(f)->tab; l->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE| PERLIO_F_TRUNCATE|PERLIO_F_APPEND); @@ -1234,6 +1613,8 @@ PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) l->flags |= PERLIO_F_FASTGETS; if (mode) { + if (*mode == '#' || *mode == 'I') + mode++; switch (*mode++) { case 'r': @@ -1246,7 +1627,7 @@ PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) l->flags |= PERLIO_F_TRUNCATE|PERLIO_F_CANWRITE; break; default: - errno = EINVAL; + SETERRNO(EINVAL,LIB$_INVARG); return -1; } while (*mode) @@ -1263,8 +1644,8 @@ PerlIOBase_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) l->flags |= PERLIO_F_CRLF; break; default: - errno = EINVAL; - return -1; + SETERRNO(EINVAL,LIB$_INVARG); + return -1; } } } @@ -1293,14 +1674,48 @@ PerlIOBase_popped(PerlIO *f) SSize_t PerlIOBase_unread(PerlIO *f, const void *vbuf, Size_t count) { + dTHX; Off_t old = PerlIO_tell(f); SSize_t done; - PerlIO_push(f,&PerlIO_pending,"r",Nullch,0); + PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv); done = PerlIOBuf_unread(f,vbuf,count); PerlIOSelf(f,PerlIOBuf)->posn = old - done; return done; } +SSize_t +PerlIOBase_read(PerlIO *f, void *vbuf, Size_t count) +{ + STDCHAR *buf = (STDCHAR *) vbuf; + if (f) + { + if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) + return 0; + while (count > 0) + { + SSize_t avail = PerlIO_get_cnt(f); + SSize_t take = 0; + if (avail > 0) + take = (count < avail) ? count : avail; + if (take > 0) + { + 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 > 0 && avail <= 0) + { + if (PerlIO_fill(f) != 0) + break; + } + } + return (buf - (STDCHAR *) vbuf); + } + return 0; +} + IV PerlIOBase_noop_ok(PerlIO *f) { @@ -1320,7 +1735,7 @@ PerlIOBase_close(PerlIO *f) PerlIO *n = PerlIONext(f); if (PerlIO_flush(f) != 0) code = -1; - if (n && (*PerlIOBase(n)->tab->Close)(n) != 0) + if (n && *n && (*PerlIOBase(n)->tab->Close)(n) != 0) code = -1; PerlIOBase(f)->flags &= ~(PERLIO_F_CANREAD|PERLIO_F_CANWRITE|PERLIO_F_OPEN); return code; @@ -1361,7 +1776,10 @@ PerlIOBase_clearerr(PerlIO *f) void PerlIOBase_setlinebuf(PerlIO *f) { - + if (f) + { + PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; + } } /*--------------------------------------------------------------------------------------*/ @@ -1427,7 +1845,7 @@ PerlIOUnix_oflags(const char *mode) oflags |= O_BINARY; if (*mode || oflags == -1) { - errno = EINVAL; + SETERRNO(EINVAL,LIB$_INVARG); oflags = -1; } return oflags; @@ -1440,9 +1858,9 @@ PerlIOUnix_fileno(PerlIO *f) } IV -PerlIOUnix_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIOUnix_pushed(PerlIO *f, const char *mode, SV *arg) { - IV code = PerlIOBase_pushed(f,mode,arg,len); + IV code = PerlIOBase_pushed(f,mode,arg); if (*PerlIONext(f)) { PerlIOUnix *s = PerlIOSelf(f,PerlIOUnix); @@ -1454,27 +1872,7 @@ PerlIOUnix_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) } PerlIO * -PerlIOUnix_fdopen(PerlIO_funcs *self, int fd,const char *mode) -{ - dTHX; - PerlIO *f = NULL; - if (*mode == 'I') - mode++; - if (fd >= 0) - { - int oflags = PerlIOUnix_oflags(mode); - if (oflags != -1) - { - PerlIOUnix *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOUnix); - s->fd = fd; - s->oflags = oflags; - } - } - return f; -} - -PerlIO * -PerlIOUnix_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) +PerlIOUnix_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { if (f) { @@ -1504,7 +1902,7 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, i if (!f) { f = PerlIO_allocate(aTHX); - s = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOUnix); + s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,PerlIOArg),PerlIOUnix); } else s = PerlIOSelf(f,PerlIOUnix); @@ -1566,7 +1964,7 @@ PerlIOUnix_write(PerlIO *f, const void *vbuf, Size_t count) IV PerlIOUnix_seek(PerlIO *f, Off_t offset, int whence) { - dTHX; + dSYS; Off_t new = PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,offset,whence); PerlIOBase(f)->flags &= ~PERLIO_F_EOF; return (new == (Off_t) -1) ? -1 : 0; @@ -1575,8 +1973,7 @@ 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); + dSYS; return PerlLIO_lseek(PerlIOSelf(f,PerlIOUnix)->fd,0,SEEK_CUR); } @@ -1606,10 +2003,11 @@ PerlIO_funcs PerlIO_unix = { "unix", sizeof(PerlIOUnix), PERLIO_K_RAW, - PerlIOUnix_fileno, - PerlIOUnix_open, PerlIOUnix_pushed, PerlIOBase_noop_ok, + PerlIOUnix_open, + NULL, + PerlIOUnix_fileno, PerlIOUnix_read, PerlIOBase_unread, PerlIOUnix_write, @@ -1641,7 +2039,7 @@ typedef struct IV PerlIOStdio_fileno(PerlIO *f) { - dTHX; + dSYS; return PerlSIO_fileno(PerlIOSelf(f,PerlIOStdio)->stdio); } @@ -1661,22 +2059,13 @@ PerlIOStdio_mode(const char *mode,char *tmode) return ret; } -PerlIO * -PerlIOStdio_fdopen(PerlIO_funcs *self, int fd,const char *mode) -{ - dTHX; - PerlIO *f = NULL; - int init = 0; - char tmode[8]; -} - /* This isn't used yet ... */ IV -PerlIOStdio_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIOStdio_pushed(PerlIO *f, const char *mode, SV *arg) { - dTHX; if (*PerlIONext(f)) { + dSYS; PerlIOStdio *s = PerlIOSelf(f,PerlIOStdio); char tmode[8]; FILE *stdio = PerlSIO_fdopen(PerlIO_fileno(PerlIONext(f)),mode = PerlIOStdio_mode(mode,tmode)); @@ -1685,7 +2074,7 @@ PerlIOStdio_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) else return -1; } - return PerlIOBase_pushed(f,mode,arg,len); + return PerlIOBase_pushed(f,mode,arg); } #undef PerlIO_importFILE @@ -1696,14 +2085,14 @@ PerlIO_importFILE(FILE *stdio, int fl) PerlIO *f = NULL; if (stdio) { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio); + PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"r+",Nullsv),PerlIOStdio); s->stdio = stdio; } return f; } PerlIO * -PerlIOStdio_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) +PerlIOStdio_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { char tmode[8]; if (f) @@ -1731,8 +2120,8 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, FILE *stdio = PerlSIO_fopen(path,mode); if (stdio) { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX), self, - (mode = PerlIOStdio_mode(mode,tmode)),Nullch,0), + PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)), self, + (mode = PerlIOStdio_mode(mode,tmode)),PerlIOArg), PerlIOStdio); s->stdio = stdio; } @@ -1769,7 +2158,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, } if (stdio) { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),self,mode,Nullch,0),PerlIOStdio); + PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),self,mode,PerlIOArg),PerlIOStdio); s->stdio = stdio; return f; } @@ -1781,7 +2170,7 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, SSize_t PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count) { - dTHX; + dSYS; FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio; SSize_t got = 0; if (count == 1) @@ -1805,7 +2194,7 @@ PerlIOStdio_read(PerlIO *f, void *vbuf, Size_t count) SSize_t PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count) { - dTHX; + dSYS; FILE *s = PerlIOSelf(f,PerlIOStdio)->stdio; STDCHAR *buf = ((STDCHAR *)vbuf)+count-1; SSize_t unread = 0; @@ -1823,14 +2212,14 @@ PerlIOStdio_unread(PerlIO *f, const void *vbuf, Size_t count) SSize_t PerlIOStdio_write(PerlIO *f, const void *vbuf, Size_t count) { - dTHX; + dSYS; return PerlSIO_fwrite(vbuf,1,count,PerlIOSelf(f,PerlIOStdio)->stdio); } IV PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence) { - dTHX; + dSYS; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; return PerlSIO_fseek(stdio,offset,whence); } @@ -1838,7 +2227,7 @@ PerlIOStdio_seek(PerlIO *f, Off_t offset, int whence) Off_t PerlIOStdio_tell(PerlIO *f) { - dTHX; + dSYS; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; return PerlSIO_ftell(stdio); } @@ -1846,14 +2235,15 @@ PerlIOStdio_tell(PerlIO *f) IV PerlIOStdio_close(PerlIO *f) { - dTHX; -#ifdef HAS_SOCKS5_INIT - int optval, optlen = sizeof(int); + dSYS; +#ifdef SOCKS5_VERSION_NAME + int optval; + Sock_size_t optlen = sizeof(int); #endif FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; return( -#ifdef HAS_SOCKS5_INIT - (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (char *)&optval, &optlen) < 0) ? +#ifdef SOCKS5_VERSION_NAME + (getsockopt(PerlIO_fileno(f), SOL_SOCKET, SO_TYPE, (void *)&optval, &optlen) < 0) ? PerlSIO_fclose(stdio) : close(PerlIO_fileno(f)) #else @@ -1866,7 +2256,7 @@ PerlIOStdio_close(PerlIO *f) IV PerlIOStdio_flush(PerlIO *f) { - dTHX; + dSYS; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { @@ -1892,7 +2282,7 @@ PerlIOStdio_flush(PerlIO *f) IV PerlIOStdio_fill(PerlIO *f) { - dTHX; + dSYS; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; int c; /* fflush()ing read-only streams can cause trouble on some stdio-s */ @@ -1910,28 +2300,28 @@ PerlIOStdio_fill(PerlIO *f) IV PerlIOStdio_eof(PerlIO *f) { - dTHX; + dSYS; return PerlSIO_feof(PerlIOSelf(f,PerlIOStdio)->stdio); } IV PerlIOStdio_error(PerlIO *f) { - dTHX; + dSYS; return PerlSIO_ferror(PerlIOSelf(f,PerlIOStdio)->stdio); } void PerlIOStdio_clearerr(PerlIO *f) { - dTHX; + dSYS; PerlSIO_clearerr(PerlIOSelf(f,PerlIOStdio)->stdio); } void PerlIOStdio_setlinebuf(PerlIO *f) { - dTHX; + dSYS; #ifdef HAS_SETLINEBUF PerlSIO_setlinebuf(PerlIOSelf(f,PerlIOStdio)->stdio); #else @@ -1943,7 +2333,7 @@ PerlIOStdio_setlinebuf(PerlIO *f) STDCHAR * PerlIOStdio_get_base(PerlIO *f) { - dTHX; + dSYS; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; return PerlSIO_get_base(stdio); } @@ -1951,7 +2341,7 @@ PerlIOStdio_get_base(PerlIO *f) Size_t PerlIOStdio_get_bufsiz(PerlIO *f) { - dTHX; + dSYS; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; return PerlSIO_get_bufsiz(stdio); } @@ -1961,7 +2351,7 @@ PerlIOStdio_get_bufsiz(PerlIO *f) STDCHAR * PerlIOStdio_get_ptr(PerlIO *f) { - dTHX; + dSYS; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; return PerlSIO_get_ptr(stdio); } @@ -1969,7 +2359,7 @@ PerlIOStdio_get_ptr(PerlIO *f) SSize_t PerlIOStdio_get_cnt(PerlIO *f) { - dTHX; + dSYS; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; return PerlSIO_get_cnt(stdio); } @@ -1977,8 +2367,8 @@ PerlIOStdio_get_cnt(PerlIO *f) void PerlIOStdio_set_ptrcnt(PerlIO *f,STDCHAR *ptr,SSize_t cnt) { - dTHX; FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + dSYS; if (ptr != NULL) { #ifdef STDIO_PTR_LVALUE @@ -2016,10 +2406,11 @@ PerlIO_funcs PerlIO_stdio = { "stdio", sizeof(PerlIOStdio), PERLIO_K_BUFFERED, - PerlIOStdio_fileno, - PerlIOStdio_open, PerlIOBase_pushed, PerlIOBase_noop_ok, + PerlIOStdio_open, + NULL, + PerlIOStdio_fileno, PerlIOStdio_read, PerlIOStdio_unread, PerlIOStdio_write, @@ -2063,7 +2454,8 @@ PerlIO_exportFILE(PerlIO *f, int fl) stdio = fdopen(PerlIO_fileno(f),"r+"); if (stdio) { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f,&PerlIO_stdio,"r+",Nullch,0),PerlIOStdio); + dTHX; + PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ f,&PerlIO_stdio,"r+",Nullsv),PerlIOStdio); s->stdio = stdio; } return stdio; @@ -2096,49 +2488,50 @@ PerlIO_releaseFILE(PerlIO *p, FILE *f) /* perlio buffer layer */ IV -PerlIOBuf_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +PerlIOBuf_pushed(PerlIO *f, const char *mode, SV *arg) { + dSYS; PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); int fd = PerlIO_fileno(f); Off_t posn; if (fd >= 0 && PerlLIO_isatty(fd)) { - PerlIOBase(f)->flags |= PERLIO_F_LINEBUF; + PerlIOBase(f)->flags |= PERLIO_F_LINEBUF|PERLIO_F_TTY; } posn = PerlIO_tell(PerlIONext(f)); if (posn != (Off_t) -1) { b->posn = posn; } - return PerlIOBase_pushed(f,mode,arg,len); + return PerlIOBase_pushed(f,mode,arg); } PerlIO * -PerlIOBuf_open(pTHX_ PerlIO_funcs *self, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) +PerlIOBuf_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) { if (f) { PerlIO *next = PerlIONext(f); - PerlIO_funcs *tab = PerlIOBase(next)->tab; - next = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,next,narg,args); - if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,Nullch,0) != 0) + PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIOBase(next)->tab); + next = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,next,narg,args); + if (!next || (*PerlIOBase(f)->tab->Pushed)(f,mode,PerlIOArg) != 0) { return NULL; } } else { - PerlIO_funcs *tab = PerlIO_default_btm(); + PerlIO_funcs *tab = PerlIO_layer_fetch(aTHX_ layers, n-2, PerlIO_default_btm()); int init = 0; if (*mode == 'I') { init = 1; mode++; } - f = (*tab->Open)(aTHX_ tab,mode,fd,imode,perm,NULL,narg,args); + f = (*tab->Open)(aTHX_ tab, layers, n-2, mode,fd,imode,perm,NULL,narg,args); if (f) { - PerlIOBuf *b = PerlIOSelf(PerlIO_push(f,self,mode,Nullch,0),PerlIOBuf); + PerlIO_push(aTHX_ f,self,mode,PerlIOArg); fd = PerlIO_fileno(f); #if O_BINARY != O_TEXT /* do something about failing setmode()? --jhi */ @@ -2222,6 +2615,8 @@ PerlIOBuf_fill(PerlIO *f) */ if (PerlIO_flush(f) != 0) return -1; + if (PerlIOBase(f)->flags & PERLIO_F_TTY) + PerlIOBase_flush_linebuf(); if (!b->buf) PerlIO_get_base(f); /* allocate via vtable */ @@ -2277,32 +2672,11 @@ SSize_t PerlIOBuf_read(PerlIO *f, void *vbuf, Size_t count) { PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); - STDCHAR *buf = (STDCHAR *) vbuf; if (f) { if (!b->ptr) PerlIO_get_base(f); - if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) - return 0; - while (count > 0) - { - SSize_t avail = PerlIO_get_cnt(f); - SSize_t take = (count < avail) ? count : avail; - if (take > 0) - { - 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 > 0 && avail <= 0) - { - if (PerlIO_fill(f) != 0) - break; - } - } - return (buf - (STDCHAR *) vbuf); + return PerlIOBase_read(f,vbuf,count); } return 0; } @@ -2431,7 +2805,6 @@ 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) @@ -2444,15 +2817,6 @@ PerlIOBuf_close(PerlIO *f) return code; } -void -PerlIOBuf_setlinebuf(PerlIO *f) -{ - if (f) - { - PerlIOBase(f)->flags &= ~PERLIO_F_LINEBUF; - } -} - STDCHAR * PerlIOBuf_get_ptr(PerlIO *f) { @@ -2479,7 +2843,6 @@ PerlIOBuf_get_base(PerlIO *f) PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); if (!b->buf) { - dTHX; if (!b->bufsiz) b->bufsiz = 4096; b->buf = PerlMemShared_calloc(b->bufsiz,sizeof(STDCHAR)); @@ -2523,10 +2886,11 @@ PerlIO_funcs PerlIO_perlio = { "perlio", sizeof(PerlIOBuf), PERLIO_K_BUFFERED, - PerlIOBase_fileno, - PerlIOBuf_open, PerlIOBuf_pushed, PerlIOBase_noop_ok, + PerlIOBuf_open, + NULL, + PerlIOBase_fileno, PerlIOBuf_read, PerlIOBuf_unread, PerlIOBuf_write, @@ -2538,7 +2902,7 @@ PerlIO_funcs PerlIO_perlio = { PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, - PerlIOBuf_setlinebuf, + PerlIOBase_setlinebuf, PerlIOBuf_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, @@ -2577,14 +2941,14 @@ PerlIOPending_seek(PerlIO *f, Off_t offset, int whence) IV PerlIOPending_flush(PerlIO *f) { + dTHX; PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf); if (b->buf && b->buf != (STDCHAR *) &b->oneword) { - dTHX; PerlMemShared_free(b->buf); b->buf = NULL; } - PerlIO_pop(f); + PerlIO_pop(aTHX_ f); return 0; } @@ -2602,9 +2966,9 @@ PerlIOPending_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) } IV -PerlIOPending_pushed(PerlIO *f,const char *mode,const char *arg,STRLEN len) +PerlIOPending_pushed(PerlIO *f,const char *mode,SV *arg) { - IV code = PerlIOBase_pushed(f,mode,arg,len); + IV code = PerlIOBase_pushed(f,mode,arg); 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 @@ -2633,15 +2997,15 @@ PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count) return got; } - PerlIO_funcs PerlIO_pending = { "pending", sizeof(PerlIOBuf), PERLIO_K_BUFFERED, - PerlIOBase_fileno, - NULL, PerlIOPending_pushed, PerlIOBase_noop_ok, + NULL, + NULL, + PerlIOBase_fileno, PerlIOPending_read, PerlIOBuf_unread, PerlIOBuf_write, @@ -2653,7 +3017,7 @@ PerlIO_funcs PerlIO_pending = { PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, - PerlIOBuf_setlinebuf, + PerlIOBase_setlinebuf, PerlIOBuf_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, @@ -2677,11 +3041,11 @@ typedef struct } PerlIOCrlf; IV -PerlIOCrlf_pushed(PerlIO *f, const char *mode,const char *arg,STRLEN len) +PerlIOCrlf_pushed(PerlIO *f, const char *mode,SV *arg) { IV code; PerlIOBase(f)->flags |= PERLIO_F_CRLF; - code = PerlIOBuf_pushed(f,mode,arg,len); + code = PerlIOBuf_pushed(f,mode,arg); #if 0 PerlIO_debug("PerlIOCrlf_pushed f=%p %s %s fl=%08"UVxf"\n", f,PerlIOBase(f)->tab->name,(mode) ? mode : "(Null)", @@ -2792,7 +3156,6 @@ PerlIOCrlf_get_cnt(PerlIO *f) 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 */ @@ -2943,10 +3306,11 @@ PerlIO_funcs PerlIO_crlf = { "crlf", sizeof(PerlIOCrlf), PERLIO_K_BUFFERED|PERLIO_K_CANCRLF, - PerlIOBase_fileno, - PerlIOBuf_open, PerlIOCrlf_pushed, PerlIOBase_noop_ok, /* popped */ + PerlIOBuf_open, + NULL, + PerlIOBase_fileno, 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' */ @@ -2958,7 +3322,7 @@ PerlIO_funcs PerlIO_crlf = { PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, - PerlIOBuf_setlinebuf, + PerlIOBase_setlinebuf, PerlIOBuf_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, @@ -2985,7 +3349,6 @@ PerlIOMmap_map(PerlIO *f) { dTHX; PerlIOMmap *m = PerlIOSelf(f,PerlIOMmap); - PerlIOBuf *b = &m->base; IV flags = PerlIOBase(f)->flags; IV code = 0; if (m->len) @@ -3247,10 +3610,11 @@ PerlIO_funcs PerlIO_mmap = { "mmap", sizeof(PerlIOMmap), PERLIO_K_BUFFERED, - PerlIOBase_fileno, - PerlIOBuf_open, PerlIOBuf_pushed, PerlIOBase_noop_ok, + PerlIOBuf_open, + NULL, + PerlIOBase_fileno, PerlIOBuf_read, PerlIOMmap_unread, PerlIOMmap_write, @@ -3262,7 +3626,7 @@ PerlIO_funcs PerlIO_mmap = { PerlIOBase_eof, PerlIOBase_error, PerlIOBase_clearerr, - PerlIOBuf_setlinebuf, + PerlIOBase_setlinebuf, PerlIOMmap_get_base, PerlIOBuf_bufsiz, PerlIOBuf_get_ptr, @@ -3275,6 +3639,10 @@ PerlIO_funcs PerlIO_mmap = { void PerlIO_init(void) { + dTHX; +#ifndef WIN32 + call_atexit(PerlIO_cleanup_layers, NULL); +#endif if (!_perlio) { #ifndef WIN32 @@ -3283,14 +3651,15 @@ PerlIO_init(void) } } - - #undef PerlIO_stdin PerlIO * PerlIO_stdin(void) { if (!_perlio) - PerlIO_stdstreams(); + { + dTHX; + PerlIO_stdstreams(aTHX); + } return &_perlio[1]; } @@ -3299,7 +3668,10 @@ PerlIO * PerlIO_stdout(void) { if (!_perlio) - PerlIO_stdstreams(); + { + dTHX; + PerlIO_stdstreams(aTHX); + } return &_perlio[2]; } @@ -3308,7 +3680,10 @@ PerlIO * PerlIO_stderr(void) { if (!_perlio) - PerlIO_stdstreams(); + { + dTHX; + PerlIO_stdstreams(aTHX); + } return &_perlio[3]; } @@ -3319,8 +3694,14 @@ char * PerlIO_getname(PerlIO *f, char *buf) { dTHX; + char *name = NULL; +#ifdef VMS + FILE *stdio = PerlIOSelf(f,PerlIOStdio)->stdio; + if (stdio) name = fgetname(stdio, buf); +#else Perl_croak(aTHX_ "Don't know how to get file name"); - return NULL; +#endif + return name; } @@ -3436,7 +3817,7 @@ PerlIO_tmpfile(void) FILE *stdio = PerlSIO_tmpfile(); if (stdio) { - PerlIOStdio *s = PerlIOSelf(PerlIO_push(f = PerlIO_allocate(aTHX),&PerlIO_stdio,"w+",Nullch,0),PerlIOStdio); + PerlIOStdio *s = PerlIOSelf(PerlIO_push(aTHX_ (f = PerlIO_allocate(aTHX)),&PerlIO_stdio,"w+",Nullsv),PerlIOStdio); s->stdio = stdio; } return f; @@ -3483,7 +3864,7 @@ PerlIO_setpos(PerlIO *f, SV *pos) if (f && len == sizeof(Off_t)) return PerlIO_seek(f,*posn,SEEK_SET); } - errno = EINVAL; + SETERRNO(EINVAL,SS$_IVCHAN); return -1; } #else @@ -3505,7 +3886,7 @@ PerlIO_setpos(PerlIO *f, SV *pos) #endif } } - errno = EINVAL; + SETERRNO(EINVAL,SS$_IVCHAN); return -1; } #endif @@ -3589,3 +3970,6 @@ PerlIO_sprintf(char *s, int n, const char *fmt,...) #endif + + +