File Coverage

blib/lib/File/Slurp/Sane.pm

Criterion	Covered	Total	%
statement	59	64	92.1
branch	16	32	50.0
condition	5	10	50.0
subroutine	12	12	100.0
pod	4	4	100.0
total	96	122	78.6

package File::Slurp::Sane;
$File::Slurp::Sane::VERSION = '0.001';
use strict;
use warnings;

use Carp 'croak';
use Encode 'resolve_alias';
use Exporter 5.57 'import';
use File::Spec::Functions 'catfile';
use FileHandle;
our @EXPORT_OK = qw/read_binary read_text read_lines read_dir/;

sub read_binary {
	my $filename = shift;
	my $buf;

	open my $fh, '<:unix', $filename or croak "Couldn't open $filename: $!";
	if (my $size = -s $fh) {
		my ($pos, $read) = 0;
		do {
			defined($read = read $fh, $buf, $size - $pos, $pos) or croak "Couldn't read $filename: $!";
			$pos += $read;
		} while ($read && $pos < $size);
		return $buf;
	}
	else {
		return do { local $/; <$fh> };
	}
}

my $crlf_default = $^O eq 'MSWin32' ? 1 : 0;
my $has_utf8_strict = eval { require PerlIO::utf8_strict };

sub _text_layers {
	my ($encoding, $options) = @_;
	my $crlf = exists $options->{crlf} ? !! delete $options->{crlf} : $crlf_default;
	if ($encoding =~ /^(latin|iso-8859-)1$/i) {
		return $crlf ? ':unix:crlf:perlio' : ':raw'
	}
	elsif ($has_utf8_strict && $encoding =~ /^utf-?8\b/) {
		return $crlf ? ':unix:utf8_strict:crlf:perlio' : ':unix:utf8_strict:perlio';
	}
	else {
		return $crlf ? ":unix:perlio:encoding($encoding):crlf:perlio" : ":raw:encoding($encoding)";
	}
}

sub read_text {
	my ($filename, $encoding, %options) = @_;
	$encoding ||= 'utf-8';
	my $layer = _text_layers($encoding, \%options);
	return read_binary($filename) if $layer eq ':raw';

	open my $fh, "<$layer", $filename or croak "Couldn't open $filename: $!";
	return do { local $/; <$fh> };
}

sub read_lines {
	my ($filename, $encoding, %options) = @_;
	$encoding ||= 'utf-8';
	my $layer = _text_layers($encoding, \%options);

	open my $fh, "<$layer", $filename or croak "Couldn't open $filename: $!";
	return <$fh> if not %options;
	my @buf = <$fh>;
	close $fh;
	chomp @buf if $options{chomp};
	return @buf;
}

sub read_dir {
	my ($dirname, %options) = @_;
	opendir my ($dir), $dirname or croak "Could not open $dirname: $!";
	my @ret = grep { not m/ \A \.\.? \z /x } readdir $dir;
	@ret = map { catfile($dirname, $_) } @ret if $options{prefix};
	closedir $dir;
	return @ret;
}

1;

# ABSTRACT: A simple, sane and efficient file slurper

__END__