From: Nick Ing-Simmons Date: Sun, 21 Jan 2001 23:44:47 +0000 (+0000) Subject: Make "real" layers of ":utf8" and ":raw". X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=dfebf9581083f76d0f88d6a3edc9e5b72e852d91;p=p5sagit%2Fp5-mst-13.2.git Make "real" layers of ":utf8" and ":raw". So now PERLIO=utf8 perl ... does what Andreas wanted. Fix arg passing in open.pm (still have a Carp issue). p4raw-id: //depot/perlio@8511 --- diff --git a/lib/open.pm b/lib/open.pm index 1e073c2..53ae308 100644 --- a/lib/open.pm +++ b/lib/open.pm @@ -7,22 +7,25 @@ use vars qw(%layers @layers); # Populate hash in non-PerlIO case %layers = (crlf => 1, raw => 0) unless (@layers); +# warn join(',',keys %layers); + our $VERSION = '1.00'; sub import { - shift; - die "`use open' needs explicit list of disciplines" unless @_; + my ($class,@args) = @_; + croak("`use open' needs explicit list of disciplines") unless @args; $^H |= $open::hint_bits; my ($in,$out) = split(/\0/,(${^OPEN} || '\0')); my @in = split(/\s+/,$in); my @out = split(/\s+/,$out); - while (@_) { - my $type = shift; - my $discp = shift; + while (@args) { + my $type = shift(@args); + my $discp = shift(@args); my @val; - foreach my $layer (split(/\s+:?/,$discp)) { + foreach my $layer (split(/\s+/,$discp)) { + $layer =~ s/^://; unless(exists $layers{$layer}) { - croak "Unknown discipline layer '$layer'"; + carp("Unknown discipline layer '$layer'"); } push(@val,":$layer"); if ($layer =~ /^(crlf|raw)$/) { diff --git a/perlio.c b/perlio.c index 61af376..1c8f65d 100644 --- a/perlio.c +++ b/perlio.c @@ -417,8 +417,30 @@ PerlIO_define_layer(PerlIO_funcs *tab) HV *stash = gv_stashpv("perlio::Layer", TRUE); SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(tab))),stash); 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) { @@ -437,6 +459,7 @@ PerlIO_default_layer(I32 n) #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); @@ -444,9 +467,11 @@ PerlIO_default_layer(I32 n) #ifdef HAS_MMAP PerlIO_define_layer(&PerlIO_mmap); #endif + PerlIO_define_layer(&PerlIO_utf8); 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)) @@ -462,8 +487,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); @@ -475,21 +507,7 @@ PerlIO_default_layer(I32 n) len = av_len(PerlIO_layer_av); if (len < 1) { - if (O_BINARY != O_TEXT) - { - av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_crlf.name,0))); - } - else - { - 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) @@ -541,6 +559,34 @@ PerlIO_push(PerlIO *f,PerlIO_funcs *tab,const char *mode,const char *arg,STRLEN return f; } +IV +PerlIOUtf8_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +{ + if (PerlIONext(f)) + { + PerlIO_pop(f); + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + return 0; + } + return -1; +} + +IV +PerlIORaw_pushed(PerlIO *f, const char *mode, const char *arg, STRLEN len) +{ + /* Pop back to bottom layer */ + if (PerlIONext(f)) + { + PerlIO_flush(f); + while (PerlIONext(f)) + { + PerlIO_pop(f); + } + return 0; + } + return -1; +} + int PerlIO_apply_layers(pTHX_ PerlIO *f, const char *mode, const char *names) { @@ -937,6 +983,105 @@ PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) } /*--------------------------------------------------------------------------------------*/ +/* utf8 and raw dummy layers */ + +PerlIO * +PerlIOUtf8_fdopen(PerlIO_funcs *self, int fd,const char *mode) +{ + PerlIO_funcs *tab = PerlIO_default_layer(-2); + PerlIO *f = (*tab->Fdopen)(tab,fd,mode); + if (f) + { + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + } + return f; +} + +PerlIO * +PerlIOUtf8_open(PerlIO_funcs *self, const char *path,const char *mode) +{ + PerlIO_funcs *tab = PerlIO_default_layer(-2); + PerlIO *f = (*tab->Open)(tab,path,mode); + if (f) + { + PerlIOBase(f)->flags |= PERLIO_F_UTF8; + } + return f; +} + +PerlIO_funcs PerlIO_utf8 = { + "utf8", + sizeof(PerlIOl), + PERLIO_K_DUMMY|PERLIO_K_BUFFERED, + 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_layer(0); + return (*tab->Fdopen)(tab,fd,mode); +} + +PerlIO * +PerlIORaw_open(PerlIO_funcs *self, const char *path,const char *mode) +{ + PerlIO_funcs *tab = PerlIO_default_layer(0); + return (*tab->Open)(tab,path,mode); +} + +PerlIO_funcs PerlIO_raw = { + "raw", + sizeof(PerlIOl), + PERLIO_K_DUMMY|PERLIO_K_RAW, + NULL, + PerlIORaw_fdopen, + PerlIORaw_open, + NULL, + PerlIORaw_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 */ +}; +/*--------------------------------------------------------------------------------------*/ +/*--------------------------------------------------------------------------------------*/ /* "Methods" of the "base class" */ IV @@ -3004,6 +3149,8 @@ PerlIO_init(void) } } + + #undef PerlIO_stdin PerlIO * PerlIO_stdin(void) diff --git a/perliol.h b/perliol.h index 04c7071..f524fcd 100644 --- a/perliol.h +++ b/perliol.h @@ -40,6 +40,7 @@ struct _PerlIO_funcs #define PERLIO_K_BUFFERED 0x00000002 #define PERLIO_K_CANCRLF 0x00000004 #define PERLIO_K_FASTGETS 0x00000008 +#define PERLIO_K_DUMMY 0x00000010 /*--------------------------------------------------------------------------------------*/ struct _PerlIO @@ -78,6 +79,8 @@ extern PerlIO_funcs PerlIO_unix; extern PerlIO_funcs PerlIO_perlio; extern PerlIO_funcs PerlIO_stdio; extern PerlIO_funcs PerlIO_crlf; +extern PerlIO_funcs PerlIO_utf8; +extern PerlIO_funcs PerlIO_raw; /* The EXT is need for Cygwin -- but why only for _pending? --jhi */ EXT PerlIO_funcs PerlIO_pending; #ifdef HAS_MMAP