at the PerlIO layer stack.
p4raw-id: //depot/perl@19203
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
}
}
+sub F_UTF8 () { 0x8000 }
+
1;
__END__
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",...)
=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:
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.
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
}
}
+/* 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
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 */
--- /dev/null
+#!./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";
+}
open($fh3{k}, "TEST");
gimme($fh3{k});
like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem");
-
}
#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
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)
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);
}
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);
+}
+
projects / platform / upstream / perl.git / commitdiff