PerlIO infrastructure complete.
Nick Ing-Simmons [Sat, 4 Nov 2000 19:56:10 +0000 (19:56 +0000)]
p4raw-id: //depot/perlio@7539

MANIFEST
iperlsys.h
lib/perlio.pm [new file with mode: 0644]
perlio.c
t/lib/b.t

index 6447f6a..637fd3b 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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
index 94e5fd6..55471cd 100644 (file)
@@ -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 (file)
index 0000000..48acfbb
--- /dev/null
@@ -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
+
+
index f469043..5d8ecdb 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -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];
 }
 
index 6303d62..fca7f47 100755 (executable)
--- a/t/lib/b.t
+++ b/t/lib/b.t
@@ -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';