diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | iperlsys.h | 20 | ||||
| -rw-r--r-- | lib/perlio.pm | 87 | ||||
| -rw-r--r-- | perlio.c | 186 | ||||
| -rwxr-xr-x | t/lib/b.t | 1 |
5 files changed, 265 insertions, 30 deletions
@@ -768,6 +768,7 @@ lib/open2.pl Open a two-ended pipe (uses IPC::Open2) lib/open3.pl Open a three-ended pipe (uses IPC::Open3) lib/overload.pm Module for overloading perl operators lib/perl5db.pl Perl debugging routines +lib/perlio.pm Perl IO interface pragma lib/pwd.pl Routines to keep track of PWD environment variable lib/shellwords.pl Perl library to split into words with shell quoting lib/sigtrap.pm For trapping an abort and giving traceback diff --git a/iperlsys.h b/iperlsys.h index 94e5fd614c..55471cdbd4 100644 --- a/iperlsys.h +++ b/iperlsys.h @@ -78,13 +78,17 @@ extern void PerlIO_init (void); typedef Signal_t (*Sighandler_t) (int); #endif +#ifndef Fpos_t +#define Fpos_t Off_t +#endif + #if defined(PERL_IMPLICIT_SYS) #ifndef PerlIO typedef struct _PerlIO PerlIOl; typedef PerlIOl *PerlIO; #define PerlIO PerlIO -#endif +#endif /* No PerlIO */ /* IPerlStdIO */ struct IPerlStdIO; @@ -136,6 +140,7 @@ typedef int (*LPSetpos)(struct IPerlStdIO*, PerlIO*, typedef void (*LPInit)(struct IPerlStdIO*); typedef void (*LPInitOSExtras)(struct IPerlStdIO*); typedef PerlIO* (*LPFdupopen)(struct IPerlStdIO*, PerlIO*); +typedef int (*LPIsUtf8)(struct IPerlStdIO*, PerlIO*); struct IPerlStdIO { @@ -178,6 +183,7 @@ struct IPerlStdIO LPInit pInit; LPInitOSExtras pInitOSExtras; LPFdupopen pFdupopen; + LPIsUtf8 pIsUtf8; }; struct IPerlStdIOInfo @@ -296,18 +302,22 @@ struct IPerlStdIOInfo (*PL_StdIO->pInitOSExtras)(PL_StdIO) #define PerlIO_fdupopen(f) \ (*PL_StdIO->pFdupopen)(PL_StdIO, (f)) +#define PerlIO_isutf8(f) \ + (*PL_StdIO->pIsUtf8)(PL_StdIO, (f)) #else /* PERL_IMPLICIT_SYS */ #include "perlsdio.h" #include "perl.h" #define PerlIO_fdupopen(f) (f) +#define PerlIO_isutf8(f) 0 #endif /* PERL_IMPLICIT_SYS */ #ifndef PERLIO_IS_STDIO #ifdef USE_SFIO #include "perlsfio.h" +#define PerlIO_isutf8(f) 0 #endif /* USE_SFIO */ #endif /* PERLIO_IS_STDIO */ @@ -338,10 +348,6 @@ typedef PerlIOl *PerlIO; #define PerlIO PerlIO #endif /* No PerlIO */ -#ifndef Fpos_t -#define Fpos_t long -#endif - #ifndef NEXT30_NO_ATTRIBUTE #ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */ #ifdef __attribute__ /* Avoid possible redefinition errors */ @@ -483,7 +489,9 @@ extern int PerlIO_setpos (PerlIO *,const Fpos_t *); #ifndef PerlIO_fdupopen extern PerlIO * PerlIO_fdupopen (PerlIO *); #endif - +#ifndef PerlIO_isutf8 +extern int PerlIO_isutf8 (PerlIO *); +#endif /* * Interface for directory functions diff --git a/lib/perlio.pm b/lib/perlio.pm new file mode 100644 index 0000000000..48acfbbf0b --- /dev/null +++ b/lib/perlio.pm @@ -0,0 +1,87 @@ +package perlio; +1; +__END__ + +=head1 NAME + +perlio - perl pragma to configure C level IO + +=head1 SYNOPSIS + + Shell: + PERLIO=perlio perl .... + + print "Have ",join(',',keys %perlio::layers),"\n"; + print "Using ",join(',',@perlio::layers),"\n"; + + +=head1 DESCRIPTION + +Mainly a Place holder for now. + +The C<%perlio::layers> hash is a record of the available "layers" that may be pushed +onto a C<PerlIO> stream. + +The C<@perlio::layers> array is the current set of layers that are used when +a new C<PerlIO> stream is opened. The C code looks are the array each time +a stream is opened so the "stack" can be manipulated by messing with the array : + + pop(@perlio::layers); + push(@perlio::layers,$perlio::layers{'stdio'}); + +The values if both the hash and the array are perl objects, of class C<perlio::Layer> +which are created by the C code in C<perlio.c>. As yet there is nothing useful you +can do with the objects at the perl level. + +There are three layers currently defined: + +=over 4 + +=item unix + +Low level layer which calls C<read>, C<write> and C<lseek> etc. + +=item stdio + +Layer which calls C<fread>, C<fwrite> and C<fseek>/C<ftell> etc. +Note that as this is "real" stdio it will ignore any layers beneath it and +got straight to the operating system via the C library as usual. + +=item perlio + +This is a re-implementation of "stdio-like" buffering written as a PerlIO "layer". +As such it will call whatever layer is below it for its operations. + +=back + +=head2 Defaults and how to override them + +If C<Configure> found out how to do "fast" IO using system's stdio, then +the default layers are : + + unix stdio + +Otherwise the default layers are + + unix perlio + +(STDERR will have just unix in this case as that is optimal way to make it +"unbuffered" - do not add a buffering layer!) + +The default may change once perlio has been better tested and tuned. + +The default can be overridden by setting the environment variable PERLIO +to a space separated list of layers (unix is always pushed first). +This can be used to see the effect of/bugs in the various layers e.g. + + cd .../perl/t + PERLIO=stdio ./perl harness + PERLIO=perlio ./perl harness + +=head1 AUTHOR + +Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt> + +=cut + + @@ -92,6 +92,7 @@ PerlIO_init(void) #ifdef I_UNISTD #include <unistd.h> #endif +#include "XSUB.h" #undef printf void PerlIO_debug(char *fmt,...) __attribute__((format(printf,1,2))); @@ -172,18 +173,19 @@ struct _PerlIO /*--------------------------------------------------------------------------------------*/ /* Flag values */ -#define PERLIO_F_EOF 0x0010000 -#define PERLIO_F_CANWRITE 0x0020000 -#define PERLIO_F_CANREAD 0x0040000 -#define PERLIO_F_ERROR 0x0080000 -#define PERLIO_F_TRUNCATE 0x0100000 -#define PERLIO_F_APPEND 0x0200000 -#define PERLIO_F_BINARY 0x0400000 -#define PERLIO_F_TEMP 0x0800000 -#define PERLIO_F_LINEBUF 0x0100000 -#define PERLIO_F_WRBUF 0x2000000 -#define PERLIO_F_RDBUF 0x4000000 -#define PERLIO_F_OPEN 0x8000000 +#define PERLIO_F_EOF 0x00010000 +#define PERLIO_F_CANWRITE 0x00020000 +#define PERLIO_F_CANREAD 0x00040000 +#define PERLIO_F_ERROR 0x00080000 +#define PERLIO_F_TRUNCATE 0x00100000 +#define PERLIO_F_APPEND 0x00200000 +#define PERLIO_F_BINARY 0x00400000 +#define PERLIO_F_UTF8 0x00800000 +#define PERLIO_F_LINEBUF 0x01000000 +#define PERLIO_F_WRBUF 0x02000000 +#define PERLIO_F_RDBUF 0x04000000 +#define PERLIO_F_TEMP 0x08000000 +#define PERLIO_F_OPEN 0x10000000 #define PerlIOBase(f) (*(f)) #define PerlIOSelf(f,type) ((type *)PerlIOBase(f)) @@ -199,7 +201,7 @@ PerlIO *_perlio = NULL; PerlIO * PerlIO_allocate(void) { - /* Find a free slot in the table, growing table as necessary */ + /* Find a free slot in the table, allocating new table as necessary */ PerlIO **last = &_perlio; PerlIO *f; while ((f = *last)) @@ -280,18 +282,148 @@ PerlIO_fileno(PerlIO *f) return (*PerlIOBase(f)->tab->Fileno)(f); } + extern PerlIO_funcs PerlIO_unix; -extern PerlIO_funcs PerlIO_stdio; extern PerlIO_funcs PerlIO_perlio; +extern PerlIO_funcs PerlIO_stdio; + +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; +} + +HV *PerlIO_layer_hv; +AV *PerlIO_layer_av; -#define PerlIO_default_top() &PerlIO_stdio -#define PerlIO_default_btm() &PerlIO_unix +SV * +PerlIO_find_layer(char *name, STRLEN len) +{ + dTHX; + SV **svp; + SV *sv; + if (len <= 0) + len = strlen(name); + svp = hv_fetch(PerlIO_layer_hv,name,len,0); + if (svp && (sv = *svp) && SvROK(sv)) + return *svp; + return NULL; +} + +void +PerlIO_define_layer(PerlIO_funcs *tab) +{ + dTHX; + HV *stash = gv_stashpv("perlio::Layer", TRUE); + SV *sv = sv_bless(newRV_noinc(newSViv((IV) tab)),stash); + hv_store(PerlIO_layer_hv,tab->name,strlen(tab->name),sv,0); +} + +PerlIO_funcs * +PerlIO_default_layer(I32 n) +{ + dTHX; + SV **svp; + SV *layer; + PerlIO_funcs *tab = &PerlIO_stdio; + int len; + if (!PerlIO_layer_hv) + { + char *s = getenv("PERLIO"); + newXS("perlio::import",XS_perlio_import,__FILE__); + newXS("perlio::unimport",XS_perlio_unimport,__FILE__); + PerlIO_layer_hv = get_hv("perlio::layers",GV_ADD|GV_ADDMULTI); + PerlIO_layer_av = get_av("perlio::layers",GV_ADD|GV_ADDMULTI); + PerlIO_define_layer(&PerlIO_unix); + PerlIO_define_layer(&PerlIO_unix); + PerlIO_define_layer(&PerlIO_perlio); + PerlIO_define_layer(&PerlIO_stdio); + av_push(PerlIO_layer_av,SvREFCNT_inc(PerlIO_find_layer(PerlIO_unix.name,0))); + if (s) + { + while (*s) + { + while (*s && isspace((unsigned char)*s)) + s++; + if (*s) + { + char *e = s; + SV *layer; + while (*e && !isspace((unsigned char)*e)) + e++; + layer = PerlIO_find_layer(s,e-s); + if (layer) + { + PerlIO_debug("Pushing %.*s\n",(e-s),s); + av_push(PerlIO_layer_av,SvREFCNT_inc(layer)); + } + else + Perl_croak(aTHX_ "Unknown layer %.*s",(e-s),s); + s = e; + } + } + } + } + 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))); + } + len = av_len(PerlIO_layer_av); + } + 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 = (PerlIO_funcs *) SvIV(layer); + } + /* PerlIO_debug("Layer %d is %s\n",n,tab->name); */ + return tab; +} + +#define PerlIO_default_top() PerlIO_default_layer(-1) +#define PerlIO_default_btm() PerlIO_default_layer(0) + +void +PerlIO_stdstreams() +{ + if (!_perlio) + { + PerlIO_allocate(); + PerlIO_fdopen(0,"Ir"); + PerlIO_fdopen(1,"Iw"); + PerlIO_fdopen(2,"Iw"); + } +} #undef PerlIO_fdopen PerlIO * PerlIO_fdopen(int fd, const char *mode) { PerlIO_funcs *tab = PerlIO_default_top(); + if (!_perlio) + PerlIO_stdstreams(); return (*tab->Fdopen)(fd,mode); } @@ -300,6 +432,8 @@ PerlIO * PerlIO_open(const char *path, const char *mode) { PerlIO_funcs *tab = PerlIO_default_top(); + if (!_perlio) + PerlIO_stdstreams(); return (*tab->Open)(path,mode); } @@ -437,6 +571,13 @@ PerlIO_flush(PerlIO *f) } } +#undef PerlIO_isutf8 +int +PerlIO_isutf8(PerlIO *f) +{ + return (PerlIOBase(f)->flags & PERLIO_F_UTF8) != 0; +} + #undef PerlIO_eof int PerlIO_eof(PerlIO *f) @@ -544,14 +685,14 @@ PerlIO_get_cnt(PerlIO *f) void PerlIO_set_cnt(PerlIO *f,int cnt) { - return (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt); + (*PerlIOBase(f)->tab->Set_ptrcnt)(f,NULL,cnt); } #undef PerlIO_set_ptrcnt void PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) { - return (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt); + (*PerlIOBase(f)->tab->Set_ptrcnt)(f,ptr,cnt); } /*--------------------------------------------------------------------------------------*/ @@ -1584,9 +1725,6 @@ PerlIO_init(void) if (!_perlio) { atexit(&PerlIO_cleanup); - PerlIO_fdopen(0,"Ir"); - PerlIO_fdopen(1,"Iw"); - PerlIO_fdopen(2,"Iw"); } } @@ -1595,7 +1733,7 @@ PerlIO * PerlIO_stdin(void) { if (!_perlio) - PerlIO_init(); + PerlIO_stdstreams(); return &_perlio[1]; } @@ -1604,7 +1742,7 @@ PerlIO * PerlIO_stdout(void) { if (!_perlio) - PerlIO_init(); + PerlIO_stdstreams(); return &_perlio[2]; } @@ -1613,7 +1751,7 @@ PerlIO * PerlIO_stderr(void) { if (!_perlio) - PerlIO_init(); + PerlIO_stdstreams(); return &_perlio[3]; } @@ -126,6 +126,7 @@ ok; chomp($a = `$^X "-I../lib" "-MB::Stash" "-Mwarnings" -e1`); $a = join ',', sort split /,/, $a; +$a =~ s/-uperlio(?:::\w+)?,//g if $Config{'useperlio'} eq 'define'; $a =~ s/-uWin32,// if $^O eq 'MSWin32'; $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2'; $a =~ s/-uCwd,// if $^O eq 'cygwin'; |