From: Nick Ing-Simmons Date: Fri, 23 Mar 2001 16:27:41 +0000 (+0000) Subject: Check in a stable (working) version before next round of tweaks. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1141d9f89ca1cb89e46951e8afc784c7b4862cd2;p=p5sagit%2Fp5-mst-13.2.git Check in a stable (working) version before next round of tweaks. Changes include: - Move default layers code out of doio.c and into perlio.c - Single routine for parsing layer specification strings. - Skeleton support for demand loading of layers - Core-dump avoidance if PERLIO environment specifies loadable layer (does not _work_ as need IO to load and need load to do IO ...) p4raw-id: //depot/perlio@9313 --- diff --git a/MANIFEST b/MANIFEST index fff4f73..fc47009 100644 --- a/MANIFEST +++ b/MANIFEST @@ -734,6 +734,7 @@ lib/Net/hostent.pm By-name interface to Perl's builtin gethost* lib/Net/netent.pm By-name interface to Perl's builtin getnet* lib/Net/protoent.pm By-name interface to Perl's builtin getproto* lib/Net/servent.pm By-name interface to Perl's builtin getserv* +lib/PerlIO.pm PerlIO support module lib/Pod/Checker.pm Pod-Parser - check POD documents for syntax errors lib/Pod/Find.pm used by pod/splitpod lib/Pod/Functions.pm used by pod/splitpod diff --git a/doio.c b/doio.c index 89df5da..94e3826 100644 --- a/doio.c +++ b/doio.c @@ -68,28 +68,6 @@ Perl_do_open9(pTHX_ GV *gv, register char *name, I32 len, int as_raw, supplied_fp, &svs, 1); } -static char *S_layers(pTHX_ char *mode); - -static char * -S_layers(pTHX_ char *mode) -{ - char *type = NULL; - /* Need to supply default layer info from open.pm */ - SV *layers = PL_curcop->cop_io; - if (layers) { - STRLEN len; - type = SvPV(layers,len); - if (type && mode[0] != 'r') { - /* Skip to write part */ - char *s = strchr(type,0); - if (s && (s-type) < len) { - type = s+1; - } - } - } - return type; -} - bool Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, @@ -214,7 +192,8 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, namesv = sv_2mortal(newSVpvn(name,strlen(name))); num_svs = 1; svp = &namesv; - fp = PerlIO_openn(aTHX_ S_layers(aTHX_ mode),mode, -1, rawmode, rawperm, NULL, num_svs, svp); + type = Nullch; + fp = PerlIO_openn(aTHX_ type,mode, -1, rawmode, rawperm, NULL, num_svs, svp); } else { /* Regular (non-sys) open */ @@ -391,7 +370,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, else was_fdopen = TRUE; if (!num_svs) - type = S_layers(aTHX_ mode); + type = Nullch; if (!(fp = PerlIO_openn(aTHX_ type,mode,fd,0,0,NULL,num_svs,svp))) { if (dodup) PerlLIO_close(fd); @@ -415,7 +394,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, namesv = sv_2mortal(newSVpvn(type,strlen(type))); num_svs = 1; svp = &namesv; - type = S_layers(aTHX_ mode); + type = Nullch; } fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } @@ -447,7 +426,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, namesv = sv_2mortal(newSVpvn(type,strlen(type))); num_svs = 1; svp = &namesv; - type = S_layers(aTHX_ mode); + type = Nullch; } fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } @@ -510,7 +489,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, namesv = sv_2mortal(newSVpvn(type,strlen(type))); num_svs = 1; svp = &namesv; - type = S_layers(aTHX_ mode); + type = Nullch; } fp = PerlIO_openn(aTHX_ type,mode,-1,0,0,NULL,num_svs,svp); } @@ -614,7 +593,7 @@ Perl_do_openn(pTHX_ GV *gv, register char *name, I32 len, int as_raw, if (IoTYPE(io) == IoTYPE_SOCKET || (IoTYPE(io) == IoTYPE_WRONLY && S_ISCHR(PL_statbuf.st_mode)) ) { mode[0] = 'w'; - if (!(IoOFP(io) = PerlIO_openn(aTHX_ S_layers(aTHX_ mode),mode,PerlIO_fileno(fp),0,0,NULL,num_svs,svp))) { + if (!(IoOFP(io) = PerlIO_openn(aTHX_ type,mode,PerlIO_fileno(fp),0,0,NULL,num_svs,svp))) { PerlIO_close(fp); IoIFP(io) = Nullfp; goto say_false; diff --git a/lib/PerlIO.pm b/lib/PerlIO.pm new file mode 100644 index 0000000..c5ce016 --- /dev/null +++ b/lib/PerlIO.pm @@ -0,0 +1,26 @@ +package PerlIO; + +# Map layer name to package that defines it +my %alias = (encoding => 'Encode'); + +sub import +{ + my $class = shift; + while (@_) + { + my $layer = shift; + if (exists $alias{$layer}) + { + $layer = $alias{$layer} + } + else + { + $layer = "${class}::$layer"; + } + eval "require $layer"; + warn $@ if $@; + } +} + +1; +__END__ diff --git a/perlio.c b/perlio.c index 62149b0..57c54c8 100644 --- a/perlio.c +++ b/perlio.c @@ -350,8 +350,22 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len) 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; + if (!svp && 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 NULL; } @@ -452,8 +466,91 @@ PerlIO_define_layer(pTHX_ PerlIO_funcs *tab) 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); + 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) @@ -468,11 +565,10 @@ PerlIO_default_buffer(pTHX) } } PerlIO_debug("Pushing %s\n",tab->name); - av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0))); + av_push(av,SvREFCNT_inc(PerlIO_find_layer(aTHX_ tab->name,0))); + av_push(av,&PL_sv_undef); } - - PerlIO_funcs * PerlIO_default_layer(pTHX_ I32 n) { @@ -482,7 +578,7 @@ PerlIO_default_layer(pTHX_ I32 n) int 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__); @@ -500,55 +596,31 @@ PerlIO_default_layer(pTHX_ I32 n) 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))); + 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(aTHX_ 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); } + n *= 2; if (n < 0) - n += len+1; - svp = av_fetch(PerlIO_layer_av,n,0); + n += len; + svp = av_fetch(PerlIO_layer_av,n,FALSE); 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); */ + /* PerlIO_debug("Layer %d is %s\n",n/2,tab->name); */ return tab; } @@ -556,11 +628,10 @@ PerlIO_default_layer(pTHX_ I32 n) #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); @@ -640,92 +711,38 @@ 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) { + int code = 0; if (names) { - const char *s = names; - while (*s) + AV *layers = newAV(); + code = PerlIO_parse_layers(aTHX_ layers,names); + if (code == 0) { - while (isSPACE(*s) || *s == ':') - s++; - if (*s) + IV max = av_len(layers)+1; + IV i; + for (i=0; i < max; i += 2) { - 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 = *av_fetch(layers,i,FALSE); + PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer))); + if (tab) { - SV *layer = PerlIO_find_layer(aTHX_ s,llen); - if (layer) + SV **argp = av_fetch(layers,i+1,FALSE); + STRLEN alen = 0; + char *as = (argp && SvOK(*argp)) ? SvPV(*argp,alen) : Nullch; + if (!PerlIO_push(aTHX_ f,tab,mode,as,alen)) { - PerlIO_funcs *tab = INT2PTR(PerlIO_funcs *, SvIV(SvRV(layer))); - if (tab) - { - if (!PerlIO_push(aTHX_ f,tab,mode,as,alen)) - return -1; - } + code -1; + break; } - else { - Perl_warn(aTHX_ "perlio: unknown layer \"%.*s\"",(int)llen,s); - return -1; - } } - s = e; } } + SvREFCNT_dec((SV *) layers); } - return 0; + return code; } - /*--------------------------------------------------------------------------------------*/ /* Given the abstraction above the public API functions */ @@ -794,9 +811,37 @@ PerlIO_fileno(PerlIO *f) return (*PerlIOBase(f)->tab->Fileno)(f); } +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; +} + PerlIO_funcs * -PerlIO_top_layer(pTHX_ const char *layers) +PerlIO_top_layer(pTHX_ const char *layers,const char *mode,int narg, SV **args) { + if (!layers) + layers = PerlIO_context_layers(aTHX_ mode); /* FIXME !!! */ return PerlIO_default_top(); } @@ -804,9 +849,10 @@ PerlIO_top_layer(pTHX_ const char *layers) 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); + PerlIO_funcs *tab = (f && *f) ? PerlIOBase(f)->tab + : PerlIO_top_layer(aTHX_ layers, mode, narg, args); if (!_perlio) - PerlIO_stdstreams(); + PerlIO_stdstreams(aTHX); 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,mode,fd,imode,perm,f,narg,args); @@ -1463,26 +1509,6 @@ 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(aTHX_ (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) { if (f) @@ -1670,15 +1696,6 @@ 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) @@ -2643,7 +2660,6 @@ PerlIOPending_read(PerlIO *f, void *vbuf, Size_t count) return got; } - PerlIO_funcs PerlIO_pending = { "pending", sizeof(PerlIOBuf), @@ -3293,14 +3309,15 @@ PerlIO_init(void) } } - - #undef PerlIO_stdin PerlIO * PerlIO_stdin(void) { if (!_perlio) - PerlIO_stdstreams(); + { + dTHX; + PerlIO_stdstreams(aTHX); + } return &_perlio[1]; } @@ -3309,7 +3326,10 @@ PerlIO * PerlIO_stdout(void) { if (!_perlio) - PerlIO_stdstreams(); + { + dTHX; + PerlIO_stdstreams(aTHX); + } return &_perlio[2]; } @@ -3318,7 +3338,10 @@ PerlIO * PerlIO_stderr(void) { if (!_perlio) - PerlIO_stdstreams(); + { + dTHX; + PerlIO_stdstreams(aTHX); + } return &_perlio[3]; }