Fix open.pm to work via XS-implemented method calls rather

than *open::layers variables which caused all the HV/AV hassle.

p4raw-id: //depot/perlio@10618

diff --git a/embed.pl b/embed.pl
index 7700ccd..ed617ae 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1427,6 +1427,7 @@ p |OP*    |block_end      |I32 floor|OP* seq
 Ap     |I32    |block_gimme
 p      |int    |block_start    |int full
 p      |void   |boot_core_UNIVERSAL
+p      |void   |boot_core_PerlIO
 Ap     |void   |call_list      |I32 oldscope|AV* av_list
 p      |bool   |cando          |Mode_t mode|Uid_t effective|Stat_t* statbufp
 Ap     |U32    |cast_ulong     |NV f

diff --git a/lib/open.pm b/lib/open.pm
index c90181b..3a08b79 100644 (file)
--- a/lib/open.pm
+++ b/lib/open.pm
@@ -2,15 +2,7 @@ package open;
 use Carp;
 $open::hint_bits = 0x20000;
 
-# layers array and hash mainly manipulated by C code in perlio.c
-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';
+our $VERSION = '1.01';
 
 sub import {
     my ($class,@args) = @_;
@@ -25,7 +17,7 @@ sub import {
        my @val;
        foreach my $layer (split(/\s+/,$discp)) {
             $layer =~ s/^://;
-           unless(exists $layers{$layer}) {
+           unless(PerlIO::Layer::->find($layer)) {
                carp("Unknown discipline layer '$layer'");
            }
            push(@val,":$layer");
@@ -90,33 +82,14 @@ everywhere if PerlIO is enabled.
 
 =head1 IMPLEMENTATION DETAILS
 
-There are two package variables C<%layers> and C<@layers> which are
-mainly manipulated by C code in F<perlio.c>, but are visible to the
-nosy:
-
-  print "Have ",join(',',keys %open::layers),"\n";
-  print "Using ",join(',',@open::layers),"\n";
-
-The C<%open::layers> hash is a record of the available "layers" that
-may be pushed onto a C<PerlIO> stream. The values of the hash are Perl
-objects, of class C<PerlIO::Layer> which are created by the C code in
-F<perlio.c>.  As yet there is nothing useful you can do with the
-objects at the perl level.
-
-The C<@open::layers> array is the current set of layers and their
-arguments.  The array consists of layer => argument pairs and I<must>
-always have even number of entries and the even entries I<must> be
-C<PerlIO::Layer> objects or Perl will "die" when it attempts to open a
-filehandle. In most cases the odd entry will be C<undef>, but in the
-case of (say) ":encoding(iso-8859-1)" it will be 'iso-8859-1'. These
-argument entries are currently restricted to being strings.
-
-When a new C<PerlIO> stream is opened, the C code looks at the array
-to determine the default layers to be pushed. So with care it is
-possible to manipulate the default layer "stack":
-
-    splice(@PerlIO::layers,-2,2);
-    push(@PerlIO::layers,$PerlIO::layers{'stdio'} => undef);
+There is a class method in C<PerlIO::Layer> C<find> which is implemented as XS code.
+It is called by C<import> to validate the layers:
+
+   PerlIO::Layer::->find("perlio")
+
+The return value (if defined) is a Perl object, of class C<PerlIO::Layer> which is
+created by the C code in F<perlio.c>.  As yet there is nothing useful you can do with the
+object at the perl level.
 
 =head1 SEE ALSO
 

diff --git a/perl.c b/perl.c
index d94bb5f..a830230 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1297,6 +1297,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
     av_store(comppadlist, 1, (SV*)PL_comppad);
     CvPADLIST(PL_compcv) = comppadlist;
 
+    boot_core_PerlIO();
     boot_core_UNIVERSAL();
 #ifndef PERL_MICRO
     boot_core_xsutils();

diff --git a/perlio.c b/perlio.c
index e23878f..2d57fb6 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -39,6 +39,8 @@
 #define PERL_IN_PERLIO_C
 #include "perl.h"
 
+#include "XSUB.h"
+
 #undef PerlMemShared_calloc
 #define PerlMemShared_calloc(x,y) calloc(x,y)
 #undef PerlMemShared_free
@@ -154,6 +156,26 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd, int imode, int
  return NULL;
 }
 
+XS(XS_PerlIO__Layer__find)
+{
+ dXSARGS;
+ if (items < 2)
+  Perl_croak(aTHX_ "Usage class->find(name[,load])");
+ else
+  {
+   char *name = SvPV_nolen(ST(1));
+   ST(0) = (strEQ(name,"crlf") || strEQ(name,"raw")) ? &PL_sv_yes : &PL_sv_undef;
+   XSRETURN(1);
+  }
+}
+
+
+void
+Perl_boot_core_PerlIO(pTHX)
+{
+ newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
+}
+
 #endif
 
 
@@ -247,7 +269,6 @@ PerlIO_findFILE(PerlIO *pio)
 #include <sys/mman.h>
 #endif
 
-#include "XSUB.h"
 
 void PerlIO_debug(const char *fmt,...) __attribute__((format(__printf__,1,2)));
 
@@ -395,7 +416,6 @@ PerlIO_list_push(PerlIO_list_t *list,PerlIO_funcs *funcs,SV *arg)
  p = &(list->array[list->cur++]);
  p->funcs = funcs;
  if ((p->arg = arg)) {
-  dTHX; 
   SvREFCNT_inc(arg);
  }
 }
@@ -587,6 +607,22 @@ PerlIO_tab_sv(pTHX_ PerlIO_funcs *tab)
  return sv;
 }
 
+XS(XS_PerlIO__Layer__find)
+{
+ dXSARGS;
+ if (items < 2)
+  Perl_croak(aTHX_ "Usage class->find(name[,load])");
+ else
+  {
+   STRLEN len = 0;
+   char *name = SvPV(ST(1),len);
+   bool load  = (items > 2) ? SvTRUE(ST(2)) : 0;
+   PerlIO_funcs *layer = PerlIO_find_layer(aTHX_ name, len, load);
+   ST(0) = (layer) ? sv_2mortal(PerlIO_tab_sv(aTHX_ layer)) : &PL_sv_undef;
+   XSRETURN(1);
+  }
+}
+
 void
 PerlIO_define_layer(pTHX_ PerlIO_funcs *tab)
 {
@@ -724,10 +760,6 @@ PerlIO_default_layers(pTHX)
    const char *s  = (PL_tainting) ? Nullch : PerlEnv_getenv("PERLIO");
    PerlIO_def_layerlist = PerlIO_list_alloc();
 
-#ifdef USE_ATTRIBUTES_FOR_PERLIO
-   newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
-#endif
-
    PerlIO_define_layer(aTHX_ &PerlIO_raw);
    PerlIO_define_layer(aTHX_ &PerlIO_unix);
    PerlIO_define_layer(aTHX_ &PerlIO_perlio);
@@ -755,6 +787,14 @@ PerlIO_default_layers(pTHX)
  return PerlIO_def_layerlist;
 }
 
+void
+Perl_boot_core_PerlIO(pTHX)
+{
+#ifdef USE_ATTRIBUTES_FOR_PERLIO
+   newXS("io::MODIFY_SCALAR_ATTRIBUTES",XS_io_MODIFY_SCALAR_ATTRIBUTES,__FILE__);
+#endif
+   newXS("PerlIO::Layer::find",XS_PerlIO__Layer__find,__FILE__);
+}
 
 PerlIO_funcs *
 PerlIO_default_layer(pTHX_ I32 n)

diff --git a/t/io/utf8.t b/t/io/utf8.t
index fee0fe6..a541030 100755 (executable)
--- a/t/io/utf8.t
+++ b/t/io/utf8.t
@@ -3,7 +3,7 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
-    unless (exists $open::layers{'perlio'}) {
+    unless (find PerlIO::Layer 'perlio') {
        print "1..0 # Skip: not perlio\n";
        exit 0;
     }

diff --git a/t/lib/io_scalar.t b/t/lib/io_scalar.t
index b1ef199..8368e66 100644 (file)
--- a/t/lib/io_scalar.t
+++ b/t/lib/io_scalar.t
@@ -3,7 +3,7 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
-    unless (exists $open::layers{'perlio'}) {
+    unless (find PerlIO::Layer 'perlio') {
        print "1..0 # Skip: not perlio\n";
        exit 0;
     }