302 lines
7.8 KiB
Perl
302 lines
7.8 KiB
Perl
package PerlIO::Layers;
|
|
$PerlIO::Layers::VERSION = '0.012';
|
|
use 5.008_001;
|
|
use strict;
|
|
use warnings FATAL => 'all';
|
|
use XSLoader;
|
|
use PerlIO ();
|
|
use Carp qw/croak/;
|
|
use List::Util qw/reduce max/;
|
|
use Exporter 5.57 qw/import/;
|
|
|
|
our @EXPORT_OK = qw/query_handle get_layers get_buffer_sizes/;
|
|
|
|
XSLoader::load(__PACKAGE__, __PACKAGE__->VERSION);
|
|
|
|
our %FLAG_FOR;
|
|
sub _names_to_flags {
|
|
return reduce { $a | $b } map { $FLAG_FOR{$_} } @_;
|
|
}
|
|
|
|
sub _flag_names {
|
|
my $flagbits = shift;
|
|
return grep { $FLAG_FOR{$_} & $flagbits } keys %FLAG_FOR;
|
|
}
|
|
|
|
sub _has_flags {
|
|
my $check_flag = _names_to_flags(@_);
|
|
return sub {
|
|
my ($fh, $layer) = @_;
|
|
my @info = PerlIO::get_layers($fh, details => 1);
|
|
while (my ($name, $arguments, $flags) = splice @info, 0, 3) {
|
|
next if defined $layer and $name ne $layer;
|
|
my $entry = $flags & $check_flag;
|
|
return 1 if $entry;
|
|
}
|
|
return 0;
|
|
}
|
|
}
|
|
|
|
our %KIND_FOR;
|
|
sub _is_kind {
|
|
my $kind = shift;
|
|
return sub {
|
|
my $fh = shift;
|
|
my $kinds = _get_kinds($fh);
|
|
if (@_) {
|
|
my $layer = shift;
|
|
return exists $kinds->{$layer} && $kinds->{$layer} & $KIND_FOR{$kind} ? 1 : 0;
|
|
}
|
|
else {
|
|
return (grep { $kinds->{$_} & $KIND_FOR{$kind} } keys %{$kinds}) ? 1 : 0;
|
|
}
|
|
};
|
|
}
|
|
|
|
my %is_binary = map { ( $_ => 1) } qw/unix stdio perlio crlf flock creat excl mmap/;
|
|
|
|
my $nonbinary_flags = _names_to_flags('UTF8', 'CRLF');
|
|
my $crlf_flags = _names_to_flags('CRLF');
|
|
|
|
my %layer_query_for = (
|
|
writeable => _has_flags('CANWRITE'),
|
|
readable => _has_flags('CANREAD'),
|
|
open => _has_flags('OPEN'),
|
|
temp => _has_flags('TEMP'),
|
|
crlf => _has_flags('CRLF'),
|
|
utf8 => _has_flags('UTF8'),
|
|
binary => sub {
|
|
my ($fh, $layer) = @_;
|
|
my @info = PerlIO::get_layers($fh, details => 1);
|
|
while (my ($name, $arguments, $flags) = splice @info, 0, 3) {
|
|
next if defined $layer and $name ne $layer;
|
|
return 0 if not $is_binary{$name} or $flags & $nonbinary_flags;
|
|
}
|
|
return 1;
|
|
},
|
|
mappable => sub {
|
|
my ($fh, $layer) = @_;
|
|
my @info = PerlIO::get_layers($fh, details => 1);
|
|
while (my ($name, $arguments, $flags) = splice @info, 0, 3) {
|
|
next if defined $layer and $name ne $layer;
|
|
return 0 if not $is_binary{$name} or $flags & $crlf_flags;
|
|
}
|
|
return 1;
|
|
},
|
|
layer => sub {
|
|
my ($fh, $layer) = @_;
|
|
my @info = PerlIO::get_layers($fh, details => 1);
|
|
while (my ($name, $arguments, $flags) = splice @info, 0, 3) {
|
|
return 1 if $name eq $layer;
|
|
}
|
|
return 0;
|
|
},
|
|
buffered => _is_kind('BUFFERED'),
|
|
can_crlf => _is_kind('CANCRLF'),
|
|
line_buffered => _has_flags('LINEBUF'),
|
|
autoflush => _has_flags('UNBUF'),
|
|
buffer_size => sub {
|
|
my ($handle, $size) = @_;
|
|
return max(get_buffer_sizes($handle)) == $size;
|
|
}
|
|
);
|
|
|
|
sub query_handle {
|
|
my ($fh, $query_name, @args) = @_;
|
|
my $layer_query = $layer_query_for{$query_name} or croak "Query $query_name isn't defined";
|
|
return $layer_query->($fh, @args);
|
|
}
|
|
|
|
sub get_layers {
|
|
my $fh = shift;
|
|
my @results;
|
|
my @info = PerlIO::get_layers($fh, details => 1);
|
|
while (my ($name, $arguments, $flags) = splice @info, 0, 3) {
|
|
push @results, [ $name, $arguments, [ _flag_names($flags) ] ];
|
|
}
|
|
return @results;
|
|
}
|
|
|
|
1; # End of PerlIO::Layers
|
|
|
|
# ABSTRACT: Querying your filehandle's capabilities
|
|
|
|
__END__
|
|
|
|
=pod
|
|
|
|
=encoding UTF-8
|
|
|
|
=head1 NAME
|
|
|
|
PerlIO::Layers - Querying your filehandle's capabilities
|
|
|
|
=head1 VERSION
|
|
|
|
version 0.012
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use PerlIO::Layers qw/query_handle/;
|
|
|
|
if (!query_handle(\*STDOUT, 'binary')) {
|
|
...
|
|
}
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Perl's filehandles are implemented as a stack of layers, with the bottom-most usually doing the actual IO and the higher ones doing buffering, encoding/decoding or transformations. PerlIO::Layers allows you to query the filehandle's properties concerning these layers.
|
|
|
|
=head1 FUNCTIONS
|
|
|
|
=head2 query_handle($fh, $query_name [, $argument])
|
|
|
|
This query a filehandle for some information. All queries can take an optional argument, that will test for that layer's properties instead of all layers of the handle. Currently supported queries include:
|
|
|
|
=over 4
|
|
|
|
=item * layer
|
|
|
|
Check the presence of a certain layer. Unlike most other properties C<$argument> is mandatory for this query.
|
|
|
|
=item * utf8
|
|
|
|
Check whether the filehandle/layer handles unicode
|
|
|
|
=item * crlf
|
|
|
|
Check whether the filehandle/layer does crlf translation
|
|
|
|
=item * binary
|
|
|
|
Check whether the filehandle/layer is binary. This test is pessimistic (for unknown layers it will assume it's not binary).
|
|
|
|
=item * mappable
|
|
|
|
Checks whether the filehandle/layer is memory mappable. It is the same as binary, except that the C<utf8> layer is accepted.
|
|
|
|
=item * buffered
|
|
|
|
Check whether the filehandle/layer is buffered.
|
|
|
|
=item * readable
|
|
|
|
Check whether the filehandle/layer is readable.
|
|
|
|
=item * writeable
|
|
|
|
Check whether the filehandle/layer is writeable.
|
|
|
|
=item * open
|
|
|
|
Check whether the filehandle/layer is open.
|
|
|
|
=item * temp
|
|
|
|
Check whether the filehandle/layer refers to a temporary file.
|
|
|
|
=item * can_crlf
|
|
|
|
Checks whether layer C<$argument> (or any layer if C<$argument> it not given) can do crlf translation.
|
|
|
|
=item * line_buffered
|
|
|
|
Check whether the filehandle is in line-buffering mode.
|
|
|
|
=item * autoflush
|
|
|
|
Checks whether the filehandle is in unbuffering mode. Note that this is not the opposite of buffering, but more similar to autoflush, hence the name of this test.
|
|
|
|
=item * buffer_size
|
|
|
|
Check whether the buffer size is equal to C<$argument>.
|
|
|
|
=back
|
|
|
|
=head2 get_layers($fh)
|
|
|
|
Gets information on the layers of a filehandle. It's a list with whose entries have 3 elements: the name of the layer, the arguments of the layer (may be undef) and an arrayref with the flags of the layer as strings. The flags array can contain any of these values:
|
|
|
|
=over 4
|
|
|
|
=item * EOF
|
|
|
|
End of file has been reached.
|
|
|
|
=item * CANWRITE
|
|
|
|
Writes are permitted, i.e. opened as ">" or "+<" or ">>", etc.
|
|
|
|
=item * CANREAD
|
|
|
|
Reads are permitted i.e. opened "<" or "+>".
|
|
|
|
=item * ERROR
|
|
|
|
An error has occurred.
|
|
|
|
=item * TRUNCATE
|
|
|
|
Truncate file suggested by open mode.
|
|
|
|
=item * APPEND
|
|
|
|
All writes should be appends.
|
|
|
|
=item * CRLF
|
|
|
|
Layer is performing Win32-like "\n" mapped to CR,LF for output and CR,LF mapped to "\n" for input. Normally the provided "crlf" layer is the only layer that need bother about this. C<binmode> will mess with this flag rather than add/remove layers if the PERLIO_K_CANCRLF bit is set for the layers class.
|
|
|
|
=item * UTF8
|
|
|
|
Data written to this layer should be UTF-8 encoded; data provided by this layer should be considered UTF-8 encoded. Can be set on any layer by ":utf8" dummy layer. Also set on ":encoding" layer.
|
|
|
|
=item * UNBUF
|
|
|
|
Layer is unbuffered - i.e. write to next layer down should occur for each write to this layer.
|
|
|
|
=item * WRBUF
|
|
|
|
The buffer for this layer currently holds data written to it but not sent to next layer.
|
|
|
|
=item * RDBUF
|
|
|
|
The buffer for this layer currently holds unconsumed data read from layer below.
|
|
|
|
=item * LINEBUF
|
|
|
|
Layer is line buffered. Write data should be passed to next layer down whenever a "\n" is seen. Any data beyond the "\n" should then be processed.
|
|
|
|
=item * TEMP
|
|
|
|
File has been unlink()ed, or should be deleted on close().
|
|
|
|
=item * OPEN
|
|
|
|
Handle is open.
|
|
|
|
=item * FASTGETS
|
|
|
|
This instance of this layer supports the "fast gets" interface. Normally set based on PERLIO_K_FASTGETS for the class and by the existence of the function(s) in the table. However a class that normally provides that interface may need to avoid it on a particular instance. The "pending" layer needs to do this when it is pushed above a layer which does not support the interface.
|
|
|
|
=back
|
|
|
|
C<query_handle> provides a more high level interface to this, you should probably use that when you can.
|
|
|
|
=head2 get_buffer_sizes($fh)
|
|
|
|
Returns a list of buffer sizes for all buffered layers. Unbuffered layers are skipped.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Leon Timmermans <fawaka@gmail.com>
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
This software is copyright (c) 2010 by Leon Timmermans.
|
|
|
|
This is free software; you can redistribute it and/or modify it under
|
|
the same terms as the Perl 5 programming language system itself.
|
|
|
|
=cut
|