File Coverage

blib/lib/PerlIO/Layers.pm

Criterion	Covered	Total	%
statement	58	58	100.0
branch	9	12	75.0
condition	3	6	50.0
subroutine	17	17	100.0
pod	2	2	100.0
total	89	95	93.6

package PerlIO::Layers;
$PerlIO::Layers::VERSION = '0.011';
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__