diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | lib/PerlIO.pm | 73 | ||||
| -rw-r--r-- | perlio.c | 30 | ||||
| -rw-r--r-- | perlio.h | 1 | ||||
| -rw-r--r-- | t/io/layers.t | 117 | ||||
| -rwxr-xr-x | t/io/open.t | 1 | ||||
| -rw-r--r-- | universal.c | 131 |
7 files changed, 347 insertions, 7 deletions
@@ -2441,6 +2441,7 @@ t/io/fflush.t See if auto-flush on fork/exec/system/qx works t/io/fs.t See if directory manipulations work t/io/inplace.t See if inplace editing works t/io/iprefix.t See if inplace editing works with prefixes +t/io/layers.t See if PerlIO layers work t/io/nargv.t See if nested ARGV stuff works t/io/open.t See if open works t/io/openpid.t See if open works for subprocesses diff --git a/lib/PerlIO.pm b/lib/PerlIO.pm index 672efb2324..c3c5c97074 100644 --- a/lib/PerlIO.pm +++ b/lib/PerlIO.pm @@ -24,6 +24,8 @@ sub import } } +sub F_UTF8 () { 0x8000 } + 1; __END__ @@ -122,11 +124,11 @@ the stream are also removed or disabled. The implementation of C<:raw> is as a pseudo-layer which when "pushed" pops itself and then any layers which do not declare themselves as suitable for binary data. (Undoing :utf8 and :crlf are implemented by clearing -flags rather than poping layers but that is an implementation detail.) +flags rather than popping layers but that is an implementation detail.) As a consequence of the fact that C<:raw> normally pops layers -it usually only makes sense to have it as the only or first element in a -layer specification. When used as the first element it provides +it usually only makes sense to have it as the only or first element in +a layer specification. When used as the first element it provides a known base on which to build e.g. open($fh,":raw:utf8",...) @@ -151,6 +153,30 @@ A more elegant (and safer) interface is needed. =back +=head2 Custom Layers + +It is possible to write custom layers in addition to the above builtin +ones, both in C/XS and Perl. Two such layers (and one example written +in Perl using the latter) come with the Perl distribution. + +=over 4 + +=item :encoding + +Use C<:encoding(ENCODING)> either in open() or binmode() to install +a layer that does transparently character set and encoding transformations, +for example from Shift-JIS to Unicode. Note that an C<:encoding> also +enables C<:utf8>. See L<PerlIO::encoding> for more information. + +=item :via + +Use C<:via(MODULE)> either in open() or binmode() to install a layer +that does whatever transformation (for example compression / +decompression, encryption / decryption) to the filehandle. +See L<PerlIO::via> for more information. + +=back + =head2 Alternatives to raw To get a binary stream an alternate method is to use: @@ -188,8 +214,8 @@ Otherwise the default layers are These defaults 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 or platform low level -layer is always pushed first). +PERLIO to a space separated list of layers (C<unix> or platform low +level layer is always pushed first). This can be used to see the effect of/bugs in the various layers e.g. @@ -197,13 +223,48 @@ This can be used to see the effect of/bugs in the various layers e.g. PERLIO=stdio ./perl harness PERLIO=perlio ./perl harness +=head2 Querying the layers of filehandle + +The following returns the B<names> of the PerlIO layers on a filehandle. + + my @layers = PerlIO::get_layers(FH); + +The layers are returned in the order an open() or binmode() call would +use them. Note that the stack begings (normally) from C<stdio>, the +platform specific low-level I/O (like C<unix>) is not part of the stack. + +By default the layers from the input side of the filehandle is +returned, to get the output side use the optional C<output> argument: + + my @layers = PerlIO::get_layers(FH, output => 1); + +(Usually the layers are identical on either side of a filehandle but +for example with sockets there may be differences.) + +B<Implementation details follow, please close your eyes.> + +The arguments to layers are by default returned in parenthesis after +the name of the layer, and certain layers (like C<utf8>) are not real +layers but instead flags on real layers: to get all of these returned +separately use the optional C<separate> argument: + + my @layer_and_args_and_flags = PerlIO::get_layers(FH, details => 1); + +The result will be up to be three times the number of layers: +the first element will be a name, the second element the arguments +(unspecified arguments will be C<undef>), the third element the flags, +the fourth element a name again, and so forth. + +B<You may open your eyes now.> + =head1 AUTHOR Nick Ing-Simmons E<lt>nick@ing-simmons.netE<gt> =head1 SEE ALSO -L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<perliol>, L<Encode> +L<perlfunc/"binmode">, L<perlfunc/"open">, L<perlunicode>, L<perliol>, +L<Encode> =cut @@ -640,6 +640,36 @@ PerlIO_pop(pTHX_ PerlIO *f) } } +/* Return as an array the stack of layers on a filehandle. Note that + * the stack is returned top-first in the array, and there are three + * times as many array elements as there are layers in the stack: the + * first element of a layer triplet is the name, the second one is the + * arguments, and the third one is the flags. */ + +AV * +PerlIO_get_layers(pTHX_ PerlIO *f) +{ + AV *av = newAV(); + + if (PerlIOValid(f)) { + dSP; + PerlIOl *l = PerlIOBase(f); + + while (l) { + SV *name = l->tab && l->tab->name ? + newSVpv(l->tab->name, 0) : &PL_sv_undef; + SV *arg = l->tab && l->tab->Getarg ? + (*l->tab->Getarg)(aTHX_ &l, 0, 0) : &PL_sv_undef; + av_push(av, name); + av_push(av, arg); + av_push(av, newSViv((IV)l->flags)); + l = l->next; + } + } + + return av; +} + /*--------------------------------------------------------------------------------------*/ /* * XS Interface for perl code @@ -107,6 +107,7 @@ extern PerlIO_funcs *PerlIO_find_layer(pTHX_ const char *name, STRLEN len, extern PerlIO *PerlIO_push(pTHX_ PerlIO *f, PerlIO_funcs *tab, const char *mode, SV *arg); extern void PerlIO_pop(pTHX_ PerlIO *f); +extern AV* PerlIO_get_layers(pTHX_ PerlIO *f); extern void PerlIO_clone(pTHX_ PerlInterpreter *proto, CLONE_PARAMS *param); #endif /* PerlIO */ diff --git a/t/io/layers.t b/t/io/layers.t new file mode 100644 index 0000000000..1596d72f07 --- /dev/null +++ b/t/io/layers.t @@ -0,0 +1,117 @@ +#!./perl + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; + require './test.pl'; +} + +plan tests => 43; + +use Config; + +{ + skip("This perl does not have perlio and Encode", 43) + unless $Config{useperlio} && " $Config{extensions} " =~ / Encode /; + + sub check { + my ($result, $expected, $id) = @_; + my $n = scalar @$expected; + is($n, scalar @$expected, "$id layers = $n"); + for (my $i = 0; $i < $n; $i++) { + my $j = $expected->[$i]; + if (ref $j eq 'CODE') { + ok($j->($result->[$i]), "$id $i is ok"); + } else { + is($result->[$i], $j, + sprintf("$id $i is %s", defined $j ? $j : "undef")); + } + } + } + + check([ PerlIO::get_layers(STDIN) ], + [ "stdio" ], + "STDIN"); + + open(F, ">:crlf", "afile"); + + check([ PerlIO::get_layers(F) ], + [ qw(stdio crlf) ], + "open :crlf"); + + binmode(F, ":encoding(sjis)"); # "sjis" will be canonized to "shiftjis" + + check([ PerlIO::get_layers(F) ], + [ qw[stdio crlf encoding(shiftjis) utf8] ], + ":encoding(sjis)"); + + binmode(F, ":pop"); + + check([ PerlIO::get_layers(F) ], + [ qw(stdio crlf) ], + ":pop"); + + binmode(F, ":raw"); + + check([ PerlIO::get_layers(F) ], + [ "stdio" ], + ":raw"); + + binmode(F, ":utf8"); + + check([ PerlIO::get_layers(F) ], + [ qw(stdio utf8) ], + ":utf8"); + + binmode(F, ":bytes"); + + check([ PerlIO::get_layers(F) ], + [ "stdio" ], + ":bytes"); + + binmode(F, ":encoding(utf8)"); + + check([ PerlIO::get_layers(F) ], + [ qw[stdio encoding(utf8) utf8] ], + ":encoding(utf8)"); + + binmode(F, ":raw :crlf"); + + check([ PerlIO::get_layers(F) ], + [ qw(stdio crlf) ], + ":raw:crlf"); + + binmode(F, ":raw :encoding(latin1)"); # "latin1" will be canonized + + check([ PerlIO::get_layers(F, details => 1) ], + [ "stdio", undef, sub { $_[0] > 0 }, + "encoding", "iso-8859-1", sub { $_[0] & PerlIO::F_UTF8() } ], + ":raw:encoding(latin1)"); + + binmode(F); + + check([ PerlIO::get_layers(F) ], + [ "stdio" ], + "binmode"); + + close F; + + { + use open(IN => ":crlf", OUT => ":encoding(cp1252)"); + open F, "<afile"; + open G, ">afile"; + + check([ PerlIO::get_layers(F, input => 1) ], + [ qw(stdio crlf) ], + "use open IN"); + + check([ PerlIO::get_layers(G, output => 1) ], + [ qw[stdio encoding(cp1252) utf8] ], + "use open OUT"); + + close F; + close G; + } + + 1 while unlink "afile"; +} diff --git a/t/io/open.t b/t/io/open.t index 09f2611d05..87a9c5580b 100755 --- a/t/io/open.t +++ b/t/io/open.t @@ -277,6 +277,5 @@ SKIP: { open($fh3{k}, "TEST"); gimme($fh3{k}); like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem"); - } diff --git a/universal.c b/universal.c index f5ce23e5a3..6b011cf27b 100644 --- a/universal.c +++ b/universal.c @@ -17,6 +17,10 @@ #define PERL_IN_UNIVERSAL_C #include "perl.h" +#ifdef USE_PERLIO +#include "perliol.h" /* For the PERLIO_F_XXX */ +#endif + /* * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> * The main guts of traverse_isa was actually copied from gv_fetchmeth @@ -176,6 +180,7 @@ XS(XS_utf8_native_to_unicode); XS(XS_Internals_SvREADONLY); XS(XS_Internals_SvREFCNT); XS(XS_Internals_hv_clear_placehold); +XS(XS_PerlIO_get_layers); void Perl_boot_core_UNIVERSAL(pTHX) @@ -214,6 +219,7 @@ Perl_boot_core_UNIVERSAL(pTHX) newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$"); newXSproto("Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, file, "\\%"); + newXS("PerlIO::get_layers", XS_PerlIO_get_layers, file); } @@ -714,3 +720,128 @@ XS(XS_Internals_hv_clear_placehold) XSRETURN(0); } + +XS(XS_PerlIO_get_layers) +{ + dXSARGS; + if (items < 1 || items % 2 == 0) + Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])"); + { + SV * sv; + GV * gv; + IO * io; + bool input = TRUE; + bool details = FALSE; + + if (items > 1) { + SV **popuntil = MARK + 1; + SV **svp; + + for (svp = MARK + 2; svp <= SP; svp += 2) { + SV **varp = svp; + SV **valp = svp + 1; + STRLEN klen; + char *key = SvPV(*varp, klen); + + switch (*key) { + case 'i': + if (klen == 5 && memEQ(key, "input", 5)) { + input = SvTRUE(*valp); + break; + } + goto fail; + case 'o': + if (klen == 6 && memEQ(key, "output", 6)) { + input = !SvTRUE(*valp); + break; + } + goto fail; + case 'd': + if (klen == 7 && memEQ(key, "details", 7)) { + details = SvTRUE(*valp); + break; + } + goto fail; + default: + fail: + Perl_croak(aTHX_ + "get_layers: unknown argument '%s'", + key); + } + } + + SP -= (items - 1); + } + + sv = POPs; + gv = (GV*)sv; + + if (!isGV(sv)) { + if (SvROK(sv) && isGV(SvRV(sv))) + gv = (GV*)SvRV(sv); + else + gv = gv_fetchpv(SvPVX(sv), FALSE, SVt_PVIO); + } + + if (gv && (io = GvIO(gv))) { + dTARGET; + AV* av = PerlIO_get_layers(aTHX_ input ? + IoIFP(io) : IoOFP(io)); + I32 i; + I32 last = av_len(av); + I32 nitem = 0; + + for (i = last; i >= 0; i -= 3) { + SV **namsvp; + SV **argsvp; + SV **flgsvp; + bool namok, argok, flgok; + + namsvp = av_fetch(av, i - 2, FALSE); + argsvp = av_fetch(av, i - 1, FALSE); + flgsvp = av_fetch(av, i, FALSE); + + namok = namsvp && *namsvp && SvPOK(*namsvp); + argok = argsvp && *argsvp && SvPOK(*argsvp); + flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); + + if (details) { + XPUSHs(namok ? + newSVpv(SvPVX(*namsvp), 0) : &PL_sv_undef); + XPUSHs(argok ? + newSVpv(SvPVX(*argsvp), 0) : &PL_sv_undef); + if (flgok) + XPUSHi(SvIVX(*flgsvp)); + else + XPUSHs(&PL_sv_undef); + nitem += 3; + } + else { + if (namok && argok) + XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", + *namsvp, *argsvp)); + else if (namok) + XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, *namsvp)); + else + XPUSHs(&PL_sv_undef); + nitem++; + if (flgok) { + IV flags = SvIVX(*flgsvp); + + if (flags & PERLIO_F_UTF8) { + XPUSHs(newSVpvn("utf8", 4)); + nitem++; + } + } + } + } + + SvREFCNT_dec(av); + + XSRETURN(nitem); + } + } + + XSRETURN(0); +} + |