File Coverage

blib/lib/IO/Detect.pm

Criterion	Covered	Total	%
statement	125	141	88.6
branch	35	56	62.5
condition	24	49	48.9
subroutine	36	38	94.7
pod	3	3	100.0
total	223	287	77.7

package IO::Detect;

use 5.008;
use constant { false => !1, true => !0 };
use strict;
use warnings;
use if $] < 5.010, 'UNIVERSAL::DOES';

BEGIN {
	$IO::Detect::AUTHORITY = 'cpan:TOBYINK';
	$IO::Detect::VERSION   = '0.202';
}

use namespace::clean 0.19;

EXPORTER:
{
	use base "Exporter::Tiny";

	our %_CONSTANTS;
	our @EXPORT    = qw( is_filehandle is_filename is_fileuri );
	our @EXPORT_OK = (
		qw( is_filehandle is_filename is_fileuri ),
		qw( FileHandle FileName FileUri ),
		qw( ducktype as_filehandle ),
	);
	our %EXPORT_TAGS = (
		smartmatch => [qw( FileHandle FileName FileUri )],
	);

	sub _exporter_validate_opts
	{
		require B;
		my $class = shift;
		$_[0]{exporter} ||= sub {
			my $into = $_[0]{into};
			my ($name, $sym) = @{ $_[1] };
			for (grep ref, $into->can($name))
			{
				B::svref_2object($_)->STASH->NAME eq $into
					and _croak("Refusing to overwrite local sub '$name' with export from $class");
			}
			"namespace::clean"->import(-cleanee => $_[0]{into}, $name);
			no strict qw(refs);
			no warnings qw(redefine prototype);
			*{"$into\::$name"} = $sym;
		}
	}
}

use overload qw<>;
use Scalar::Util qw< blessed openhandle reftype >;
use Carp qw;
use URI::file;

sub _lu {
	require lexical::underscore;
	goto \&lexical::underscore;
}

sub _ducktype
{
	my ($object, $methods) = @_;
	return unless blessed $object;

	foreach my $m (@{ $methods || [] })
	{
		return unless $object->can($m);
	}

	return true;
}

sub _generate_ducktype
{
	my ($class, $name, $arg) = @_;
	my $methods = $arg->{methods};
	return sub (;$) {
		@_ = ${+_lu} unless @_;
		push @_, $methods;
		goto \&_ducktype;
	};
}

my $expected_methods = [
	qw(close eof fcntl fileno getc getline getlines ioctl read print stat)
];

sub is_filehandle (;$)
{
	my $fh = @_ ? shift : ${+_lu};

	return true if openhandle $fh;

	# Logic from IO::Handle::Util
	{
		my $reftype = reftype($fh);
		$reftype = '' unless defined $reftype;

		if ($reftype eq 'IO'
		or  $reftype eq 'GLOB' && *{$fh}{IO})
		{
			for ($fh->fileno, fileno($fh))
			{
				return unless defined;
				return unless $_ >= 0;
			}

			return true;
		}
	}

	return true if blessed $fh && $fh->DOES('IO::Handle');
	return true if blessed $fh && $fh->DOES('FileHandle');
	return true if blessed $fh && $fh->DOES('IO::All');

	return _ducktype $fh, $expected_methods;
}

sub _oneline ($)
{
	!! ( $_[0] !~ /\r?\n|\r/s )
}

sub is_filename (;$)
{
	my $f = @_ ? shift : ${+_lu};
	return true if blessed $f && $f->DOES('IO::All');
	return true if blessed $f && $f->DOES('Path::Class::Entity');
	return ( length "$f" and _oneline "$f" )
		if blessed $f && overload::Method($f, q[""]);
	return ( length $f and _oneline $f )
		if defined $f && !ref $f;
	return;
}

sub is_fileuri (;$)
{
	my $f = @_ ? shift : ${+_lu};
	return $f if blessed $f && $f->DOES('URI::file');
	return URI::file->new($f->uri) if blessed $f && $f->DOES('RDF::Trine::Node::Resource');
	return URI::file->new($f) if $f =~ m{^file://\S+}i;
	return;
}

sub _generate_as_filehandle
{
	my ($class, $name, $arg) = @_;
	my $default_mode = $arg->{mode} || '<';

	return sub (;$$)
	{
		my $f = @_ ? shift : ${+_lu};
		return $f if is_filehandle($f);

		if (my $uri = is_fileuri($f))
			{ $f = $uri->file }

		my $mode = shift || $default_mode;
		open my $fh, $mode, $f
			or croak "Cannot open '$f' with mode '$mode': $!, died";
		return $fh;
	};
}

*as_filehandle = __PACKAGE__->_generate_as_filehandle('as_filehandle', +{});

{
	package IO::Detect::SmartMatcher;
	BEGIN {
		$IO::Detect::SmartMatcher::AUTHORITY = 'cpan:TOBYINK';
		$IO::Detect::SmartMatcher::VERSION   = '0.202';
	}
	use Scalar::Util qw< blessed >;
	use overload (); no warnings 'overload';  # '~~' unavailable in Perl 5.8
	use overload
		'""'     => 'to_string',
		'~~'     => 'check',
		'=='     => 'check',
		'eq'     => 'check',
		fallback => 1;
	sub check
	{
		my ($self, $thing) = @_;
		$self->[1]->($thing);
	}
	sub to_string
	{
		shift->[0]
	}
	sub new
	{
		my $proto = shift;
		if (blessed $proto and $proto->isa(__PACKAGE__))
		{
			return "$proto"->new(@_);
		}
		bless \@_ => $proto;
	}
}

use constant FileHandle => IO::Detect::SmartMatcher::->new(FileHandle => \&is_filehandle);
use constant FileName   => IO::Detect::SmartMatcher::->new(FileName   => \&is_filename);
use constant FileUri    => IO::Detect::SmartMatcher::->new(FileUri    => \&is_fileuri);

true;

__END__