From: Nick Ing-Simmons Date: Fri, 15 Jun 2001 20:27:42 +0000 (+0000) Subject: Fix open.pm to work via XS-implemented method calls rather X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0c4f7ff0542ecfc72484b0714d25e263611253ee;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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, 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 stream. The values of the hash are Perl -objects, of class C which are created by the C code in -F. 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 -always have even number of entries and the even entries I be -C objects or Perl will "die" when it attempts to open a -filehandle. In most cases the odd entry will be C, 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 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 C which is implemented as XS code. +It is called by C to validate the layers: + + PerlIO::Layer::->find("perlio") + +The return value (if defined) is a Perl object, of class C which is +created by the C code in F. 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 --- 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 --- 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 #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 --- 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 --- 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; }