File Coverage

blib/lib/SmartMatch/Sugar.pm

Criterion	Covered	Total	%
statement	74	108	68.5
branch	12	34	35.2
condition	10	45	22.2
subroutine	33	37	89.1
pod	7	7	100.0
total	136	231	58.8

#!/usr/bin/perl

package SmartMatch::Sugar;

use strict;
use warnings;

use Scalar::Util qw(blessed looks_like_number);
use Carp qw(croak);
use Class::Inspector ();

our $VERSION = "0.04";

use Sub::Exporter -setup => {
	exports => [qw(
		any none

		object class inv_isa inv_can inv_does

		overloaded stringifies

		array array_length_is non_empty_array even_sized_array

		hash hash_size_is non_empty_hash

		non_ref string_length_is non_empty_string

		match
	)],
	groups => {
		default  => [ -all ],
		base     => [ qw/any none/ ],
		object   => [ qw/object class inv_isa inv_can inv_does/ ],
		overload => [ qw/overloaded stringifies/ ],
		array    => [ qw/array array_length_is non_empty_array even_sized_array/ ],
		hash     => [ qw/hash hash_size_is non_empty_hash/ ],
		string   => [ qw/non_ref string_length_is non_empty_string/ ],
		match    => [ qw/match/ ],
	},
};

use 5.010;

{
	package SmartMatch::Sugar::Overloaded;
	use overload '~~' => sub { $_[0]->(@_) };
}

sub match (&) { bless $_[0], "SmartMatch::Sugar::Overloaded" }

use constant any => match { not(not(1)) };
use constant none => match { not(not(0)) };

use constant non_empty_string => match {
	defined($_[1])
		and
	not ref($_[1])
		and
	length($_[1])
};

sub string_length_is ($) {
	my $length = _length(shift);

	return match {
		defined($_[1])
			and
		not ref($_[1])
			and
		length($_[1]) == $length
	}
}

use constant non_ref => match {
	defined($_[1])
		and
	not ref($_[1])
};

use overload ();
use constant overloaded => match {
	blessed($_[1])
		and
	overload::Overloaded($_[1]);
};

use constant stringifies => match {
	blessed($_[1])
		and
	overload::OverloadedStringify($_[1]);
};

use constant object => match { blessed($_[1]) };

use constant class => match {
	not ref($_[1])
		and
	Class::Inspector->loaded($_[1])
};

sub inv_does ($) {
	my $role = shift;

	return match {
		blessed($_[1]) || ( defined($_[1]) && not(ref($_[1])) )
			and
		$_[1]->DOES($role);
	}
}

sub inv_isa ($) {
	my $class = shift;
	return match {
		blessed($_[1]) || ( defined($_[1]) && not(ref($_[1])) )
			and
		$_[1]->isa($class);
	}
}

sub inv_can ($) {
	my $method = shift;
	return match {
		blessed($_[1]) || ( defined($_[1]) && not(ref($_[1])) )
			and
		$_[1]->can($method);
	}
}
use constant array => match {
	ref($_[1])
		and
	ref($_[1]) eq 'ARRAY'
};

use constant hash => match {
	ref($_[1])
		and
	ref($_[1]) eq 'HASH'
};

use constant non_empty_array => match {
	ref($_[1])
		and
	ref($_[1]) eq 'ARRAY'
		and
	scalar(@{ $_[1] })
};

use constant non_empty_hash => match {
	ref($_[1])
		and
	ref($_[1]) eq 'HASH'
		and
	scalar(keys %{ $_[1] });
};

use constant even_sized_array => match {
	ref($_[1])
		and
	ref($_[1]) eq 'ARRAY'
		and
	scalar(@{$_[1]}) % 2 == 0
};

sub array_length_is ($) {
	my $length = _length(shift);

	return match {
		ref($_[1])
			and
		ref($_[1]) eq 'ARRAY'
			and
		scalar(@{$_[1]}) == $length
	};
}

sub hash_size_is ($) {
	my $length = _length(shift);

	return match {
		ref($_[1])
			and
		ref($_[1]) eq 'HASH'
			and
		scalar(keys %{$_[1]}) == $length
	};
}

sub _length ($) {
	my $length = shift;

	unless ( looks_like_number($length) and $length >= 0 and int($length) == $length ) {
		croak "Length is not a positive integer";
	}

	return int $length;
}

__PACKAGE__

__END__