The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package MyEvenClass;

use MooseX::Contract;
use Moose::Util::TypeConstraints;

my $even_int = subtype 'Int', where { $_ % 2 == 0};

has value => (
	is => 'rw',
	isa => $even_int,
	required => 1,
	default => 0
);

invariant assert { shift->{value} % 2 == 0 } 'self->{value} must be an even value';

contract incr => accepts [$even_int];
sub incr {
	my $self = shift;
	my $incr = shift;
	$self->{value} += $incr;
	return;
}
contract incr_by_two => accepts void, returns void;
sub incr_by_two {
	shift->{value} += 2;
	return;
}
contract bad_return => returns void;
sub bad_return {
	my $self = shift;
	return "Hiya!";
}

sub bad_method {
	shift->{value}++;
}

contract 'get_multiple'
	=> accepts ['Int'],
	=> returns [$even_int];
sub get_multiple {
	return shift->{value} * shift;
}

contract 'get_multiple_bad'
	=> accepts ['Int'],
	=> returns [$even_int];
sub get_multiple_bad {
	return (shift->{value} * shift) + 1;
}

no MooseX::Contract;

__PACKAGE__->meta->make_immutable;


package main;

use strict;
use warnings;
use Test::More tests => 11;

BEGIN { require_ok('MooseX::Contract') };

my $o = MyEvenClass->new;
is($o->value, 0, 'initialized properly');
$o->incr(2);
is($o->value, 2, 'incremented properly');
eval { $o->incr(1) };
ok($@, "accepts error expected");
eval { my $foo = $o->bad_return };
ok($@, "returns error expected");
eval { $o->bad_return };
ok(!$@, "no returns error in void context") || diag $@;
eval { $o->bad_method };
ok($@, "invariant causes error on bad_method");
$o->value(2);
$o->incr_by_two;
is($o->value, 4, 'incr_by_two');
eval { $o->incr_by_two(1) };
ok($@, 'incr_by_two with extra args fails as expected');

is($o->get_multiple(3), $o->{value} * 3, 'get_multiple');
eval { my $multiple = $o->get_multiple_bad(3) };
ok($@, 'returns assertion fails') || diag $@;