File Coverage

blib/lib/PerlX/Assert.pm

Criterion	Covered	Total	%
statement	43	50	86.0
branch	13	24	54.1
condition	6	15	40.0
subroutine	11	13	84.6
pod			n/a
total	73	102	71.5

use 5.008001;
use strict;
use warnings;
no warnings qw( uninitialized void once );

use Devel::StrictMode ();
use Exporter::Tiny ();

package PerlX::Assert;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.903';
our @ISA       = qw( Exporter::Tiny );
our @EXPORT    = qw( assert );

our $NO_KEYWORD_API;
my $IMPLEMENTATION;
my %HINTS = (check => 1);

# This functionality probably needs to be added to
# Exporter::Tiny itself.
sub import
{
	my $me = shift;
	my $symbols = grep {
		ref($_)                        ? 0 :  # refs are not symbols
		/\A[:-](\w+)\z/ && $HINTS{$1}  ? 0 :  # hints are not symbols
		1;                                    # everything else is
	} @_;

	push @_, @EXPORT if $symbols == 0;

	my $globals = ref($_[0]) eq 'HASH' ? shift() : {};
	unshift @_, $me, $globals;
	goto \&Exporter::Tiny::import;
}

sub _exporter_validate_opts
{
	my $me = shift;
	my ($globals) = @_;

	$IMPLEMENTATION ||= $me unless $me eq __PACKAGE__;
	$IMPLEMENTATION ||= eval {
		die if $NO_KEYWORD_API;
		require PerlX::Assert::Keyword;
		'PerlX::Assert::Keyword';
	}
	|| do {
		require PerlX::Assert::DD;
		'PerlX::Assert::DD';
	};

	++$globals->{check} if Devel::StrictMode::STRICT;
}

sub _exporter_install_sub
{
	my $me = shift;
	my ($name, $value, $globals, $sym) = @_;

	# This is harder than it should be. :-(
	# A rather roundabout method for overwriting
	# the installation of the 'assert' function.
	if ($name eq 'assert' and not ref $globals->{into})
	{
		my $tmp = exists($globals->{installer})
			? [ delete($globals->{installer}) ]
			: undef;
		$globals->{installer} = sub {
			$IMPLEMENTATION->_install_assert(
				$_[1][0],
				$globals,
			);
		};
		$me->SUPER::_exporter_install_sub(@_);
		$tmp
			? ($globals->{installer} = $tmp->[0])
			: delete($globals->{installer});
		return;
	}

	$me->SUPER::_exporter_install_sub(@_);
}

sub _generate_assert
{
	my $me = shift;
	my ($name, $args, $globals) = @_;

	return sub ($$) { 0 }
		unless $globals->{check};

	return sub ($$) {
		my ($desc, $value) = @_==1 ? (undef, @_) : @_;
		return if $value;
		require Carp;
		Carp::croak(sprintf(q[Assertion failed: %s], $desc)) if defined $desc;
		Carp::croak(sprintf(q[Assertion failed]));
	};
}

*assert = __PACKAGE__->_generate_assert(assert => {}, {});

__PACKAGE__
__END__