use strict;
use warnings;
use Test::More;
use Test::Fatal;
# tests for AccessorMustReadWrite
{
use Moose;
my $exception = exception {
has 'test' => (
is => 'ro',
isa => 'Int',
accessor => 'bar',
)
};
like(
$exception,
qr!Cannot define an accessor name on a read-only attribute, accessors are read/write!,
"Read-only attributes can't have accessor");
isa_ok(
$exception,
"Moose::Exception::AccessorMustReadWrite",
"Read-only attributes can't have accessor");
is(
$exception->attribute_name,
'test',
"Read-only attributes can't have accessor");
}
# tests for AttributeIsRequired
{
{
package Foo;
use Moose;
has 'baz' => (
is => 'ro',
isa => 'Int',
required => 1,
);
}
my $exception = exception {
Foo->new;
};
like(
$exception,
qr/\QAttribute (baz) is required/,
"... must supply all the required attribute");
isa_ok(
$exception,
"Moose::Exception::AttributeIsRequired",
"... must supply all the required attribute");
is(
$exception->attribute_name,
'baz',
"... must supply all the required attribute");
isa_ok(
$exception->class_name,
'Foo',
"... must supply all the required attribute");
}
# tests for invalid value for is
{
my $exception = exception {
use Moose;
has 'foo' => (
is => 'bar',
);
};
like(
$exception,
qr/^\QI do not understand this option (is => bar) on attribute (foo)/,
"invalid value for is");
isa_ok(
$exception,
'Moose::Exception::InvalidValueForIs',
"invalid value for is");
}
{
{
package Foo;
use Moose;
}
my $exception = exception {
use Moose;
has 'bar' => (
is => 'ro',
isa => 'Foo',
does => 'Not::A::Role'
);
};
like(
$exception,
qr/^\QCannot have an isa option and a does option if the isa does not do the does on attribute (bar)/,
"isa option should does the role on the given attribute");
isa_ok(
$exception,
'Moose::Exception::IsaDoesNotDoTheRole',
"isa option should does the role on the given attribute");
}
{
{
package Foo;
use Moose;
}
my $exception = exception {
has 'bar' => (
is => 'ro',
isa => 'Not::A::Class',
does => 'Not::A::Role',
);
};
like(
$exception,
qr/^\QCannot have an isa option which cannot ->does() on attribute (bar)/,
"isa option which is not a class cannot ->does the role specified in does");
isa_ok(
$exception,
'Moose::Exception::IsaLacksDoesMethod',
"isa option which is not a class cannot ->does the role specified in does");
}
{
my $exception = exception {
use Moose;
has 'bar' => (
is => 'ro',
coerce => 1,
);
};
like(
$exception,
qr/^\QYou cannot have coercion without specifying a type constraint on attribute (bar)/,
"cannot coerce if type constraint i.e. isa option is not given");
isa_ok(
$exception,
'Moose::Exception::CoercionNeedsTypeConstraint',
"cannot coerce if type constraint i.e. isa option is not given");
}
{
my $exception = exception {
use Moose;
has 'bar' => (
is => 'ro',
isa => 'Int',
weak_ref => 1,
coerce => 1,
);
};
like(
$exception,
qr/^\QYou cannot have a weak reference to a coerced value on attribute (bar)/,
"cannot coerce if attribute is a weak_ref");
isa_ok(
$exception,
'Moose::Exception::CannotCoerceAWeakRef',
"cannot coerce if attribute is a weak_ref");
}
{
my $exception = exception {
use Moose;
has 'bar' => (
is => 'ro',
isa => 'Int',
trigger => "foo",
);
};
like(
$exception,
qr/^\QTrigger must be a CODE ref on attribute (bar)/,
"Trigger must be a CODE ref");
isa_ok(
$exception,
'Moose::Exception::TriggerMustBeACodeRef',
"Trigger must be a CODE ref");
}
{
{
package Foo;
use Moose;
has 'baz' => (
is => 'ro',
isa => 'Int',
builder => "_build_baz",
);
}
my $exception = exception {
Foo->new;
};
like(
$exception,
qr/^\QFoo does not support builder method '_build_baz' for attribute 'baz'/,
"Correct error when a builder method is not present");
isa_ok(
$exception,
'Moose::Exception::BuilderDoesNotExist',
"Correct error when a builder method is not present");
isa_ok(
$exception->instance,
'Foo',
"Correct error when a builder method is not present");
is(
$exception->attribute->name,
'baz',
"Correct error when a builder method is not present");
is(
$exception->attribute->builder,
'_build_baz',
"Correct error when a builder method is not present");
}
# tests for CannotDelegateWithoutIsa
{
my $exception = exception {
package Foo;
use Moose;
has 'bar' => (
is => 'ro',
handles => qr/baz/,
);
};
like(
$exception,
qr/\QCannot delegate methods based on a Regexp without a type constraint (isa)/,
"isa is required while delegating methods based on a Regexp");
isa_ok(
$exception,
'Moose::Exception::CannotDelegateWithoutIsa',
"isa is required while delegating methods based on a Regexp");
}
{
my $exception = exception {
package Foo;
use Moose;
has bar => (
is => 'ro',
auto_deref => 1,
);
};
like(
$exception,
qr/\QYou cannot auto-dereference without specifying a type constraint on attribute (bar)/,
"You cannot auto-dereference without specifying a type constraint on attribute");
isa_ok(
$exception,
'Moose::Exception::CannotAutoDerefWithoutIsa',
"You cannot auto-dereference without specifying a type constraint on attribute");
is(
$exception->attribute_name,
'bar',
"You cannot auto-dereference without specifying a type constraint on attribute");
}
{
my $exception = exception {
package Foo;
use Moose;
has 'bar' => (
is => 'ro',
required => 1,
init_arg => undef,
);
};
like(
$exception,
qr/\QYou cannot have a required attribute (bar) without a default, builder, or an init_arg/,
"No default, builder or init_arg is given");
isa_ok(
$exception,
'Moose::Exception::RequiredAttributeNeedsADefault',
"No default, builder or init_arg is given");
}
{
my $exception = exception {
package Foo;
use Moose;
has 'bar' => (
is => 'ro',
lazy => 1,
);
};
like(
$exception,
qr/\QYou cannot have a lazy attribute (bar) without specifying a default value for it/,
"No default for a lazy attribute is given");
isa_ok(
$exception,
'Moose::Exception::LazyAttributeNeedsADefault',
"No default for a lazy attribute is given");
}
{
my $exception = exception {
package Foo;
use Moose;
has 'bar' => (
is => 'ro',
isa => 'Int',
auto_deref => 1,
);
};
like(
$exception,
qr/\QYou cannot auto-dereference anything other than a ArrayRef or HashRef on attribute (bar)/,
"auto_deref needs either HashRef or ArrayRef");
isa_ok(
$exception,
'Moose::Exception::AutoDeRefNeedsArrayRefOrHashRef',
"auto_deref needs either HashRef or ArrayRef");
}
{
my $exception = exception {
package Foo;
use Moose;
has 'bar' => (
is => 'ro',
lazy_build => 1,
default => 1,
);
};
like(
$exception,
qr/\QYou can not use lazy_build and default for the same attribute (bar)/,
"An attribute can't use lazy_build & default simultaneously");
isa_ok(
$exception,
'Moose::Exception::CannotUseLazyBuildAndDefaultSimultaneously',
"An attribute can't use lazy_build & default simultaneously");
}
{
my $exception = exception {
package Delegator;
use Moose;
sub full { 1 }
sub stub;
has d1 => (
isa => 'X',
handles => ['full'],
);
};
like(
$exception,
qr/\QYou cannot overwrite a locally defined method (full) with a delegation/,
'got an error when trying to declare a delegation method that overwrites a local method');
isa_ok(
$exception,
'Moose::Exception::CannotDelegateLocalMethodIsPresent',
"got an error when trying to declare a delegation method that overwrites a local method");
$exception = exception {
package Delegator;
use Moose;
has d2 => (
isa => 'X',
handles => ['stub'],
);
};
is(
$exception,
undef,
'no error when trying to declare a delegation method that overwrites a stub method');
}
{
{
package Test;
use Moose;
has 'foo' => (
is => 'rw',
clearer => 'clear_foo',
predicate => 'foo',
accessor => 'bar',
);
}
my $exception = exception {
package Test2;
use Moose;
extends 'Test';
has '+foo' => (
clearer => 'clear_foo1',
);
};
like(
$exception,
qr/\QIllegal inherited options => (clearer)/,
"Illegal inherited option is given");
isa_ok(
$exception,
"Moose::Exception::IllegalInheritedOptions",
"Illegal inherited option is given");
$exception = exception {
package Test3;
use Moose;
extends 'Test';
has '+foo' => (
clearer => 'clear_foo1',
predicate => 'xyz',
accessor => 'bar2',
);
};
like(
$exception,
qr/\QIllegal inherited options => (accessor, clearer, predicate)/,
"Illegal inherited option is given");
}
# tests for exception thrown is Moose::Meta::Attribute::set_value
{
my $exception = exception {
{
package Foo1;
use Moose;
has 'bar' => (
is => 'ro',
required => 1,
);
}
my $instance = Foo1->new(bar => "test");
my $bar_attr = Foo1->meta->get_attribute('bar');
my $bar_writer = $bar_attr->get_write_method_ref;
$bar_writer->($instance);
};
like(
$exception,
qr/\QAttribute (bar) is required/,
"... must supply all the required attribute");
isa_ok(
$exception,
"Moose::Exception::AttributeIsRequired",
"... must supply all the required attribute");
is(
$exception->attribute_name,
'bar',
"... must supply all the required attribute");
isa_ok(
$exception->class_name,
'Foo1',
"... must supply all the required attribute");
}
{
my $exception = exception {
{
package Foo1;
use Moose;
has 'bar' => (
is => 'ro',
handles => \*STDIN,
);
}
};
my $handle = \*STDIN;
like(
$exception,
qr/\QUnable to canonicalize the 'handles' option with $handle/,
"handles doesn't take file handle");
#Unable to canonicalize the 'handles' option with GLOB(0x109d0b0)
isa_ok(
$exception,
"Moose::Exception::UnableToCanonicalizeHandles",
"handles doesn't take file handle");
}
{
my $exception = exception {
{
package Foo1;
use Moose;
has 'bar' => (
is => 'ro',
handles => 'Foo1',
);
}
};
like(
$exception,
qr/\QUnable to canonicalize the 'handles' option with Foo1 because its metaclass is not a Moose::Meta::Role/,
"'Str' given to handles should be a metaclass of Moose::Meta::Role");
isa_ok(
$exception,
"Moose::Exception::UnableToCanonicalizeNonRolePackage",
"'Str' given to handles should be a metaclass of Moose::Meta::Role");
}
{
my $exception = exception {
{
package Foo1;
use Moose;
has 'bar' => (
is => 'ro',
isa => 'Not::Loaded',
handles => qr/xyz/,
);
}
};
like(
$exception,
qr/\QThe bar attribute is trying to delegate to a class which has not been loaded - Not::Loaded/,
"You cannot delegate to a class which has not yet loaded");
isa_ok(
$exception,
"Moose::Exception::DelegationToAClassWhichIsNotLoaded",
"You cannot delegate to a class which has not yet loaded");
is(
$exception->attribute->name,
'bar',
"You cannot delegate to a class which has not yet loaded"
);
is(
$exception->class_name,
'Not::Loaded',
"You cannot delegate to a class which has not yet loaded"
);
}
{
my $exception = exception {
{
package Foo1;
use Moose;
has bar => (
is => 'ro',
does => 'Role',
handles => qr/Role/,
);
}
};
like(
$exception,
qr/\QThe bar attribute is trying to delegate to a role which has not been loaded - Role/,
"You cannot delegate to a role which has not yet loaded");
isa_ok(
$exception,
"Moose::Exception::DelegationToARoleWhichIsNotLoaded",
"You cannot delegate to a role which has not yet loaded");
is(
$exception->attribute->name,
'bar',
"You cannot delegate to a role which has not yet loaded"
);
is(
$exception->role_name,
'Role',
"You cannot delegate to a role which has not yet loaded"
);
}
{
my $exception = exception {
{
package Foo1;
use Moose;
has 'bar' => (
is => 'ro',
isa => 'Int',
handles => qr/xyz/,
);
}
};
like(
$exception,
qr/\QThe bar attribute is trying to delegate to a type (Int) that is not backed by a class/,
"Delegating to a type that is not backed by a class");
isa_ok(
$exception,
"Moose::Exception::DelegationToATypeWhichIsNotAClass",
"Delegating to a type that is not backed by a class");
is(
$exception->attribute->name,
'bar',
"Delegating to a type that is not backed by a class");
is(
$exception->attribute->type_constraint->name,
'Int',
"Delegating to a type that is not backed by a class");
$exception = exception {
{
package Foo1;
use Moose;
use Moose::Util::TypeConstraints;
subtype 'PositiveInt',
as 'Int',
where { $_ > 0 };
has 'bar' => (
is => 'ro',
isa => 'PositiveInt',
handles => qr/xyz/,
);
}
};
like(
$exception,
qr/\QThe bar attribute is trying to delegate to a type (PositiveInt) that is not backed by a class/,
"Delegating to a type that is not backed by a class");
isa_ok(
$exception,
"Moose::Exception::DelegationToATypeWhichIsNotAClass",
"Delegating to a type that is not backed by a class");
is(
$exception->attribute->type_constraint->name,
'PositiveInt',
"Delegating to a type that is not backed by a class");
}
{
my $exception = exception {
{
package Foo1;
use Moose;
has 'bar' => (
is => 'ro',
does => '',
handles => qr/xyz/,
);
}
};
like(
$exception,
qr/Cannot find delegate metaclass for attribute bar/,
"no does or isa is given");
isa_ok(
$exception,
"Moose::Exception::CannotFindDelegateMetaclass",
"no does or isa is given");
is(
$exception->attribute->name,
'bar',
"no does or isa is given");
}
# tests for type coercions
{
use Moose;
use Moose::Util::TypeConstraints;
subtype 'HexNum' => as 'Int', where { /[a-f0-9]/i };
my $type_object = find_type_constraint 'HexNum';
my $exception = exception {
$type_object->coerce;
};
like(
$exception,
qr/Cannot coerce without a type coercion/,
"You cannot coerce a type unless coercion is supported by that type");
isa_ok(
$exception,
"Moose::Exception::CoercingWithoutCoercions",
"You cannot coerce a type unless coercion is supported by that type");
is(
$exception->type_name,
'HexNum',
"You cannot coerce a type unless coercion is supported by that type");
}
{
{
package Parent;
use Moose;
has foo => (
is => 'rw',
isa => 'Num',
default => 5.5,
);
}
{
package Child;
use Moose;
extends 'Parent';
has '+foo' => (
isa => 'Int',
default => 100,
);
}
my $foo = Child->new;
my $exception = exception {
$foo->foo(10.5);
};
like(
$exception,
qr/\QAttribute (foo) does not pass the type constraint because: Validation failed for 'Int' with value 10.5/,
"10.5 is not an Int");
isa_ok(
$exception,
"Moose::Exception::ValidationFailedForInlineTypeConstraint",
"10.5 is not an Int");
is(
$exception->class_name,
"Child",
"10.5 is not an Int");
}
{
{
package Foo2;
use Moose;
has a4 => (
traits => ['Array'],
is => 'rw',
isa => 'ArrayRef',
lazy => 1,
default => 'invalid',
clearer => '_clear_a4',
handles => {
get_a4 => 'get',
push_a4 => 'push',
accessor_a4 => 'accessor',
},
);
has a5 => (
traits => ['Array'],
is => 'rw',
isa => 'ArrayRef[Int]',
lazy => 1,
default => sub { [] },
clearer => '_clear_a5',
handles => {
get_a5 => 'get',
push_a5 => 'push',
accessor_a5 => 'accessor',
},
);
}
my $foo = Foo2->new;
my $expect
= qr/\QAttribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value \E.*invalid.*/;
my $exception = exception { $foo->accessor_a4(0); };
like(
$exception,
$expect,
'invalid default is caught when trying to read via accessor');
#Attribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value "invalid"
isa_ok(
$exception,
"Moose::Exception::ValidationFailedForInlineTypeConstraint",
'invalid default is caught when trying to read via accessor');
is(
$exception->class_name,
"Foo2",
'invalid default is caught when trying to read via accessor');
$exception = exception { $foo->accessor_a4( 0 => 42 ); };
like(
$exception,
$expect,
'invalid default is caught when trying to write via accessor');
#Attribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value "invalid"
isa_ok(
$exception,
"Moose::Exception::ValidationFailedForInlineTypeConstraint",
'invalid default is caught when trying to write via accessor');
is(
$exception->class_name,
"Foo2",
'invalid default is caught when trying to write via accessor');
$exception = exception { $foo->push_a4(42); };
like(
$exception,
$expect,
'invalid default is caught when trying to push');
#Attribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value "invalid"
isa_ok(
$exception,
"Moose::Exception::ValidationFailedForInlineTypeConstraint",
'invalid default is caught when trying to push');
is(
$exception->class_name,
"Foo2",
'invalid default is caught when trying to push');
$exception = exception { $foo->get_a4(42); };
like(
$exception,
$expect,
'invalid default is caught when trying to get');
#Attribute (a4) does not pass the type constraint because: Validation failed for 'ArrayRef' with value "invalid"
isa_ok(
$exception,
"Moose::Exception::ValidationFailedForInlineTypeConstraint",
'invalid default is caught when trying to get');
is(
$exception->class_name,
"Foo2",
'invalid default is caught when trying to get');
}
{
my $class = Moose::Meta::Class->create("RedundantClass");
my $attr = Moose::Meta::Attribute->new('foo', (auto_deref => 1,
isa => 'ArrayRef',
is => 'ro'
)
);
my $attr2 = $attr->clone_and_inherit_options( isa => 'Int');
my $exception = exception {
$attr2->get_value($class);
};
like(
$exception,
qr/Can not auto de-reference the type constraint 'Int'/,
"Cannot auto-deref with 'Int'");
isa_ok(
$exception,
"Moose::Exception::CannotAutoDereferenceTypeConstraint",
"Cannot auto-deref with 'Int'");
is(
$exception->attribute->name,
"foo",
"Cannot auto-deref with 'Int'");
is(
$exception->type_name,
"Int",
"Cannot auto-deref with 'Int'");
}
{
{
my $parameterizable = subtype 'ParameterizableArrayRef', as 'ArrayRef';
my $int = find_type_constraint('Int');
my $from_parameterizable = $parameterizable->parameterize($int);
{
package Parameterizable;
use Moose;
has from_parameterizable => ( is => 'rw', isa => $from_parameterizable );
}
}
my $params = Parameterizable->new();
my $exception = exception {
$params->from_parameterizable( 'Hello' );
};
like(
$exception,
qr/\QAttribute (from_parameterizable) does not pass the type constraint because: Validation failed for 'ParameterizableArrayRef[Int]'\E with value "?Hello"?/,
"'Hello' is a Str");
isa_ok(
$exception,
"Moose::Exception::ValidationFailedForInlineTypeConstraint",
"'Hello' is a Str");
is(
$exception->class_name,
"Parameterizable",
"'Hello' is a Str");
is(
$exception->value,
"Hello",
"'Hello' is a Str");
is(
$exception->attribute_name,
"from_parameterizable",
"'Hello' is a Str");
}
{
{
package Test::LazyBuild::Attribute;
use Moose;
has 'fool' => ( lazy_build => 1, is => 'ro');
}
my $instance = Test::LazyBuild::Attribute->new;
my $exception = exception {
$instance->fool;
};
like(
$exception,
qr/\QTest::LazyBuild::Attribute does not support builder method '_build_fool' for attribute 'fool' /,
"builder method _build_fool doesn't exist");
isa_ok(
$exception,
"Moose::Exception::BuilderMethodNotSupportedForInlineAttribute",
"builder method _build_fool doesn't exist");
is(
$exception->attribute_name,
"fool",
"builder method _build_fool doesn't exist");
is(
$exception->builder,
"_build_fool",
"builder method _build_fool doesn't exist");
is(
$exception->class_name,
"Test::LazyBuild::Attribute",
"builder method _build_fool doesn't exist");
}
{
{
package Foo::Required;
use Moose;
has 'foo_required' => (
reader => 'get_foo_required',
writer => 'set_foo_required',
required => 1,
);
}
my $foo = Foo::Required->new(foo_required => "required");
my $exception = exception {
$foo->set_foo_required();
};
like(
$exception,
qr/\QAttribute (foo_required) is required/,
"passing no value to set_foo_required");
isa_ok(
$exception,
"Moose::Exception::AttributeIsRequired",
"passing no value to set_foo_required");
is(
$exception->attribute_name,
'foo_required',
"passing no value to set_foo_required");
isa_ok(
$exception->class_name,
'Foo::Required',
"passing no value to set_foo_required");
}
{
use Moose::Util::TypeConstraints;
my $exception = exception {
{
package BadMetaClass;
use Moose;
has 'foo' => (
is => 'ro',
isa => "Moose::Util::TypeConstraints",
handles => qr/hello/
);
}
};
like(
$exception,
qr/Unable to recognize the delegate metaclass 'Class::MOP::Package/,
"unable to recognize metaclass of Moose::Util::TypeConstraints");
isa_ok(
$exception,
"Moose::Exception::UnableToRecognizeDelegateMetaclass",
"unable to recognize metaclass of Moose::Util::TypeConstraints");
is(
$exception->attribute->name,
'foo',
"unable to recognize metaclass of Moose::Util::TypeConstraints");
is(
$exception->delegate_metaclass->name,
'Moose::Util::TypeConstraints',
"unable to recognize metaclass of Moose::Util::TypeConstraints");
}
{
my $exception = exception {
package Foo::CannotCoerce::WithoutCoercion;
use Moose;
has 'foo' => (
is => 'ro',
isa => 'Str',
coerce => 1
)
};
like(
$exception,
qr/\QYou cannot coerce an attribute (foo) unless its type (Str) has a coercion/,
"has throws error with odd number of attribute options");
isa_ok(
$exception,
"Moose::Exception::CannotCoerceAttributeWhichHasNoCoercion",
"has throws error with odd number of attribute options");
is(
$exception->attribute_name,
'foo',
"has throws error with odd number of attribute options");
is(
$exception->type_name,
'Str',
"has throws error with odd number of attribute options");
}
{
my $exception = exception {
{
package Foo1;
use Moose;
has 'bar' => (
is =>
);
}
};
like(
$exception,
qr/\QYou must pass an even number of attribute options/,
'has throws exception with odd number of attribute options');
isa_ok(
$exception,
"Moose::Exception::MustPassEvenNumberOfAttributeOptions",
'has throws exception with odd number of attribute options');
is(
$exception->attribute_name,
'bar',
'has throws exception with odd number of attribute options');
}
{
my $exception = exception {
{
package Foo1;
use Moose;
has bar => (
is => 'ro',
required => 1,
isa => 'Int',
);
}
Foo1->new(bar => "test");
};
like(
$exception,
qr/^Attribute \(bar\) does not pass the type constraint because: Validation failed for 'Int' with value "?test"?/,
"bar is an 'Int' and 'Str' is given");
#Attribute (bar) does not pass the type constraint because: Validation failed for 'Int' with value "test"
isa_ok(
$exception,
"Moose::Exception::ValidationFailedForTypeConstraint",
"bar is an 'Int' and 'Str' is given");
}
done_testing;