--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 29;
+use Test::Exception;
+
+use Scalar::Util 'isweak';
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ eval {
+ has 'foo' => (
+ reader => 'get_foo',
+ writer => 'set_foo',
+ );
+ };
+ ::ok(!$@, '... created the writer method okay');
+
+ eval {
+ has 'foo_required' => (
+ reader => 'get_foo_required',
+ writer => 'set_foo_required',
+ required => 1,
+ );
+ };
+ ::ok(!$@, '... created the required writer method okay');
+
+ eval {
+ has 'foo_int' => (
+ reader => 'get_foo_int',
+ writer => 'set_foo_int',
+ isa => 'Int',
+ );
+ };
+ ::ok(!$@, '... created the writer method with type constraint okay');
+
+ eval {
+ has 'foo_weak' => (
+ reader => 'get_foo_weak',
+ writer => 'set_foo_weak',
+ weak_ref => 1
+ );
+ };
+ ::ok(!$@, '... created the writer method with weak_ref okay');
+}
+
+{
+ my $foo = Foo->new(foo_required => 'required');
+ isa_ok($foo, 'Foo');
+
+ # regular writer
+
+ can_ok($foo, 'set_foo');
+ is($foo->get_foo(), undef, '... got an unset value');
+ lives_ok {
+ $foo->set_foo(100);
+ } '... set_foo wrote successfully';
+ is($foo->get_foo(), 100, '... got the correct set value');
+
+ ok(!isweak($foo->{foo}), '... it is not a weak reference');
+
+ # required writer
+
+ dies_ok {
+ Foo->new;
+ } '... cannot create without the required attribute';
+
+ can_ok($foo, 'set_foo_required');
+ is($foo->get_foo_required(), 'required', '... got an unset value');
+ lives_ok {
+ $foo->set_foo_required(100);
+ } '... set_foo_required wrote successfully';
+ is($foo->get_foo_required(), 100, '... got the correct set value');
+
+ dies_ok {
+ $foo->set_foo_required();
+ } '... set_foo_required died successfully with no value';
+
+ lives_ok {
+ $foo->set_foo_required(undef);
+ } '... set_foo_required did accept undef';
+
+ ok(!isweak($foo->{foo_required}), '... it is not a weak reference');
+
+ # with type constraint
+
+ can_ok($foo, 'set_foo_int');
+ is($foo->get_foo_int(), undef, '... got an unset value');
+ lives_ok {
+ $foo->set_foo_int(100);
+ } '... set_foo_int wrote successfully';
+ is($foo->get_foo_int(), 100, '... got the correct set value');
+
+ dies_ok {
+ $foo->set_foo_int("Foo");
+ } '... set_foo_int died successfully';
+
+ ok(!isweak($foo->{foo_int}), '... it is not a weak reference');
+
+ # with weak_ref
+
+ my $test = [];
+
+ can_ok($foo, 'set_foo_weak');
+ is($foo->get_foo_weak(), undef, '... got an unset value');
+ lives_ok {
+ $foo->set_foo_weak($test);
+ } '... set_foo_weak wrote successfully';
+ is($foo->get_foo_weak(), $test, '... got the correct set value');
+
+ ok(isweak($foo->{foo_weak}), '... it is a weak reference');
+}
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 57;
+use Test::Exception;
+
+use Scalar::Util 'isweak';
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ eval {
+ has 'foo' => (
+ accessor => 'foo',
+ );
+ };
+ ::ok(!$@, '... created the accessor method okay');
+
+ eval {
+ has 'lazy_foo' => (
+ accessor => 'lazy_foo',
+ lazy => 1,
+ default => sub { 10 }
+ );
+ };
+ ::ok(!$@, '... created the lazy accessor method okay');
+
+
+ eval {
+ has 'foo_required' => (
+ accessor => 'foo_required',
+ required => 1,
+ );
+ };
+ ::ok(!$@, '... created the required accessor method okay');
+
+ eval {
+ has 'foo_int' => (
+ accessor => 'foo_int',
+ isa => 'Int',
+ );
+ };
+ ::ok(!$@, '... created the accessor method with type constraint okay');
+
+ eval {
+ has 'foo_weak' => (
+ accessor => 'foo_weak',
+ weak_ref => 1
+ );
+ };
+ ::ok(!$@, '... created the accessor method with weak_ref okay');
+
+ eval {
+ has 'foo_deref' => (
+ accessor => 'foo_deref',
+ isa => 'ArrayRef',
+ auto_deref => 1,
+ );
+ };
+ ::ok(!$@, '... created the accessor method with auto_deref okay');
+
+ eval {
+ has 'foo_deref_ro' => (
+ reader => 'foo_deref_ro',
+ isa => 'ArrayRef',
+ auto_deref => 1,
+ );
+ };
+ ::ok(!$@, '... created the reader method with auto_deref okay');
+
+ eval {
+ has 'foo_deref_hash' => (
+ accessor => 'foo_deref_hash',
+ isa => 'HashRef',
+ auto_deref => 1,
+ );
+ };
+ ::ok(!$@, '... created the reader method with auto_deref okay');
+}
+
+{
+ my $foo = Foo->new(foo_required => 'required');
+ isa_ok($foo, 'Foo');
+
+ # regular accessor
+
+ can_ok($foo, 'foo');
+ is($foo->foo(), undef, '... got an unset value');
+ lives_ok {
+ $foo->foo(100);
+ } '... foo wrote successfully';
+ is($foo->foo(), 100, '... got the correct set value');
+
+ ok(!isweak($foo->{foo}), '... it is not a weak reference');
+
+ # required writer
+
+ dies_ok {
+ Foo->new;
+ } '... cannot create without the required attribute';
+
+ can_ok($foo, 'foo_required');
+ is($foo->foo_required(), 'required', '... got an unset value');
+ lives_ok {
+ $foo->foo_required(100);
+ } '... foo_required wrote successfully';
+ is($foo->foo_required(), 100, '... got the correct set value');
+
+ lives_ok {
+ $foo->foo_required(undef);
+ } '... foo_required did not die with undef';
+
+ is($foo->foo_required, undef, "value is undef");
+
+ ok(!isweak($foo->{foo_required}), '... it is not a weak reference');
+
+ # lazy
+
+ ok(!exists($foo->{lazy_foo}), '... no value in lazy_foo slot');
+
+ can_ok($foo, 'lazy_foo');
+ is($foo->lazy_foo(), 10, '... got an deferred value');
+
+ # with type constraint
+
+ can_ok($foo, 'foo_int');
+ is($foo->foo_int(), undef, '... got an unset value');
+ lives_ok {
+ $foo->foo_int(100);
+ } '... foo_int wrote successfully';
+ is($foo->foo_int(), 100, '... got the correct set value');
+
+ dies_ok {
+ $foo->foo_int("Foo");
+ } '... foo_int died successfully';
+
+ ok(!isweak($foo->{foo_int}), '... it is not a weak reference');
+
+ # with weak_ref
+
+ my $test = [];
+
+ can_ok($foo, 'foo_weak');
+ is($foo->foo_weak(), undef, '... got an unset value');
+ lives_ok {
+ $foo->foo_weak($test);
+ } '... foo_weak wrote successfully';
+ is($foo->foo_weak(), $test, '... got the correct set value');
+
+ ok(isweak($foo->{foo_weak}), '... it is a weak reference');
+
+ can_ok( $foo, 'foo_deref');
+ is_deeply( [$foo->foo_deref()], [], '... default default value');
+ my @list;
+ lives_ok {
+ @list = $foo->foo_deref();
+ } "... doesn't deref undef value";
+ is_deeply( \@list, [], "returns empty list in list context");
+
+ lives_ok {
+ $foo->foo_deref( [ qw/foo bar gorch/ ] );
+ } '... foo_deref wrote successfully';
+
+ is( Scalar::Util::reftype( scalar $foo->foo_deref() ), "ARRAY", "returns an array reference in scalar context" );
+ is_deeply( scalar($foo->foo_deref()), [ qw/foo bar gorch/ ], "correct array" );
+
+ is( scalar( () = $foo->foo_deref() ), 3, "returns list in list context" );
+ is_deeply( [ $foo->foo_deref() ], [ qw/foo bar gorch/ ], "correct list" );
+
+
+ can_ok( $foo, 'foo_deref' );
+ is_deeply( [$foo->foo_deref_ro()], [], "... default default value" );
+
+ dies_ok {
+ $foo->foo_deref_ro( [] );
+ } "... read only";
+
+ $foo->{foo_deref_ro} = [qw/la la la/];
+
+ is_deeply( scalar($foo->foo_deref_ro()), [qw/la la la/], "scalar context ro" );
+ is_deeply( [ $foo->foo_deref_ro() ], [qw/la la la/], "list context ro" );
+
+ can_ok( $foo, 'foo_deref_hash' );
+ is_deeply( { $foo->foo_deref_hash() }, {}, "... default default value" );
+
+ my %hash;
+ lives_ok {
+ %hash = $foo->foo_deref_hash();
+ } "... doesn't deref undef value";
+ is_deeply( \%hash, {}, "returns empty list in list context");
+
+ lives_ok {
+ $foo->foo_deref_hash( { foo => 1, bar => 2 } );
+ } '... foo_deref_hash wrote successfully';
+
+ is_deeply( scalar($foo->foo_deref_hash), { foo => 1, bar => 2 }, "scalar context" );
+
+ %hash = $foo->foo_deref_hash;
+ is_deeply( \%hash, { foo => 1, bar => 2 }, "list context");
+}
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+use Test::Exception;
+
+
+
+{
+ package Foo::Role;
+ use Mouse::Role;
+ use Mouse::Util::TypeConstraints;
+
+ # if does() exists on its own, then
+ # we create a type constraint for
+ # it, just as we do for isa()
+ has 'bar' => (is => 'rw', does => 'Bar::Role');
+ has 'baz' => (
+ is => 'rw',
+ does => role_type('Bar::Role')
+ );
+
+ package Bar::Role;
+ use Mouse::Role;
+
+ # if isa and does appear together, then see if Class->does(Role)
+ # if it does work... then the does() check is actually not needed
+ # since the isa() check will imply the does() check
+ has 'foo' => (is => 'rw', isa => 'Foo::Class', does => 'Foo::Role');
+
+ package Foo::Class;
+ use Mouse;
+
+ with 'Foo::Role';
+
+ package Bar::Class;
+ use Mouse;
+
+ with 'Bar::Role';
+
+}
+
+my $foo = Foo::Class->new;
+isa_ok($foo, 'Foo::Class');
+
+my $bar = Bar::Class->new;
+isa_ok($bar, 'Bar::Class');
+
+lives_ok {
+ $foo->bar($bar);
+} '... bar passed the type constraint okay';
+
+dies_ok {
+ $foo->bar($foo);
+} '... foo did not pass the type constraint okay';
+
+lives_ok {
+ $foo->baz($bar);
+} '... baz passed the type constraint okay';
+
+dies_ok {
+ $foo->baz($foo);
+} '... foo did not pass the type constraint okay';
+
+lives_ok {
+ $bar->foo($foo);
+} '... foo passed the type constraint okay';
+
+
+
+# some error conditions
+
+{
+ package Baz::Class;
+ use Test::More;
+ use Mouse;
+
+ local $TODO = 'setting both isa and does';
+
+ # if isa and does appear together, then see if Class->does(Role)
+ # if it does not,.. we have a conflict... so we die loudly
+ ::dies_ok {
+ has 'foo' => (isa => 'Foo::Class', does => 'Bar::Class');
+ } '... cannot have a does() which is not done by the isa()';
+}
+
+{
+ package Bling;
+ use strict;
+ use warnings;
+
+ sub bling { 'Bling::bling' }
+
+ package Bling::Bling;
+ use Test::More;
+ use Mouse;
+
+ local $TODO = 'setting both isa and does';
+
+ # if isa and does appear together, then see if Class->does(Role)
+ # if it does not,.. we have a conflict... so we die loudly
+ ::dies_ok {
+ has 'foo' => (isa => 'Bling', does => 'Bar::Class');
+ } '... cannot have a isa() which is cannot does()';
+}
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 15;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (is => 'ro', required => 1);
+ has 'baz' => (is => 'rw', default => 100, required => 1);
+ has 'boo' => (is => 'rw', lazy => 1, default => 50, required => 1);
+}
+
+{
+ my $foo = Foo->new(bar => 10, baz => 20, boo => 100);
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 10, '... got the right bar');
+ is($foo->baz, 20, '... got the right baz');
+ is($foo->boo, 100, '... got the right boo');
+}
+
+{
+ my $foo = Foo->new(bar => 10, boo => 5);
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 10, '... got the right bar');
+ is($foo->baz, 100, '... got the right baz');
+ is($foo->boo, 5, '... got the right boo');
+}
+
+{
+ my $foo = Foo->new(bar => 10);
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, 10, '... got the right bar');
+ is($foo->baz, 100, '... got the right baz');
+ is($foo->boo, 50, '... got the right boo');
+}
+
+#Yeah.. this doesn't work like this anymore, see below. (groditi)
+#throws_ok {
+# Foo->new(bar => 10, baz => undef);
+#} qr/^Attribute \(baz\) is required and cannot be undef/, '... must supply all the required attribute';
+
+#throws_ok {
+# Foo->new(bar => 10, boo => undef);
+#} qr/^Attribute \(boo\) is required and cannot be undef/, '... must supply all the required attribute';
+
+lives_ok {
+ Foo->new(bar => 10, baz => undef);
+} '... undef is a valid attribute value';
+
+lives_ok {
+ Foo->new(bar => 10, boo => undef);
+} '... undef is a valid attribute value';
+
+
+throws_ok {
+ Foo->new;
+} qr/^Attribute \(bar\) is required/, '... must supply all the required attribute';
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 16;
+use Test::Exception;
+
+
+
+{
+ package Foo::Meta::Attribute;
+ use Mouse;
+
+ extends 'Mouse::Meta::Attribute';
+
+ around 'new' => sub {
+ my $next = shift;
+ my $self = shift;
+ my $name = shift;
+ $next->($self, $name, (is => 'rw', isa => 'Foo'), @_);
+ };
+
+ package Foo;
+ use Mouse;
+
+ has 'foo' => (metaclass => 'Foo::Meta::Attribute');
+}
+{
+ my $foo = Foo->new;
+ isa_ok($foo, 'Foo');
+
+ my $foo_attr = Foo->meta->get_attribute('foo');
+ isa_ok($foo_attr, 'Foo::Meta::Attribute');
+ isa_ok($foo_attr, 'Mouse::Meta::Attribute');
+
+ is($foo_attr->name, 'foo', '... got the right name for our meta-attribute');
+ ok($foo_attr->has_accessor, '... our meta-attrubute created the accessor for us');
+
+ ok($foo_attr->has_type_constraint, '... our meta-attrubute created the type_constraint for us');
+
+ my $foo_attr_type_constraint = $foo_attr->type_constraint;
+ isa_ok($foo_attr_type_constraint, 'Mouse::Meta::TypeConstraint');
+
+ is($foo_attr_type_constraint->name, 'Foo', '... got the right type constraint name');
+
+ local $TODO = '$type_constraint->parent is not reliable';
+ is($foo_attr_type_constraint->parent, 'Object', '... got the right type constraint parent name');
+}
+{
+ package Bar::Meta::Attribute;
+ use Mouse;
+
+ #extends 'Class::MOP::Attribute';
+ extends 'Mouse::Meta::Attribute';
+
+ package Bar;
+ use Mouse;
+
+ ::lives_ok {
+ has 'bar' => (metaclass => 'Bar::Meta::Attribute');
+ } '... the attribute metaclass need not be a Mouse::Meta::Attribute as long as it behaves';
+}
+
+{
+ package Mouse::Meta::Attribute::Custom::Foo;
+ sub register_implementation { 'Foo::Meta::Attribute' }
+
+ package Mouse::Meta::Attribute::Custom::Bar;
+ use Mouse;
+
+ extends 'Mouse::Meta::Attribute';
+
+ package Another::Foo;
+ use Mouse;
+
+ ::lives_ok {
+ has 'foo' => (metaclass => 'Foo');
+ } '... the attribute metaclass alias worked correctly';
+
+ ::lives_ok {
+ has 'bar' => (metaclass => 'Bar', is => 'bare');
+ } '... the attribute metaclass alias worked correctly';
+}
+
+{
+ my $foo_attr = Another::Foo->meta->get_attribute('foo');
+ isa_ok($foo_attr, 'Foo::Meta::Attribute');
+ isa_ok($foo_attr, 'Mouse::Meta::Attribute');
+
+ my $bar_attr = Another::Foo->meta->get_attribute('bar');
+ isa_ok($bar_attr, 'Mouse::Meta::Attribute::Custom::Bar');
+ isa_ok($bar_attr, 'Mouse::Meta::Attribute');
+}
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 18;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (is => 'rw', isa => 'ArrayRef | HashRef');
+}
+
+my $foo = Foo->new;
+isa_ok($foo, 'Foo');
+
+lives_ok {
+ $foo->bar([])
+} '... set bar successfully with an ARRAY ref';
+
+lives_ok {
+ $foo->bar({})
+} '... set bar successfully with a HASH ref';
+
+dies_ok {
+ $foo->bar(100)
+} '... couldnt set bar successfully with a number';
+
+dies_ok {
+ $foo->bar(sub {})
+} '... couldnt set bar successfully with a CODE ref';
+
+# check the constructor
+
+lives_ok {
+ Foo->new(bar => [])
+} '... created new Foo with bar successfully set with an ARRAY ref';
+
+lives_ok {
+ Foo->new(bar => {})
+} '... created new Foo with bar successfully set with a HASH ref';
+
+dies_ok {
+ Foo->new(bar => 50)
+} '... didnt create a new Foo with bar as a number';
+
+dies_ok {
+ Foo->new(bar => sub {})
+} '... didnt create a new Foo with bar as a CODE ref';
+
+{
+ package Bar;
+ use Mouse;
+
+ has 'baz' => (is => 'rw', isa => 'Str | CodeRef');
+}
+
+my $bar = Bar->new;
+isa_ok($bar, 'Bar');
+
+lives_ok {
+ $bar->baz('a string')
+} '... set baz successfully with a string';
+
+lives_ok {
+ $bar->baz(sub { 'a sub' })
+} '... set baz successfully with a CODE ref';
+
+dies_ok {
+ $bar->baz(\(my $var1))
+} '... couldnt set baz successfully with a SCALAR ref';
+
+dies_ok {
+ $bar->baz({})
+} '... couldnt set bar successfully with a HASH ref';
+
+# check the constructor
+
+lives_ok {
+ Bar->new(baz => 'a string')
+} '... created new Bar with baz successfully set with a string';
+
+lives_ok {
+ Bar->new(baz => sub { 'a sub' })
+} '... created new Bar with baz successfully set with a CODE ref';
+
+dies_ok {
+ Bar->new(baz => \(my $var2))
+} '... didnt create a new Bar with baz as a number';
+
+dies_ok {
+ Bar->new(baz => {})
+} '... didnt create a new Bar with baz as a HASH ref';
+
+
#!/usr/bin/perl
-use lib 't/lib';
use strict;
use warnings;
use Test::More tests => 12;
-
use Test::Exception;
use Test::Mouse;
after 'install_accessors' => sub {
my $self = shift;
- my $reader = $self->get_read_method_ref;
-
$self->associated_class->add_method(
$self->alias_to,
- $reader,
+ $self->get_read_method_ref
);
};
}
is($c->baz, 100, '... got the right value for baz');
my $bar_attr = $c->meta->get_attribute('bar');
-
does_ok($bar_attr, 'My::Attribute::Trait');
ok($bar_attr->has_applied_traits, '... got the applied traits');
is_deeply($bar_attr->applied_traits, [qw/My::Attribute::Trait/], '... got the applied traits');
use Test::More tests => 23;
use Test::Exception;
-
-use lib 't/lib';
use Test::Mouse;
+
+
{
package My::Attribute::Trait;
use Mouse::Role;
is($bar_attr->foo, "blah", "attr initialized");
ok(!$bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity");
-{
- local $TODO = 'Mouse does not support ->does($aliased)';
- ok($bar_attr->does('Aliased'), "attr->does uses aliases");
-}
+ok($bar_attr->does('Aliased'), "attr->does uses aliases");
ok(!$bar_attr->meta->does_role('Fictional'), "does_role returns false for nonexistent roles");
ok(!$bar_attr->does('Fictional'), "attr->does returns false for nonexistent roles");
is($derived_bar_attr->the_other_attr, "oink", "attr initialized" );
ok(!$derived_bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity");
-{
- local $TODO = 'Mouse does not support ->does($aliased)';
- ok($derived_bar_attr->does('Aliased'), "attr->does uses aliases");
-}
+ok($derived_bar_attr->does('Aliased'), "attr->does uses aliases");
ok(!$derived_bar_attr->meta->does_role('Fictional'), "does_role returns false for nonexistent roles");
ok(!$derived_bar_attr->does('Fictional'), "attr->does returns false for nonexistent roles");
use Test::More tests => 7;
use Test::Exception;
-
-use lib 't/lib';
use Test::Mouse;
+
+
{
package My::Meta::Attribute::DefaultReadOnly;
use Mouse;
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 20;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ eval {
+ has 'foo' => (
+ reader => 'get_foo'
+ );
+ };
+ ::ok(!$@, '... created the reader method okay');
+
+ eval {
+ has 'lazy_foo' => (
+ reader => 'get_lazy_foo',
+ lazy => 1,
+ default => sub { 10 }
+ );
+ };
+ ::ok(!$@, '... created the lazy reader method okay') or warn $@;
+
+ my $warn;
+
+ eval {
+ local $SIG{__WARN__} = sub { $warn = $_[0] };
+ has 'mtfnpy' => (
+ reder => 'get_mftnpy'
+ );
+ };
+ ::ok($warn, '... got a warning for mispelled attribute argument');
+}
+
+{
+ my $foo = Foo->new;
+ isa_ok($foo, 'Foo');
+
+ can_ok($foo, 'get_foo');
+ is($foo->get_foo(), undef, '... got an undefined value');
+ dies_ok {
+ $foo->get_foo(100);
+ } '... get_foo is a read-only';
+
+ ok(!exists($foo->{lazy_foo}), '... no value in get_lazy_foo slot');
+
+ can_ok($foo, 'get_lazy_foo');
+ is($foo->get_lazy_foo(), 10, '... got an deferred value');
+ dies_ok {
+ $foo->get_lazy_foo(100);
+ } '... get_lazy_foo is a read-only';
+}
+
+{
+ my $foo = Foo->new;
+ isa_ok($foo, 'Foo');
+
+ my $attr = $foo->meta->find_attribute_by_name("lazy_foo");
+
+ isa_ok( $attr, "Mouse::Meta::Attribute" );
+
+ ok( $attr->is_lazy, "it's lazy" );
+
+ is( $attr->get_raw_value($foo), undef, "raw value" );
+
+ is( $attr->get_value($foo), 10, "lazy value" );
+
+ is( $attr->get_raw_value($foo), 10, "raw value" );
+}
+
+{
+ my $foo = Foo->new(foo => 10, lazy_foo => 100);
+ isa_ok($foo, 'Foo');
+
+ is($foo->get_foo(), 10, '... got the correct value');
+ is($foo->get_lazy_foo(), 100, '... got the correct value');
+}
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Scalar::Util 'isweak';
+
+use Test::More tests => 43;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (is => 'rw',
+ isa => 'Maybe[Bar]',
+ trigger => sub {
+ my ($self, $bar) = @_;
+ $bar->foo($self) if defined $bar;
+ });
+
+ has 'baz' => (writer => 'set_baz',
+ reader => 'get_baz',
+ isa => 'Baz',
+ trigger => sub {
+ my ($self, $baz) = @_;
+ $baz->foo($self);
+ });
+
+
+ package Bar;
+ use Mouse;
+
+ has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
+
+ package Baz;
+ use Mouse;
+
+ has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
+}
+
+{
+ my $foo = Foo->new;
+ isa_ok($foo, 'Foo');
+
+ my $bar = Bar->new;
+ isa_ok($bar, 'Bar');
+
+ my $baz = Baz->new;
+ isa_ok($baz, 'Baz');
+
+ lives_ok {
+ $foo->bar($bar);
+ } '... did not die setting bar';
+
+ is($foo->bar, $bar, '... set the value foo.bar correctly');
+ is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
+
+ ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
+
+ lives_ok {
+ $foo->bar(undef);
+ } '... did not die un-setting bar';
+
+ is($foo->bar, undef, '... set the value foo.bar correctly');
+ is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
+
+ # test the writer
+
+ lives_ok {
+ $foo->set_baz($baz);
+ } '... did not die setting baz';
+
+ is($foo->get_baz, $baz, '... set the value foo.baz correctly');
+ is($baz->foo, $foo, '... which in turn set the value baz.foo correctly');
+
+ ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
+}
+
+{
+ my $bar = Bar->new;
+ isa_ok($bar, 'Bar');
+
+ my $baz = Baz->new;
+ isa_ok($baz, 'Baz');
+
+ my $foo = Foo->new(bar => $bar, baz => $baz);
+ isa_ok($foo, 'Foo');
+
+ is($foo->bar, $bar, '... set the value foo.bar correctly');
+ is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
+
+ ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
+
+ is($foo->get_baz, $baz, '... set the value foo.baz correctly');
+ is($baz->foo, $foo, '... which in turn set the value baz.foo correctly');
+
+ ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
+}
+
+# some errors
+
+{
+ package Bling;
+ use Mouse;
+
+ ::dies_ok {
+ has('bling' => (is => 'rw', trigger => 'Fail'));
+ } '... a trigger must be a CODE ref';
+
+ ::dies_ok {
+ has('bling' => (is => 'rw', trigger => []));
+ } '... a trigger must be a CODE ref';
+}
+
+# Triggers do not fire on built values
+
+{
+ package Blarg;
+ use Mouse;
+
+ our %trigger_calls;
+ our %trigger_vals;
+ has foo => (is => 'rw', default => sub { 'default foo value' },
+ trigger => sub { my ($self, $val, $attr) = @_;
+ $trigger_calls{foo}++;
+ $trigger_vals{foo} = $val });
+ has bar => (is => 'rw', lazy_build => 1,
+ trigger => sub { my ($self, $val, $attr) = @_;
+ $trigger_calls{bar}++;
+ $trigger_vals{bar} = $val });
+ sub _build_bar { return 'default bar value' }
+ has baz => (is => 'rw', builder => '_build_baz',
+ trigger => sub { my ($self, $val, $attr) = @_;
+ $trigger_calls{baz}++;
+ $trigger_vals{baz} = $val });
+ sub _build_baz { return 'default baz value' }
+}
+
+{
+ my $blarg;
+ lives_ok { $blarg = Blarg->new; } 'Blarg->new() lives';
+ ok($blarg, 'Have a $blarg');
+ foreach my $attr (qw/foo bar baz/) {
+ is($blarg->$attr(), "default $attr value", "$attr has default value");
+ }
+ is_deeply(\%Blarg::trigger_calls, {}, 'No triggers fired');
+ foreach my $attr (qw/foo bar baz/) {
+ $blarg->$attr("Different $attr value");
+ }
+ is_deeply(\%Blarg::trigger_calls, { map { $_ => 1 } qw/foo bar baz/ }, 'All triggers fired once on assign');
+ is_deeply(\%Blarg::trigger_vals, { map { $_ => "Different $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values');
+
+ lives_ok { $blarg => Blarg->new( map { $_ => "Yet another $_ value" } qw/foo bar baz/ ) } '->new() with parameters';
+ is_deeply(\%Blarg::trigger_calls, { map { $_ => 2 } qw/foo bar baz/ }, 'All triggers fired once on construct');
+ is_deeply(\%Blarg::trigger_vals, { map { $_ => "Yet another $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values');
+}
+
+# Triggers do not receive the meta-attribute as an argument, but do
+# receive the old value
+
+{
+ package Foo;
+ use Mouse;
+ our @calls;
+ has foo => (is => 'rw', trigger => sub { push @calls, [@_] });
+}
+
+{
+ my $attr = Foo->meta->get_attribute('foo');
+
+ my $foo = Foo->new;
+ $attr->set_value( $foo, 2 );
+
+ is_deeply(
+ \@Foo::calls,
+ [ [ $foo, 2 ] ],
+ 'trigger called correctly on initial set via meta-API',
+ );
+ @Foo::calls = ();
+
+ $attr->set_value( $foo, 3 );
+
+ is_deeply(
+ \@Foo::calls,
+ [ [ $foo, 3, 2 ] ],
+ 'trigger called correctly on second set via meta-API',
+ );
+ @Foo::calls = ();
+
+ $attr->set_raw_value( $foo, 4 );
+
+ is_deeply(
+ \@Foo::calls,
+ [ ],
+ 'trigger not called using set_raw_value method',
+ );
+ @Foo::calls = ();
+}
+
+{
+ my $foo = Foo->new(foo => 2);
+ is_deeply(
+ \@Foo::calls,
+ [ [ $foo, 2 ] ],
+ 'trigger called correctly on construction',
+ );
+ @Foo::calls = ();
+
+ $foo->foo(3);
+ is_deeply(
+ \@Foo::calls,
+ [ [ $foo, 3, 2 ] ],
+ 'trigger called correctly on set (with old value)',
+ );
+ @Foo::calls = ();
+ Foo->meta->make_immutable, redo if Foo->meta->is_mutable;
+}
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 84;
+use Test::Exception;
+
+
+
+{
+ package Thing;
+ use Mouse;
+
+ sub hello { 'Hello World (from Thing)' }
+ sub goodbye { 'Goodbye World (from Thing)' }
+
+ package Foo;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ subtype 'FooStr'
+ => as 'Str'
+ => where { /Foo/ };
+
+ coerce 'FooStr'
+ => from ArrayRef
+ => via { 'FooArrayRef' };
+
+ has 'bar' => (is => 'ro', isa => 'Str', default => 'Foo::bar');
+ has 'baz' => (is => 'rw', isa => 'Ref');
+ has 'foo' => (is => 'rw', isa => 'FooStr');
+
+ has 'gorch' => (is => 'ro');
+ has 'gloum' => (is => 'ro', default => sub {[]});
+ has 'fleem' => (is => 'ro');
+
+ has 'bling' => (is => 'ro', isa => 'Thing');
+ has 'blang' => (is => 'ro', isa => 'Thing', handles => ['goodbye']);
+
+ has 'bunch_of_stuff' => (is => 'rw', isa => 'ArrayRef');
+
+ has 'one_last_one' => (is => 'rw', isa => 'Ref');
+
+ # this one will work here ....
+ has 'fail' => (isa => 'CodeRef', is => 'bare');
+ has 'other_fail' => (is => 'bare');
+
+ package Bar;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ extends 'Foo';
+
+ ::lives_ok {
+ has '+bar' => (default => 'Bar::bar');
+ } '... we can change the default attribute option';
+
+ ::lives_ok {
+ has '+baz' => (isa => 'ArrayRef');
+ } '... we can add change the isa as long as it is a subtype';
+
+ ::lives_ok {
+ has '+foo' => (coerce => 1);
+ } '... we can change/add coerce as an attribute option';
+
+ ::lives_ok {
+ has '+gorch' => (required => 1);
+ } '... we can change/add required as an attribute option';
+
+ ::lives_ok {
+ has '+gloum' => (lazy => 1);
+ } '... we can change/add lazy as an attribute option';
+
+ ::lives_ok {
+ has '+gloum' => (lazy_build => 1);
+ } '... we can add lazy_build as an attribute option';
+
+ ::lives_ok {
+ has '+bunch_of_stuff' => (isa => 'ArrayRef[Int]');
+ } '... extend an attribute with parameterized type';
+
+ ::lives_ok {
+ has '+one_last_one' => (isa => subtype('Ref', where { blessed $_ eq 'CODE' }));
+ } '... extend an attribute with anon-subtype';
+
+ ::lives_ok {
+ has '+one_last_one' => (isa => 'Value');
+ } '... now can extend an attribute with a non-subtype';
+
+ ::lives_ok {
+ has '+fleem' => (weak_ref => 1);
+ } '... now allowed to add the weak_ref option via inheritance';
+
+ ::lives_ok {
+ has '+bling' => (handles => ['hello']);
+ } '... we can add the handles attribute option';
+
+ # this one will *not* work here ....
+ ::dies_ok {
+ has '+blang' => (handles => ['hello']);
+ } '... we can not alter the handles attribute option';
+ ::lives_ok {
+ has '+fail' => (isa => 'Ref');
+ } '... can now create an attribute with an improper subtype relation';
+ ::dies_ok {
+ has '+other_fail' => (trigger => sub {});
+ } '... cannot create an attribute with an illegal option';
+ ::throws_ok {
+ has '+does_not_exist' => (isa => 'Str');
+ } qr/in Bar/, '... cannot extend a non-existing attribute';
+}
+
+my $foo = Foo->new;
+isa_ok($foo, 'Foo');
+
+is($foo->foo, undef, '... got the right undef default value');
+lives_ok { $foo->foo('FooString') } '... assigned foo correctly';
+is($foo->foo, 'FooString', '... got the right value for foo');
+
+dies_ok { $foo->foo([]) } '... foo is not coercing (as expected)';
+
+is($foo->bar, 'Foo::bar', '... got the right default value');
+dies_ok { $foo->bar(10) } '... Foo::bar is a read/only attr';
+
+is($foo->baz, undef, '... got the right undef default value');
+
+{
+ my $hash_ref = {};
+ lives_ok { $foo->baz($hash_ref) } '... Foo::baz accepts hash refs';
+ is($foo->baz, $hash_ref, '... got the right value assigned to baz');
+
+ my $array_ref = [];
+ lives_ok { $foo->baz($array_ref) } '... Foo::baz accepts an array ref';
+ is($foo->baz, $array_ref, '... got the right value assigned to baz');
+
+ my $scalar_ref = \(my $var);
+ lives_ok { $foo->baz($scalar_ref) } '... Foo::baz accepts scalar ref';
+ is($foo->baz, $scalar_ref, '... got the right value assigned to baz');
+
+ lives_ok { $foo->bunch_of_stuff([qw[one two three]]) } '... Foo::bunch_of_stuff accepts an array of strings';
+
+ lives_ok { $foo->one_last_one(sub { 'Hello World'}) } '... Foo::one_last_one accepts a code ref';
+
+ my $code_ref = sub { 1 };
+ lives_ok { $foo->baz($code_ref) } '... Foo::baz accepts a code ref';
+ is($foo->baz, $code_ref, '... got the right value assigned to baz');
+}
+
+dies_ok {
+ Bar->new;
+} '... cannot create Bar without required gorch param';
+
+my $bar = Bar->new(gorch => 'Bar::gorch');
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
+
+is($bar->foo, undef, '... got the right undef default value');
+lives_ok { $bar->foo('FooString') } '... assigned foo correctly';
+is($bar->foo, 'FooString', '... got the right value for foo');
+lives_ok { $bar->foo([]) } '... assigned foo correctly';
+is($bar->foo, 'FooArrayRef', '... got the right value for foo');
+
+is($bar->gorch, 'Bar::gorch', '... got the right default value');
+
+is($bar->bar, 'Bar::bar', '... got the right default value');
+dies_ok { $bar->bar(10) } '... Bar::bar is a read/only attr';
+
+is($bar->baz, undef, '... got the right undef default value');
+
+{
+ my $hash_ref = {};
+ dies_ok { $bar->baz($hash_ref) } '... Bar::baz does not accept hash refs';
+
+ my $array_ref = [];
+ lives_ok { $bar->baz($array_ref) } '... Bar::baz can accept an array ref';
+ is($bar->baz, $array_ref, '... got the right value assigned to baz');
+
+ my $scalar_ref = \(my $var);
+ dies_ok { $bar->baz($scalar_ref) } '... Bar::baz does not accept a scalar ref';
+
+ lives_ok { $bar->bunch_of_stuff([1, 2, 3]) } '... Bar::bunch_of_stuff accepts an array of ints';
+ dies_ok { $bar->bunch_of_stuff([qw[one two three]]) } '... Bar::bunch_of_stuff does not accept an array of strings';
+
+ my $code_ref = sub { 1 };
+ dies_ok { $bar->baz($code_ref) } '... Bar::baz does not accept a code ref';
+}
+
+# check some meta-stuff
+
+ok(Bar->meta->has_attribute('foo'), '... Bar has a foo attr');
+ok(Bar->meta->has_attribute('bar'), '... Bar has a bar attr');
+ok(Bar->meta->has_attribute('baz'), '... Bar has a baz attr');
+ok(Bar->meta->has_attribute('gorch'), '... Bar has a gorch attr');
+ok(Bar->meta->has_attribute('gloum'), '... Bar has a gloum attr');
+ok(Bar->meta->has_attribute('bling'), '... Bar has a bling attr');
+ok(Bar->meta->has_attribute('bunch_of_stuff'), '... Bar does have a bunch_of_stuff attr');
+{
+local $TODO = 'not supported';
+ok(!Bar->meta->has_attribute('blang'), '... Bar does not have a blang attr');
+}
+ok(Bar->meta->has_attribute('fail'), '... Bar has a fail attr');
+{
+local $TODO = 'not supported';
+ok(!Bar->meta->has_attribute('other_fail'), '... Bar does not have an other_fail attr');
+}
+
+isnt(Foo->meta->get_attribute('foo'),
+ Bar->meta->get_attribute('foo'),
+ '... Foo and Bar have different copies of foo');
+isnt(Foo->meta->get_attribute('bar'),
+ Bar->meta->get_attribute('bar'),
+ '... Foo and Bar have different copies of bar');
+isnt(Foo->meta->get_attribute('baz'),
+ Bar->meta->get_attribute('baz'),
+ '... Foo and Bar have different copies of baz');
+isnt(Foo->meta->get_attribute('gorch'),
+ Bar->meta->get_attribute('gorch'),
+ '... Foo and Bar have different copies of gorch');
+isnt(Foo->meta->get_attribute('gloum'),
+ Bar->meta->get_attribute('gloum'),
+ '... Foo and Bar have different copies of gloum');
+isnt(Foo->meta->get_attribute('bling'),
+ Bar->meta->get_attribute('bling'),
+ '... Foo and Bar have different copies of bling');
+isnt(Foo->meta->get_attribute('bunch_of_stuff'),
+ Bar->meta->get_attribute('bunch_of_stuff'),
+ '... Foo and Bar have different copies of bunch_of_stuff');
+
+ok(Bar->meta->get_attribute('bar')->has_type_constraint,
+ '... Bar::bar inherited the type constraint too');
+ok(Bar->meta->get_attribute('baz')->has_type_constraint,
+ '... Bar::baz inherited the type constraint too');
+
+is(Bar->meta->get_attribute('bar')->type_constraint->name,
+ 'Str', '... Bar::bar inherited the right type constraint too');
+
+is(Foo->meta->get_attribute('baz')->type_constraint->name,
+ 'Ref', '... Foo::baz inherited the right type constraint too');
+is(Bar->meta->get_attribute('baz')->type_constraint->name,
+ 'ArrayRef', '... Bar::baz inherited the right type constraint too');
+
+ok(!Foo->meta->get_attribute('gorch')->is_required,
+ '... Foo::gorch is not a required attr');
+ok(Bar->meta->get_attribute('gorch')->is_required,
+ '... Bar::gorch is a required attr');
+
+is(Foo->meta->get_attribute('bunch_of_stuff')->type_constraint->name,
+ 'ArrayRef',
+ '... Foo::bunch_of_stuff is an ArrayRef');
+is(Bar->meta->get_attribute('bunch_of_stuff')->type_constraint->name,
+ 'ArrayRef[Int]',
+ '... Bar::bunch_of_stuff is an ArrayRef[Int]');
+
+ok(!Foo->meta->get_attribute('gloum')->is_lazy,
+ '... Foo::gloum is not a required attr');
+ok(Bar->meta->get_attribute('gloum')->is_lazy,
+ '... Bar::gloum is a required attr');
+
+ok(!Foo->meta->get_attribute('foo')->should_coerce,
+ '... Foo::foo should not coerce');
+ok(Bar->meta->get_attribute('foo')->should_coerce,
+ '... Bar::foo should coerce');
+
+ok(!Foo->meta->get_attribute('bling')->has_handles,
+ '... Foo::foo should not handles');
+ok(Bar->meta->get_attribute('bling')->has_handles,
+ '... Bar::foo should handles');
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 92;
+use Test::Exception;
+
+
+
+# -------------------------------------------------------------------
+# HASH handles
+# -------------------------------------------------------------------
+# the canonical form of of the 'handles'
+# option is the hash ref mapping a
+# method name to the delegated method name
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (is => 'rw', default => 10);
+
+ sub baz { 42 }
+
+ package Bar;
+ use Mouse;
+
+ has 'foo' => (
+ is => 'rw',
+ default => sub { Foo->new },
+ handles => {
+ 'foo_bar' => 'bar',
+ foo_baz => 'baz',
+ 'foo_bar_to_20' => [ bar => 20 ],
+ },
+ );
+}
+
+my $bar = Bar->new;
+isa_ok($bar, 'Bar');
+
+ok($bar->foo, '... we have something in bar->foo');
+isa_ok($bar->foo, 'Foo');
+
+my $meth = Bar->meta->get_method('foo_bar');
+isa_ok($meth, 'Mouse::Meta::Method::Delegation');
+is($meth->associated_attribute->name, 'foo',
+ 'associated_attribute->name for this method is foo');
+
+is($bar->foo->bar, 10, '... bar->foo->bar returned the right default');
+
+can_ok($bar, 'foo_bar');
+is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly');
+
+# change the value ...
+
+$bar->foo->bar(30);
+
+# and make sure the delegation picks it up
+
+is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
+is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
+
+# change the value through the delegation ...
+
+$bar->foo_bar(50);
+
+# and make sure everyone sees it
+
+is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
+is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
+
+# change the object we are delegating too
+
+my $foo = Foo->new(bar => 25);
+isa_ok($foo, 'Foo');
+
+is($foo->bar, 25, '... got the right foo->bar');
+
+lives_ok {
+ $bar->foo($foo);
+} '... assigned the new Foo to Bar->foo';
+
+is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
+
+is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
+is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
+
+# curried handles
+$bar->foo_bar_to_20;
+is($bar->foo_bar, 20, '... correctly curried a single argument');
+
+# -------------------------------------------------------------------
+# ARRAY handles
+# -------------------------------------------------------------------
+# we also support an array based format
+# which assumes that the name is the same
+# on either end
+
+{
+ package Engine;
+ use Mouse;
+
+ sub go { 'Engine::go' }
+ sub stop { 'Engine::stop' }
+
+ package Car;
+ use Mouse;
+
+ has 'engine' => (
+ is => 'rw',
+ default => sub { Engine->new },
+ handles => [ 'go', 'stop' ]
+ );
+}
+
+my $car = Car->new;
+isa_ok($car, 'Car');
+
+isa_ok($car->engine, 'Engine');
+can_ok($car->engine, 'go');
+can_ok($car->engine, 'stop');
+
+is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go');
+is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop');
+
+can_ok($car, 'go');
+can_ok($car, 'stop');
+
+is($car->go, 'Engine::go', '... got the right value from ->go');
+is($car->stop, 'Engine::stop', '... got the right value from ->stop');
+
+# -------------------------------------------------------------------
+# REGEXP handles
+# -------------------------------------------------------------------
+# and we support regexp delegation
+
+{
+ package Baz;
+ use Mouse;
+
+ sub foo { 'Baz::foo' }
+ sub bar { 'Baz::bar' }
+ sub boo { 'Baz::boo' }
+
+ package Baz::Proxy1;
+ use Mouse;
+
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Baz',
+ default => sub { Baz->new },
+ handles => qr/.*/
+ );
+
+ package Baz::Proxy2;
+ use Mouse;
+
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Baz',
+ default => sub { Baz->new },
+ handles => qr/.oo/
+ );
+
+ package Baz::Proxy3;
+ use Mouse;
+
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Baz',
+ default => sub { Baz->new },
+ handles => qr/b.*/
+ );
+}
+
+{
+ my $baz_proxy = Baz::Proxy1->new;
+ isa_ok($baz_proxy, 'Baz::Proxy1');
+
+ can_ok($baz_proxy, 'baz');
+ isa_ok($baz_proxy->baz, 'Baz');
+
+ can_ok($baz_proxy, 'foo');
+ can_ok($baz_proxy, 'bar');
+ can_ok($baz_proxy, 'boo');
+
+ is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
+ is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
+}
+{
+ my $baz_proxy = Baz::Proxy2->new;
+ isa_ok($baz_proxy, 'Baz::Proxy2');
+
+ can_ok($baz_proxy, 'baz');
+ isa_ok($baz_proxy->baz, 'Baz');
+
+ can_ok($baz_proxy, 'foo');
+ can_ok($baz_proxy, 'boo');
+
+ is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
+}
+{
+ my $baz_proxy = Baz::Proxy3->new;
+ isa_ok($baz_proxy, 'Baz::Proxy3');
+
+ can_ok($baz_proxy, 'baz');
+ isa_ok($baz_proxy->baz, 'Baz');
+
+ can_ok($baz_proxy, 'bar');
+ can_ok($baz_proxy, 'boo');
+
+ is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value');
+ is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value');
+}
+
+# -------------------------------------------------------------------
+# ROLE handles
+# -------------------------------------------------------------------
+
+{
+ package Foo::Bar;
+ use Mouse::Role;
+
+ requires 'foo';
+ requires 'bar';
+
+ package Foo::Baz;
+ use Mouse;
+
+ sub foo { 'Foo::Baz::FOO' }
+ sub bar { 'Foo::Baz::BAR' }
+ sub baz { 'Foo::Baz::BAZ' }
+
+ package Foo::Thing;
+ use Mouse;
+
+ has 'thing' => (
+ is => 'rw',
+ isa => 'Foo::Baz',
+ handles => 'Foo::Bar',
+ );
+
+}
+
+{
+ my $foo = Foo::Thing->new(thing => Foo::Baz->new);
+ isa_ok($foo, 'Foo::Thing');
+ isa_ok($foo->thing, 'Foo::Baz');
+
+ ok($foo->meta->has_method('foo'), '... we have the method we expect');
+ ok($foo->meta->has_method('bar'), '... we have the method we expect');
+ ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect');
+
+ is($foo->foo, 'Foo::Baz::FOO', '... got the right value');
+ is($foo->bar, 'Foo::Baz::BAR', '... got the right value');
+ is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
+}
+
+# -------------------------------------------------------------------
+# AUTOLOAD & handles
+# -------------------------------------------------------------------
+
+{
+ package Foo::Autoloaded;
+ use Mouse;
+
+ sub AUTOLOAD {
+ my $self = shift;
+
+ my $name = our $AUTOLOAD;
+ $name =~ s/.*://; # strip fully-qualified portion
+
+ if (@_) {
+ return $self->{$name} = shift;
+ } else {
+ return $self->{$name};
+ }
+ }
+
+ package Bar::Autoloaded;
+ use Mouse;
+
+ has 'foo' => (
+ is => 'rw',
+ default => sub { Foo::Autoloaded->new },
+ handles => { 'foo_bar' => 'bar' }
+ );
+
+ package Baz::Autoloaded;
+ use Mouse;
+
+ has 'foo' => (
+ is => 'rw',
+ default => sub { Foo::Autoloaded->new },
+ handles => ['bar']
+ );
+
+ package Goorch::Autoloaded;
+ use Mouse;
+
+ ::dies_ok {
+ has 'foo' => (
+ is => 'rw',
+ default => sub { Foo::Autoloaded->new },
+ handles => qr/bar/
+ );
+ } '... you cannot delegate to AUTOLOADED class with regexp';
+}
+
+# check HASH based delegation w/ AUTOLOAD
+
+{
+ my $bar = Bar::Autoloaded->new;
+ isa_ok($bar, 'Bar::Autoloaded');
+
+ ok($bar->foo, '... we have something in bar->foo');
+ isa_ok($bar->foo, 'Foo::Autoloaded');
+
+ # change the value ...
+
+ $bar->foo->bar(30);
+
+ # and make sure the delegation picks it up
+
+ is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value');
+ is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly');
+
+ # change the value through the delegation ...
+
+ $bar->foo_bar(50);
+
+ # and make sure everyone sees it
+
+ is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value');
+ is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly');
+
+ # change the object we are delegating too
+
+ my $foo = Foo::Autoloaded->new;
+ isa_ok($foo, 'Foo::Autoloaded');
+
+ $foo->bar(25);
+
+ is($foo->bar, 25, '... got the right foo->bar');
+
+ lives_ok {
+ $bar->foo($foo);
+ } '... assigned the new Foo to Bar->foo';
+
+ is($bar->foo, $foo, '... assigned bar->foo with the new Foo');
+
+ is($bar->foo->bar, 25, '... bar->foo->bar returned the right result');
+ is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again');
+}
+
+# check ARRAY based delegation w/ AUTOLOAD
+
+{
+ my $baz = Baz::Autoloaded->new;
+ isa_ok($baz, 'Baz::Autoloaded');
+
+ ok($baz->foo, '... we have something in baz->foo');
+ isa_ok($baz->foo, 'Foo::Autoloaded');
+
+ # change the value ...
+
+ $baz->foo->bar(30);
+
+ # and make sure the delegation picks it up
+
+ is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value');
+ is($baz->bar, 30, '... baz->foo_bar delegated correctly');
+
+ # change the value through the delegation ...
+
+ $baz->bar(50);
+
+ # and make sure everyone sees it
+
+ is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value');
+ is($baz->bar, 50, '... baz->foo_bar delegated correctly');
+
+ # change the object we are delegating too
+
+ my $foo = Foo::Autoloaded->new;
+ isa_ok($foo, 'Foo::Autoloaded');
+
+ $foo->bar(25);
+
+ is($foo->bar, 25, '... got the right foo->bar');
+
+ lives_ok {
+ $baz->foo($foo);
+ } '... assigned the new Foo to Baz->foo';
+
+ is($baz->foo, $foo, '... assigned baz->foo with the new Foo');
+
+ is($baz->foo->bar, 25, '... baz->foo->bar returned the right result');
+ is($baz->bar, 25, '... and baz->foo_bar delegated correctly again');
+}
+
+# Check that removing attributes removes their handles methods also.
+{
+ {
+ package Quux;
+ use Mouse;
+ has foo => (
+ isa => 'Foo',
+ default => sub { Foo->new },
+ handles => { 'foo_bar' => 'bar' }
+ );
+ }
+ my $i = Quux->new;
+ ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present');
+ $i->meta->remove_attribute('foo');
+ ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed');
+}
+
+# Make sure that a useful error message is thrown when the delegation target is
+# not an object
+{
+ my $i = Bar->new(foo => undef);
+ throws_ok { $i->foo_bar } qr/is not defined/,
+ 'useful error from unblessed reference';
+
+ my $j = Bar->new(foo => []);
+ throws_ok { $j->foo_bar } qr/is not an object \(got 'ARRAY/,
+ 'useful error from unblessed reference';
+
+ my $k = Bar->new(foo => "Foo");
+ lives_ok { $k->foo_baz } "but not for class name";
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 39;
+use Test::Exception;
+
+=pod
+
+This tests the more complex
+delegation cases and that they
+do not fail at compile time.
+
+=cut
+
+{
+
+ package ChildASuper;
+ use Mouse;
+
+ sub child_a_super_method { "as" }
+
+ package ChildA;
+ use Mouse;
+
+ extends "ChildASuper";
+
+ sub child_a_method_1 { "a1" }
+ sub child_a_method_2 { Scalar::Util::blessed($_[0]) . " a2" }
+
+ package ChildASub;
+ use Mouse;
+
+ extends "ChildA";
+
+ sub child_a_method_3 { "a3" }
+
+ package ChildB;
+ use Mouse;
+
+ sub child_b_method_1 { "b1" }
+ sub child_b_method_2 { "b2" }
+ sub child_b_method_3 { "b3" }
+
+ package ChildC;
+ use Mouse;
+
+ sub child_c_method_1 { "c1" }
+ sub child_c_method_2 { "c2" }
+ sub child_c_method_3_la { "c3" }
+ sub child_c_method_4_la { "c4" }
+
+ package ChildD;
+ use Mouse;
+
+ sub child_d_method_1 { "d1" }
+ sub child_d_method_2 { "d2" }
+
+ package ChildE;
+ # no Mouse
+
+ sub new { bless {}, shift }
+ sub child_e_method_1 { "e1" }
+ sub child_e_method_2 { "e2" }
+
+ package ChildF;
+ # no Mouse
+
+ sub new { bless {}, shift }
+ sub child_f_method_1 { "f1" }
+ sub child_f_method_2 { "f2" }
+
+ package ChildG;
+ use Mouse;
+
+ sub child_g_method_1 { "g1" }
+
+ package Parent;
+ use Mouse;
+
+ ::dies_ok {
+ has child_a => (
+ is => "ro",
+ default => sub { ChildA->new },
+ handles => qr/.*/,
+ );
+ } "all_methods requires explicit isa";
+
+ ::lives_ok {
+ has child_a => (
+ isa => "ChildA",
+ is => "ro",
+ default => sub { ChildA->new },
+ handles => qr/.*/,
+ );
+ } "allow all_methods with explicit isa";
+
+ ::lives_ok {
+ has child_b => (
+ is => 'ro',
+ default => sub { ChildB->new },
+ handles => [qw/child_b_method_1/],
+ );
+ } "don't need to declare isa if method list is predefined";
+
+ ::lives_ok {
+ has child_c => (
+ isa => "ChildC",
+ is => "ro",
+ default => sub { ChildC->new },
+ handles => qr/_la$/,
+ );
+ } "can declare regex collector";
+
+ ::dies_ok {
+ has child_d => (
+ is => "ro",
+ default => sub { ChildD->new },
+ handles => sub {
+ my ( $class, $delegate_class ) = @_;
+ }
+ );
+ } "can't create attr with generative handles parameter and no isa";
+
+ ::lives_ok {
+ has child_d => (
+ isa => "ChildD",
+ is => "ro",
+ default => sub { ChildD->new },
+ handles => sub {
+ my ( $class, $delegate_class ) = @_;
+ return;
+ }
+ );
+ } "can't create attr with generative handles parameter and no isa";
+
+ ::lives_ok {
+ has child_e => (
+ isa => "ChildE",
+ is => "ro",
+ default => sub { ChildE->new },
+ handles => ["child_e_method_2"],
+ );
+ } "can delegate to non moose class using explicit method list";
+
+ my $delegate_class;
+ ::lives_ok {
+ has child_f => (
+ isa => "ChildF",
+ is => "ro",
+ default => sub { ChildF->new },
+ handles => sub {
+ $delegate_class = $_[1]->name;
+ return;
+ },
+ );
+ } "subrefs on non moose class give no meta";
+
+ ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" );
+
+ ::lives_ok {
+ has child_g => (
+ isa => "ChildG",
+ default => sub { ChildG->new },
+ handles => ["child_g_method_1"],
+ );
+ } "can delegate to object even without explicit reader";
+
+ sub parent_method { "p" }
+}
+
+# sanity
+
+isa_ok( my $p = Parent->new, "Parent" );
+isa_ok( $p->child_a, "ChildA" );
+isa_ok( $p->child_b, "ChildB" );
+isa_ok( $p->child_c, "ChildC" );
+isa_ok( $p->child_d, "ChildD" );
+isa_ok( $p->child_e, "ChildE" );
+isa_ok( $p->child_f, "ChildF" );
+
+ok(!$p->can('child_g'), '... no child_g accessor defined');
+
+
+is( $p->parent_method, "p", "parent method" );
+is( $p->child_a->child_a_super_method, "as", "child supermethod" );
+is( $p->child_a->child_a_method_1, "a1", "child method" );
+
+can_ok( $p, "child_a_super_method" );
+can_ok( $p, "child_a_method_1" );
+can_ok( $p, "child_a_method_2" );
+ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" );
+
+is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" );
+is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" );
+
+
+can_ok( $p, "child_b_method_1" );
+ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" );
+
+
+ok( !$p->can($_), "none of ChildD's methods ($_)" )
+ for grep { /^child/ } map { $_->name } ChildD->meta->get_all_methods();
+
+can_ok( $p, "child_c_method_3_la" );
+can_ok( $p, "child_c_method_4_la" );
+
+is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" );
+
+can_ok( $p, "child_e_method_2" );
+ok( !$p->can("child_e_method_1"), "but not child_e_method_1");
+
+is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" );
+
+can_ok( $p, "child_g_method_1" );
+is( $p->child_g_method_1, "g1", "delegate to moose class without reader (child_g_method_1)" );
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 43;
+use Test::Exception;
+
+use lib 't/lib';
+use Test::Mouse;
+
+{
+ {
+ package Test::Attribute::Inline::Documentation;
+ use Mouse;
+
+ has 'foo' => (
+ documentation => q{
+ The 'foo' attribute is my favorite
+ attribute in the whole wide world.
+ },
+ is => 'bare',
+ );
+ }
+
+ my $foo_attr = Test::Attribute::Inline::Documentation->meta->get_attribute('foo');
+
+ ok($foo_attr->has_documentation, '... the foo has docs');
+ is($foo_attr->documentation,
+ q{
+ The 'foo' attribute is my favorite
+ attribute in the whole wide world.
+ },
+ '... got the foo docs');
+}
+
+{
+ {
+ package Test::For::Lazy::TypeConstraint;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ has 'bad_lazy_attr' => (
+ is => 'rw',
+ isa => 'ArrayRef',
+ lazy => 1,
+ default => sub { "test" },
+ );
+
+ has 'good_lazy_attr' => (
+ is => 'rw',
+ isa => 'ArrayRef',
+ lazy => 1,
+ default => sub { [] },
+ );
+
+ }
+
+ my $test = Test::For::Lazy::TypeConstraint->new;
+ isa_ok($test, 'Test::For::Lazy::TypeConstraint');
+
+ dies_ok {
+ $test->bad_lazy_attr;
+ } '... this does not work';
+
+ lives_ok {
+ $test->good_lazy_attr;
+ } '... this does work';
+}
+
+{
+ {
+ package Test::Arrayref::Attributes;
+ use Mouse;
+
+ has [qw(foo bar baz)] => (
+ is => 'rw',
+ );
+
+ }
+
+ my $test = Test::Arrayref::Attributes->new;
+ isa_ok($test, 'Test::Arrayref::Attributes');
+ can_ok($test, qw(foo bar baz));
+
+}
+
+{
+ {
+ package Test::Arrayref::RoleAttributes::Role;
+ use Mouse::Role;
+
+ has [qw(foo bar baz)] => (
+ is => 'rw',
+ );
+
+ }
+ {
+ package Test::Arrayref::RoleAttributes;
+ use Mouse;
+ with 'Test::Arrayref::RoleAttributes::Role';
+ }
+
+ my $test = Test::Arrayref::RoleAttributes->new;
+ isa_ok($test, 'Test::Arrayref::RoleAttributes');
+ can_ok($test, qw(foo bar baz));
+
+}
+
+{
+ {
+ package Test::UndefDefault::Attributes;
+ use Mouse;
+
+ has 'foo' => (
+ is => 'ro',
+ isa => 'Str',
+ default => sub { return }
+ );
+
+ }
+
+ dies_ok {
+ Test::UndefDefault::Attributes->new;
+ } '... default must return a value which passes the type constraint';
+
+}
+
+{
+ {
+ package OverloadedStr;
+ use Mouse;
+ use overload '""' => sub { 'this is *not* a string' };
+
+ has 'a_str' => ( isa => 'Str' , is => 'rw' );
+ }
+
+ my $moose_obj = OverloadedStr->new;
+
+ is($moose_obj->a_str( 'foobar' ), 'foobar', 'setter took string');
+ ok($moose_obj, 'this is a *not* a string');
+
+ throws_ok {
+ $moose_obj->a_str( $moose_obj )
+ } qr/Attribute \(a_str\) does not pass the type constraint because\: Validation failed for 'Str' failed with value OverloadedStr=HASH\(0x.+?\)/,
+ '... dies without overloading the string';
+
+}
+
+{
+ {
+ package OverloadBreaker;
+ use Mouse;
+
+ has 'a_num' => ( isa => 'Int' , is => 'rw', default => 7.5 );
+ }
+
+ throws_ok {
+ OverloadBreaker->new;
+ } qr/Attribute \(a_num\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 7\.5/,
+ '... this doesnt trip overload to break anymore ';
+
+ lives_ok {
+ OverloadBreaker->new(a_num => 5);
+ } '... this works fine though';
+
+}
+
+{
+ {
+ package Test::Builder::Attribute;
+ use Mouse;
+
+ has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro');
+ sub build_foo { return "works" };
+ }
+
+ my $meta = Test::Builder::Attribute->meta;
+ my $foo_attr = $meta->get_attribute("foo");
+
+ ok($foo_attr->is_required, "foo is required");
+ ok($foo_attr->has_builder, "foo has builder");
+ is($foo_attr->builder, "build_foo", ".. and it's named build_foo");
+
+ my $instance = Test::Builder::Attribute->new;
+ is($instance->foo, 'works', "foo builder works");
+}
+
+{
+ {
+ package Test::Builder::Attribute::Broken;
+ use Mouse;
+
+ has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro');
+ }
+
+ dies_ok {
+ Test::Builder::Attribute::Broken->new;
+ } '... no builder, wtf';
+}
+
+
+{
+ {
+ package Test::LazyBuild::Attribute;
+ use Mouse;
+
+ has 'foo' => ( lazy_build => 1, is => 'ro');
+ has '_foo' => ( lazy_build => 1, is => 'ro');
+ has 'fool' => ( lazy_build => 1, is => 'ro');
+ sub _build_foo { return "works" };
+ sub _build__foo { return "works too" };
+ }
+
+ my $meta = Test::LazyBuild::Attribute->meta;
+ my $foo_attr = $meta->get_attribute("foo");
+ my $_foo_attr = $meta->get_attribute("_foo");
+
+ ok($foo_attr->is_lazy, "foo is lazy");
+ ok($foo_attr->is_lazy_build, "foo is lazy_build");
+
+ ok($foo_attr->has_clearer, "foo has clearer");
+ is($foo_attr->clearer, "clear_foo", ".. and it's named clear_foo");
+
+ ok($foo_attr->has_builder, "foo has builder");
+ is($foo_attr->builder, "_build_foo", ".. and it's named build_foo");
+
+ ok($foo_attr->has_predicate, "foo has predicate");
+ is($foo_attr->predicate, "has_foo", ".. and it's named has_foo");
+
+ ok($_foo_attr->is_lazy, "_foo is lazy");
+ ok(!$_foo_attr->is_required, "lazy_build attributes are no longer automatically required");
+ ok($_foo_attr->is_lazy_build, "_foo is lazy_build");
+
+ ok($_foo_attr->has_clearer, "_foo has clearer");
+ is($_foo_attr->clearer, "_clear_foo", ".. and it's named _clear_foo");
+
+ ok($_foo_attr->has_builder, "_foo has builder");
+ is($_foo_attr->builder, "_build__foo", ".. and it's named _build_foo");
+
+ ok($_foo_attr->has_predicate, "_foo has predicate");
+ is($_foo_attr->predicate, "_has_foo", ".. and it's named _has_foo");
+
+ my $instance = Test::LazyBuild::Attribute->new;
+ ok(!$instance->has_foo, "noo foo value yet");
+ ok(!$instance->_has_foo, "noo _foo value yet");
+ is($instance->foo, 'works', "foo builder works");
+ is($instance->_foo, 'works too', "foo builder works too");
+ dies_ok { $instance->fool }
+# throws_ok { $instance->fool }
+# qr/Test::LazyBuild::Attribute does not support builder method \'_build_fool\' for attribute \'fool\'/,
+ "Correct error when a builder method is not present";
+
+}
+
+{
+ package OutOfClassTest;
+
+ use Mouse;
+}
+
+# Mouse::Exporter does not support 'with_meta'
+#lives_ok { OutOfClassTest::has('foo', is => 'bare'); } 'create attr via direct sub call';
+#lives_ok { OutOfClassTest->can('has')->('bar', is => 'bare'); } 'create attr via can';
+
+#ok(OutOfClassTest->meta->get_attribute('foo'), 'attr created from sub call');
+#ok(OutOfClassTest->meta->get_attribute('bar'), 'attr created from can');
+
+
+{
+ {
+ package Foo;
+ use Mouse;
+
+ ::throws_ok { has 'foo' => ( 'ro', isa => 'Str' ) }
+ qr/^Usage/, 'has throws error with odd number of attribute options';
+ }
+
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 11;
+use Test::Exception;
+
+
+
+{
+ package Customer;
+ use Mouse;
+
+ package Firm;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ ::lives_ok {
+ has 'customers' => (
+ is => 'ro',
+ isa => subtype('ArrayRef' => where {
+ (blessed($_) && $_->isa('Customer') || return) for @$_; 1 }),
+ auto_deref => 1,
+ );
+ } '... successfully created attr';
+}
+
+{
+ my $customer = Customer->new;
+ isa_ok($customer, 'Customer');
+
+ my $firm = Firm->new(customers => [ $customer ]);
+ isa_ok($firm, 'Firm');
+
+ can_ok($firm, 'customers');
+
+ is_deeply(
+ [ $firm->customers ],
+ [ $customer ],
+ '... got the right dereferenced value'
+ );
+}
+
+{
+ my $firm = Firm->new();
+ isa_ok($firm, 'Firm');
+
+ can_ok($firm, 'customers');
+
+ is_deeply(
+ [ $firm->customers ],
+ [],
+ '... got the right dereferenced value'
+ );
+}
+
+{
+ package AutoDeref;
+ use Mouse;
+
+ has 'bar' => (
+ is => 'rw',
+ isa => 'ArrayRef[Int]',
+ auto_deref => 1,
+ );
+}
+
+{
+ my $autoderef = AutoDeref->new;
+
+ dies_ok {
+ $autoderef->bar(1, 2, 3);
+ } '... its auto-de-ref-ing, not auto-en-ref-ing';
+
+ lives_ok {
+ $autoderef->bar([ 1, 2, 3 ])
+ } '... set the results of bar correctly';
+
+ is_deeply [ $autoderef->bar ], [ 1, 2, 3 ], '... auto-dereffed correctly';
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use Test::Exception;
+
+
+
+{
+ package HTTPHeader;
+ use Mouse;
+
+ has 'array' => (is => 'ro');
+ has 'hash' => (is => 'ro');
+}
+
+{
+ package Request;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ subtype Header =>
+ => as Object
+ => where { $_->isa('HTTPHeader') };
+
+ coerce Header
+ => from ArrayRef
+ => via { HTTPHeader->new(array => $_[0]) }
+ => from HashRef
+ => via { HTTPHeader->new(hash => $_[0]) };
+
+ has 'headers' => (
+ is => 'rw',
+ isa => 'Header',
+ coerce => 1,
+ lazy => 1,
+ default => sub { [ 'content-type', 'text/html' ] }
+ );
+}
+
+my $r = Request->new;
+isa_ok($r, 'Request');
+
+lives_ok {
+ $r->headers;
+} '... this coerces and passes the type constraint even with lazy';
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ eval {
+ has 'foo' => (
+ is => "rw",
+ init_arg => undef,
+ );
+ };
+ ::ok(!$@, '... created the attr okay');
+}
+
+{
+ my $foo = Foo->new( foo => "bar" );
+ isa_ok($foo, 'Foo');
+
+ is( $foo->foo, undef, "field is not set via init arg" );
+
+ $foo->foo("blah");
+
+ is( $foo->foo, "blah", "field is set via setter" );
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 23;
+use Test::Exception;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'foo' => (
+ reader => 'get_foo',
+ writer => 'set_foo',
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'foo', '... got the right name');
+
+ $callback->($value * 2);
+ },
+ );
+
+ has 'lazy_foo' => (
+ reader => 'get_lazy_foo',
+ lazy => 1,
+ default => 10,
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'lazy_foo', '... got the right name');
+
+ $callback->($value * 2);
+ },
+ );
+
+ has 'lazy_foo_w_type' => (
+ reader => 'get_lazy_foo_w_type',
+ isa => 'Int',
+ lazy => 1,
+ default => 20,
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'lazy_foo_w_type', '... got the right name');
+
+ $callback->($value * 2);
+ },
+ );
+
+ has 'lazy_foo_builder' => (
+ reader => 'get_lazy_foo_builder',
+ builder => 'get_foo_builder',
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'lazy_foo_builder', '... got the right name');
+
+ $callback->($value * 2);
+ },
+ );
+
+ has 'lazy_foo_builder_w_type' => (
+ reader => 'get_lazy_foo_builder_w_type',
+ isa => 'Int',
+ builder => 'get_foo_builder_w_type',
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'lazy_foo_builder_w_type', '... got the right name');
+
+ $callback->($value * 2);
+ },
+ );
+
+ sub get_foo_builder { 100 }
+ sub get_foo_builder_w_type { 1000 }
+}
+
+{
+ my $foo = Foo->new(foo => 10);
+ isa_ok($foo, 'Foo');
+
+ is($foo->get_foo, 20, 'initial value set to 2x given value');
+ is($foo->get_lazy_foo, 20, 'initial lazy value set to 2x given value');
+ is($foo->get_lazy_foo_w_type, 40, 'initial lazy value with type set to 2x given value');
+ is($foo->get_lazy_foo_builder, 200, 'initial lazy value with builder set to 2x given value');
+ is($foo->get_lazy_foo_builder_w_type, 2000, 'initial lazy value with builder and type set to 2x given value');
+}
+
+{
+ package Bar;
+ use Mouse;
+
+ has 'foo' => (
+ reader => 'get_foo',
+ writer => 'set_foo',
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'foo', '... got the right name');
+
+ $callback->($value * 2);
+ },
+ );
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+{
+ my $bar = Bar->new(foo => 10);
+ isa_ok($bar, 'Bar');
+
+ is($bar->get_foo, 20, 'initial value set to 2x given value');
+}
+
+{
+ package Fail::Bar;
+ use Mouse;
+
+ has 'foo' => (
+ reader => 'get_foo',
+ writer => 'set_foo',
+ isa => 'Int',
+ initializer => sub {
+ my ($self, $value, $callback, $attr) = @_;
+
+ ::isa_ok($attr, 'Mouse::Meta::Attribute');
+ ::is($attr->name, 'foo', '... got the right name');
+
+ $callback->("Hello $value World");
+ },
+ );
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+dies_ok {
+ Fail::Bar->new(foo => 10)
+} '... this fails, because initializer returns a bad type';
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 11;
+use Test::Exception;
+
+
+
+{
+
+ package Fake::DateTime;
+ use Mouse;
+
+ has 'string_repr' => ( is => 'ro' );
+
+ package Mortgage;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ coerce 'Fake::DateTime' => from 'Str' =>
+ via { Fake::DateTime->new( string_repr => $_ ) };
+
+ has 'closing_date' => (
+ is => 'rw',
+ isa => 'Fake::DateTime',
+ coerce => 1,
+ trigger => sub {
+ my ( $self, $val ) = @_;
+ ::pass('... trigger is being called');
+ ::isa_ok( $self->closing_date, 'Fake::DateTime' );
+ ::isa_ok( $val, 'Fake::DateTime' );
+ }
+ );
+}
+
+{
+ my $mtg = Mortgage->new( closing_date => 'yesterday' );
+ isa_ok( $mtg, 'Mortgage' );
+
+ # check that coercion worked
+ isa_ok( $mtg->closing_date, 'Fake::DateTime' );
+}
+
+Mortgage->meta->make_immutable;
+ok( Mortgage->meta->is_immutable, '... Mortgage is now immutable' );
+
+{
+ my $mtg = Mortgage->new( closing_date => 'yesterday' );
+ isa_ok( $mtg, 'Mortgage' );
+
+ # check that coercion worked
+ isa_ok( $mtg->closing_date, 'Fake::DateTime' );
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 17;
+use Test::Exception;
+
+
+
+=pod
+
+ is => rw, writer => _foo # turns into (reader => foo, writer => _foo)
+ is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before
+ is => rw, accessor => _foo # turns into (accessor => _foo)
+ is => ro, accessor => _foo # error, accesor is rw
+
+=cut
+
+sub make_class {
+ my ($is, $attr, $class) = @_;
+
+ eval "package $class; use Mouse; has 'foo' => ( is => '$is', $attr => '_foo' );";
+
+ return $@ ? die $@ : $class;
+}
+
+my $obj;
+my $class;
+
+$class = make_class('rw', 'writer', 'Test::Class::WriterRW');
+ok($class, "Can define attr with rw + writer");
+
+$obj = $class->new();
+
+can_ok($obj, qw/foo _foo/);
+lives_ok {$obj->_foo(1)} "$class->_foo is writer";
+is($obj->foo(), 1, "$class->foo is reader");
+dies_ok {$obj->foo(2)} "$class->foo is not writer"; # this should fail
+ok(!defined $obj->_foo(), "$class->_foo is not reader");
+
+$class = make_class('ro', 'writer', 'Test::Class::WriterRO');
+ok($class, "Can define attr with ro + writer");
+
+$obj = $class->new();
+
+can_ok($obj, qw/foo _foo/);
+lives_ok {$obj->_foo(1)} "$class->_foo is writer";
+is($obj->foo(), 1, "$class->foo is reader");
+dies_ok {$obj->foo(1)} "$class->foo is not writer";
+isnt($obj->_foo(), 1, "$class->_foo is not reader");
+
+$class = make_class('rw', 'accessor', 'Test::Class::AccessorRW');
+ok($class, "Can define attr with rw + accessor");
+
+$obj = $class->new();
+
+can_ok($obj, qw/_foo/);
+lives_ok {$obj->_foo(1)} "$class->_foo is writer";
+is($obj->_foo(), 1, "$class->foo is reader");
+
+dies_ok { make_class('ro', 'accessor', "Test::Class::AccessorRO"); } "Cant define attr with ro + accessor";
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+
+
+{
+ package Bar::Meta::Attribute;
+ use Mouse;
+
+ extends 'Mouse::Meta::Attribute';
+
+ has 'my_legal_option' => (
+ isa => 'CodeRef',
+ is => 'rw',
+ );
+
+ around legal_options_for_inheritance => sub {
+ return (shift->(@_), qw/my_legal_option/);
+ };
+
+ package Bar;
+ use Mouse;
+
+ has 'bar' => (
+ metaclass => 'Bar::Meta::Attribute',
+ my_legal_option => sub { 'Bar' },
+ is => 'bare',
+ );
+
+ package Bar::B;
+ use Mouse;
+
+ extends 'Bar';
+
+ has '+bar' => (
+ my_legal_option => sub { 'Bar::B' }
+ );
+}
+
+my $bar_attr = Bar::B->meta->get_attribute('bar');
+my ($legal_option) = grep {
+ $_ eq 'my_legal_option'
+} $bar_attr->legal_options_for_inheritance;
+is($legal_option, 'my_legal_option',
+ '... added my_legal_option as legal option for inheritance' );
+is($bar_attr->my_legal_option->(), 'Bar::B', '... overloaded my_legal_option');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 8;
+use Test::Exception;
+
+my $exception_regex = qr/You must provide a name for the attribute/;
+{
+ package My::Role;
+ use Mouse::Role;
+
+ ::throws_ok {
+ has;
+ } $exception_regex, 'has; fails';
+
+ ::throws_ok {
+ has undef;
+ } $exception_regex, 'has undef; fails';
+
+ ::lives_ok {
+ has "" => (
+ is => 'bare',
+ );
+ } 'has ""; works now';
+
+ ::lives_ok {
+ has 0 => (
+ is => 'bare',
+ );
+ } 'has 0; works now';
+}
+
+{
+ package My::Class;
+ use Mouse;
+
+ ::throws_ok {
+ has;
+ } $exception_regex, 'has; fails';
+
+ ::throws_ok {
+ has undef;
+ } $exception_regex, 'has undef; fails';
+
+ ::lives_ok {
+ has "" => (
+ is => 'bare',
+ );
+ } 'has ""; works now';
+
+ ::lives_ok {
+ has 0 => (
+ is => 'bare',
+ );
+ } 'has 0; works now';
+}
+
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 5;
+
+{
+ package My::Attribute::Trait;
+ use Mouse::Role;
+
+ sub reversed_name {
+ my $self = shift;
+ scalar reverse $self->name;
+ }
+}
+
+{
+ package My::Class;
+ use Mouse;
+
+ has foo => (
+ traits => [
+ 'My::Attribute::Trait' => {
+ -alias => {
+ reversed_name => 'eman',
+ },
+ },
+ ],
+ is => 'bare',
+ );
+}
+
+{
+ package My::Other::Class;
+ use Mouse;
+
+ has foo => (
+ traits => [
+ 'My::Attribute::Trait' => {
+ -alias => {
+ reversed_name => 'reversed',
+ },
+ -excludes => 'reversed_name',
+ },
+ ],
+ is => 'bare',
+ );
+}
+
+my $attr = My::Class->meta->get_attribute('foo');
+is($attr->eman, 'oof', 'the aliased method is in the attribute');
+ok(!$attr->can('reversed'), "the method was not installed under the other class' alias");
+
+my $other_attr = My::Other::Class->meta->get_attribute('foo');
+is($other_attr->reversed, 'oof', 'the aliased method is in the attribute');
+ok(!$other_attr->can('enam'), "the method was not installed under the other class' alias");
+ok(!$other_attr->can('reversed_name'), "the method was not installed under the original name when that was excluded");
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+use Test::Exception;
+
+{
+ package Baz;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ coerce 'Baz' => from 'HashRef' => via { Baz->new($_) };
+
+ has 'hello' => (
+ is => 'ro',
+ isa => 'Str',
+ );
+
+ package Bar;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ coerce 'Bar' => from 'HashRef' => via { Bar->new($_) };
+
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Baz',
+ coerce => 1
+ );
+
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (
+ is => 'ro',
+ isa => 'Bar',
+ coerce => 1,
+ );
+}
+
+my $foo = Foo->new(bar => { baz => { hello => 'World' } });
+isa_ok($foo, 'Foo');
+isa_ok($foo->bar, 'Bar');
+isa_ok($foo->bar->baz, 'Baz');
+is($foo->bar->baz->hello, 'World', '... this all worked fine');
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+use Mouse ();
+use Mouse::Meta::Class;
+
+my $meta = Mouse::Meta::Class->create('Banana');
+
+my $warn;
+$SIG{__WARN__} = sub { $warn = "@_" };
+
+$meta->add_attribute('foo');
+like $warn, qr/Attribute \(foo\) of class Banana has no associated methods/,
+ 'correct error message';
+
+$warn = '';
+$meta->add_attribute('bar', is => 'bare');
+is $warn, '', 'add attribute with no methods and is => "bare"';
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+ eval "use Test::Output;";
+ plan skip_all => "Test::Output is required for this test" if $@;
+ plan tests => 5;
+}
+
+{
+ package Foo;
+ use Mouse;
+
+ sub get_a { }
+ sub set_b { }
+ sub has_c { }
+ sub clear_d { }
+ sub e { }
+}
+
+my $foo_meta = Foo->meta;
+stderr_like(sub { $foo_meta->add_attribute(a => (reader => 'get_a')) },
+ qr/^You are overwriting a locally defined method \(get_a\) with an accessor/, 'reader overriding gives proper warning');
+stderr_like(sub { $foo_meta->add_attribute(b => (writer => 'set_b')) },
+ qr/^You are overwriting a locally defined method \(set_b\) with an accessor/, 'writer overriding gives proper warning');
+stderr_like(sub { $foo_meta->add_attribute(c => (predicate => 'has_c')) },
+ qr/^You are overwriting a locally defined method \(has_c\) with an accessor/, 'predicate overriding gives proper warning');
+stderr_like(sub { $foo_meta->add_attribute(d => (clearer => 'clear_d')) },
+ qr/^You are overwriting a locally defined method \(clear_d\) with an accessor/, 'clearer overriding gives proper warning');
+stderr_like(sub { $foo_meta->add_attribute(e => (is => 'rw')) },
+ qr/^You are overwriting a locally defined method \(e\) with an accessor/, 'accessor overriding gives proper warning');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+{
+ package SomeAwesomeDB;
+
+ sub new_row { }
+ sub read { }
+ sub write { }
+}
+
+{
+ package MouseX::SomeAwesomeDBFields;
+
+ # implementation of methods not called in the example deliberately
+ # omitted
+
+ use Mouse::Role;
+
+ sub inline_create_instance {
+ my ( $self, $classvar ) = @_;
+
+ "bless SomeAwesomeDB::new_row(), $classvar";
+ }
+
+ sub inline_get_slot_value {
+ my ( $self, $invar, $slot ) = @_;
+
+ "SomeAwesomeDB::read($invar, \"$slot\")";
+ }
+
+ sub inline_set_slot_value {
+ my ( $self, $invar, $slot, $valexp ) = @_;
+
+ "SomeAwesomeDB::write($invar, \"$slot\", $valexp)";
+ }
+
+ sub inline_is_slot_initialized {
+ my ( $self, $invar, $slot ) = @_;
+
+ "1";
+ }
+
+ sub inline_initialize_slot {
+ my ( $self, $invar, $slot ) = @_;
+
+ "";
+ }
+
+ sub inline_slot_access {
+ die "inline_slot_access should not have been used";
+ }
+}
+
+{
+ package Toy;
+
+ use Mouse;
+ use Mouse::Util::MetaRole;
+
+ use Test::More tests => 3;
+ use Test::Exception;
+
+ Mouse::Util::MetaRole::apply_metaclass_roles(
+ for_class => __PACKAGE__,
+ instance_metaclass_roles => ['MouseX::SomeAwesomeDBFields']
+ );
+
+ lives_ok {
+ has lazy_attr => (
+ is => 'ro',
+ isa => 'Bool',
+ lazy => 1,
+ default => sub {0},
+ );
+ }
+ "Adding lazy accessor does not use inline_slot_access";
+
+ lives_ok {
+ has rw_attr => (
+ is => 'rw',
+ );
+ }
+ "Adding read-write accessor does not use inline_slot_access";
+
+ lives_ok { __PACKAGE__->meta->make_immutable; }
+ "Inling constructor does not use inline_slot_access";
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 14;
+use Test::Exception;
+
+lives_ok {
+ package My::Class;
+ use Mouse;
+
+ has s_rw => (
+ is => 'rw',
+ );
+
+ has s_ro => (
+ is => 'ro',
+ );
+
+ has a_rw => (
+ is => 'rw',
+ isa => 'ArrayRef',
+
+ auto_deref => 1,
+ );
+
+ has a_ro => (
+ is => 'ro',
+ isa => 'ArrayRef',
+
+ auto_deref => 1,
+ );
+
+ has h_rw => (
+ is => 'rw',
+ isa => 'HashRef',
+
+ auto_deref => 1,
+ );
+
+ has h_ro => (
+ is => 'ro',
+ isa => 'HashRef',
+
+ auto_deref => 1,
+ );
+} 'class definition';
+
+lives_ok {
+ my $o = My::Class->new();
+
+ is_deeply [scalar $o->s_rw], [undef], 'uninitialized scalar attribute/rw in scalar context';
+ is_deeply [$o->s_rw], [undef], 'uninitialized scalar attribute/rw in list context';
+ is_deeply [scalar $o->s_ro], [undef], 'uninitialized scalar attribute/ro in scalar context';
+ is_deeply [$o->s_ro], [undef], 'uninitialized scalar attribute/ro in list context';
+
+
+ is_deeply [scalar $o->a_rw], [undef], 'uninitialized ArrayRef attribute/rw in scalar context';
+ is_deeply [$o->a_rw], [], 'uninitialized ArrayRef attribute/rw in list context';
+ is_deeply [scalar $o->a_ro], [undef], 'uninitialized ArrayRef attribute/ro in scalar context';
+ is_deeply [$o->a_ro], [], 'uninitialized ArrayRef attribute/ro in list context';
+
+ is_deeply [scalar $o->h_rw], [undef], 'uninitialized HashRef attribute/rw in scalar context';
+ is_deeply [$o->h_rw], [], 'uninitialized HashRef attribute/rw in list context';
+ is_deeply [scalar $o->h_ro], [undef], 'uninitialized HashRef attribute/ro in scalar context';
+ is_deeply [$o->h_ro], [], 'uninitialized HashRef attribute/ro in list context';
+
+} 'testing';
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+
+{
+ package Foo;
+ use Mouse;
+ has 'type' => (
+ required => 0,
+ reader => 'get_type',
+ default => 1,
+ );
+
+ has '@type' => (
+ required => 0,
+ reader => 'get_at_type',
+ default => 2,
+ );
+
+ has 'has spaces' => (
+ required => 0,
+ reader => 'get_hs',
+ default => 42,
+ );
+
+ no Mouse;
+}
+
+{
+ my $foo = Foo->new;
+
+ ok( Foo->meta->has_attribute($_), "Foo has '$_' attribute" )
+ for 'type', '@type', 'has spaces';
+
+ is( $foo->get_type, 1, q{'type' attribute default is 1} );
+ is( $foo->get_at_type, 2, q{'@type' attribute default is 1} );
+ is( $foo->get_hs, 42, q{'has spaces' attribute default is 42} );
+
+ Foo->meta->make_immutable, redo if Foo->meta->is_mutable;
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+use Test::Exception;
+
+{
+ package Bar;
+ use Mouse;
+
+ sub baz { 'Bar::baz' }
+ sub gorch { 'Bar::gorch' }
+
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (
+ is => 'ro',
+ isa => 'Bar',
+ lazy => 1,
+ default => sub { Bar->new },
+ handles => [qw[ baz gorch ]]
+ );
+
+ package Foo::Extended;
+ use Mouse;
+
+ extends 'Foo';
+
+ has 'test' => (
+ is => 'rw',
+ isa => 'Bool',
+ default => sub { 0 },
+ );
+
+ around 'bar' => sub {
+ my $next = shift;
+ my $self = shift;
+
+ $self->test(1);
+ $self->$next();
+ };
+}
+
+my $foo = Foo::Extended->new;
+isa_ok($foo, 'Foo::Extended');
+isa_ok($foo, 'Foo');
+
+ok(!$foo->test, '... the test value has not been changed');
+
+is($foo->baz, 'Bar::baz', '... got the right delegated method');
+
+ok($foo->test, '... the test value has now been changed');
+
+
+
+
+
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+use Test::Exception;
+
+
+
+{
+ package My::Custom::Meta::Attr;
+ use Mouse;
+
+ extends 'Mouse::Meta::Attribute';
+}
+
+{
+ package My::Fancy::Role;
+ use Mouse::Role;
+
+ has 'bling_bling' => (
+ metaclass => 'My::Custom::Meta::Attr',
+ is => 'rw',
+ isa => 'Str',
+ );
+}
+
+{
+ package My::Class;
+ use Mouse;
+
+ with 'My::Fancy::Role';
+}
+
+my $c = My::Class->new;
+isa_ok($c, 'My::Class');
+
+ok($c->meta->has_attribute('bling_bling'), '... got the attribute');
+
+isa_ok($c->meta->get_attribute('bling_bling'), 'My::Custom::Meta::Attr');
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use Test::Exception;
+
+;
+
+lives_ok {
+ package MouseX::Attribute::Test;
+ use Mouse::Role;
+} 'creating custom attribute "metarole" is okay';
+
+lives_ok {
+ package Mouse::Meta::Attribute::Custom::Test;
+ use Mouse;
+
+ extends 'Mouse::Meta::Attribute';
+ with 'MouseX::Attribute::Test';
+} 'custom attribute metaclass extending role is okay';
sub applied_traits{ $_[0]->{traits} } # TEST ONLY
sub has_applied_traits{ exists $_[0]->{traits} } # TEST ONLY
+sub has_documentation{ exists $_[0]->{documentation} } # TEST ONLY
+sub documentation{ $_[0]->{documentation} } # TEST ONLY
+
1;
__END__
projects / gitmo/Mouse.git / commitdiff