--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use lib 't/lib', 'lib';
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+
+{
+
+ package Bar;
+ use Mouse;
+
+ ::lives_ok { extends 'Foo' } 'loaded Foo superclass correctly';
+}
+
+{
+
+ package Baz;
+ use Mouse;
+
+ ::lives_ok { extends 'Bar' } 'loaded (inline) Bar superclass correctly';
+}
+
+{
+
+ package Foo::Bar;
+ use Mouse;
+
+ ::lives_ok { extends 'Foo', 'Bar' }
+ 'loaded Foo and (inline) Bar superclass correctly';
+}
+
+{
+
+ package Bling;
+ use Mouse;
+
+ ::throws_ok { extends 'No::Class' }
+ qr{Can't locate No/Class\.pm in \@INC},
+ 'correct error when superclass could not be found';
+}
+
+{
+ package Affe;
+ our $VERSION = 23;
+}
+
+{
+ package Tiger;
+ use Mouse;
+
+ ::lives_ok { extends 'Foo', Affe => { -version => 13 } }
+ 'extends with version requirement';
+}
+
+{
+ package Birne;
+ use Mouse;
+
+ ::throws_ok { extends 'Foo', Affe => { -version => 42 } }
+ qr/Affe version 42 required--this is only version 23/,
+ 'extends with unsatisfied version requirement';
+}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 11;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
use Scalar::Util 'blessed';
# try to rebless, except it will fail due to Child's stricter type constraint
throws_ok { Child->meta->rebless_instance($foo) }
-qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 10\.5/,
+qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/,
'... this failed cause of type check';
throws_ok { Child->meta->rebless_instance($bar) }
-qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 5\.5/,
+qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 5\.5/,
'... this failed cause of type check';;
$foo->type_constrained(10);
is($bar->lazy_classname, 'Child', "lazy attribute just now initialized");
throws_ok { $foo->type_constrained(10.5) }
-qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 10\.5/,
+qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/,
'... this failed cause of type check';
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+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 Foo::Class;
+ use Mouse;
+
+ with 'Foo::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 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 Mouse;
+
+ # 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 Mouse;
+
+ # 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()';
+}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 92;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-
# -------------------------------------------------------------------
# HASH handles
# -------------------------------------------------------------------
isa_ok($bar->foo, 'Foo');
my $meth = Bar->meta->get_method('foo_bar');
-isa_ok($meth, 'Mouse::Meta::Method::Delegation');
+isa_ok($meth, 'Mouse::Meta::Method');
is($meth->associated_attribute->name, 'foo',
'associated_attribute->name for this method is foo');
handles => 'Foo::Bar',
);
+ package Foo::OtherThing;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ has 'other_thing' => (
+ is => 'rw',
+ isa => 'Foo::Baz',
+ handles => Mouse::Util::TypeConstraints::find_type_constraint('Foo::Bar'),
+ );
}
{
is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value');
}
+{
+ my $foo = Foo::OtherThing->new(other_thing => Foo::Baz->new);
+ isa_ok($foo, 'Foo::OtherThing');
+ isa_ok($foo->other_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->other_thing->baz, 'Foo::Baz::BAZ', '... got the right value');
+}
# -------------------------------------------------------------------
# AUTOLOAD & handles
# -------------------------------------------------------------------
my $k = Bar->new(foo => "Foo");
lives_ok { $k->foo_baz } "but not for class name";
}
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+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 ChildH;
+ use Mouse;
+
+ sub child_h_method_1 { "h1" }
+ sub parent_method_1 { "child_parent_1" }
+
+ package ChildI;
+ use Mouse;
+
+ sub child_i_method_1 { "i1" }
+ sub parent_method_1 { "child_parent_1" }
+
+ package Parent;
+ use Mouse;
+
+ sub parent_method_1 { "parent_1" }
+ ::can_ok('Parent', 'parent_method_1');
+
+ ::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";
+
+ ::can_ok('Parent', 'parent_method_1');
+ ::dies_ok {
+ has child_h => (
+ isa => "ChildH",
+ is => "ro",
+ default => sub { ChildH->new },
+ handles => sub { map { $_, $_ } $_[1]->get_all_method_names },
+ );
+ } "Can't override exisiting class method in delegate";
+ ::can_ok('Parent', 'parent_method_1');
+
+ ::lives_ok {
+ has child_i => (
+ isa => "ChildI",
+ is => "ro",
+ default => sub { ChildI->new },
+ handles => sub {
+ map { $_, $_ } grep { !/^parent_method_1|meta$/ }
+ $_[1]->get_all_method_names;
+ },
+ );
+ } "Test handles code ref for skipping predefined methods";
+
+
+ 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" );
+isa_ok( $p->child_i, "ChildI" );
+
+ok(!$p->can('child_g'), '... no child_g accessor defined');
+ok(!$p->can('child_h'), '... no child_h 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)" );
+
+can_ok( $p, "child_i_method_1" );
+is( $p->parent_method_1, "parent_1", "delegate doesn't override existing method" );
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-
=pod
is => rw, writer => _foo # turns into (reader => foo, writer => _foo)
dies_ok { make_class('ro', 'accessor', "Test::Class::AccessorRO"); } "Cant define attr with ro + accessor";
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 8;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
my $exception_regex = qr/You must provide a name for the attribute/;
} 'has 0; works now';
}
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
}
{
- package MouseX::SomeAwesomeDBFields;
+ package MooseX::SomeAwesomeDBFields;
# implementation of methods not called in the example deliberately
# omitted
use Mouse;
use Mouse::Util::MetaRole;
- use Test::More tests => 3;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => __PACKAGE__,
- instance_metaclass_roles => ['MouseX::SomeAwesomeDBFields']
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => { instance => ['MooseX::SomeAwesomeDBFields'] },
);
lives_ok {
lives_ok { __PACKAGE__->meta->make_immutable; }
"Inling constructor does not use inline_slot_access";
+
+ done_testing;
}
--- /dev/null
+#!/usr/bin/env perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use strict;
+use warnings;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+
+my $called;
+{
+ package Foo::Meta::Instance;
+ use Mouse::Role;
+
+ sub is_inlinable { 0 }
+
+ after get_slot_value => sub { $called++ };
+}
+
+{
+ package Foo;
+ use Mouse;
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => {
+ instance => ['Foo::Meta::Instance'],
+ },
+ );
+
+ has foo => (is => 'ro');
+}
+
+my $foo = Foo->new(foo => 1);
+is($foo->foo, 1, "got the right value");
+is($called, 1, "reader was called");
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+use Mouse::Meta::Role;
+use Mouse::Util::TypeConstraints ();
+
+{
+ package FooRole;
+
+ our $VERSION = '0.01';
+
+ sub foo { 'FooRole::foo' }
+}
+
+my $foo_role = Mouse::Meta::Role->initialize('FooRole');
+isa_ok($foo_role, 'Mouse::Meta::Role');
+isa_ok($foo_role, 'Mouse::Meta::Module');
+
+is($foo_role->name, 'FooRole', '... got the right name of FooRole');
+is($foo_role->version, '0.01', '... got the right version of FooRole');
+
+# methods ...
+
+ok($foo_role->has_method('foo'), '... FooRole has the foo method');
+is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method');
+
+isa_ok($foo_role->get_method('foo'), 'Mouse::Meta::Role::Method');
+
+is_deeply(
+ [ $foo_role->get_method_list() ],
+ [ 'foo' ],
+ '... got the right method list');
+
+# attributes ...
+
+is_deeply(
+ [ $foo_role->get_attribute_list() ],
+ [],
+ '... got the right attribute list');
+
+ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute');
+
+lives_ok {
+ $foo_role->add_attribute('bar' => (is => 'rw', isa => 'Foo'));
+} '... added the bar attribute okay';
+
+is_deeply(
+ [ $foo_role->get_attribute_list() ],
+ [ 'bar' ],
+ '... got the right attribute list');
+
+ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute');
+
+my $bar = $foo_role->get_attribute('bar');
+is_deeply( $bar->original_options, { is => 'rw', isa => 'Foo' },
+ 'original options for bar attribute' );
+my $bar_for_class = $bar->attribute_for_class('Mouse::Meta::Attribute');
+is(
+ $bar_for_class->type_constraint,
+ Mouse::Util::TypeConstraints::class_type('Foo'),
+ 'bar has a Foo class type'
+);
+
+lives_ok {
+ $foo_role->add_attribute('baz' => (is => 'ro'));
+} '... added the baz attribute okay';
+
+is_deeply(
+ [ sort $foo_role->get_attribute_list() ],
+ [ 'bar', 'baz' ],
+ '... got the right attribute list');
+
+ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute');
+
+my $baz = $foo_role->get_attribute('baz');
+is_deeply( $baz->original_options, { is => 'ro' },
+ 'original options for baz attribute' );
+
+lives_ok {
+ $foo_role->remove_attribute('bar');
+} '... removed the bar attribute okay';
+
+is_deeply(
+ [ $foo_role->get_attribute_list() ],
+ [ 'baz' ],
+ '... got the right attribute list');
+
+ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute');
+ok($foo_role->has_attribute('baz'), '... FooRole does still have the baz attribute');
+
+# method modifiers
+
+ok(!$foo_role->has_before_method_modifiers('boo'), '... no boo:before modifier');
+
+my $method = sub { "FooRole::boo:before" };
+lives_ok {
+ $foo_role->add_before_method_modifier('boo' => $method);
+} '... added a method modifier okay';
+
+ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier');
+is(($foo_role->get_before_method_modifiers('boo'))[0], $method, '... got the right method back');
+
+is_deeply(
+ [ $foo_role->get_method_modifier_list('before') ],
+ [ 'boo' ],
+ '... got the right list of before method modifiers');
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+{
+ package FooRole;
+ use Mouse::Role;
+
+ our $VERSION = 23;
+
+ has 'bar' => ( is => 'rw', isa => 'FooClass' );
+ has 'baz' => ( is => 'ro' );
+
+ sub goo {'FooRole::goo'}
+ sub foo {'FooRole::foo'}
+
+ override 'boo' => sub { 'FooRole::boo -> ' . super() };
+
+ around 'blau' => sub {
+ my $c = shift;
+ 'FooRole::blau -> ' . $c->();
+ };
+}
+
+{
+ package BarRole;
+ use Mouse::Role;
+ sub woot {'BarRole::woot'}
+}
+
+{
+ package BarClass;
+ use Mouse;
+
+ sub boo {'BarClass::boo'}
+ sub foo {'BarClass::foo'} # << the role overrides this ...
+}
+
+{
+ package FooClass;
+ use Mouse;
+
+ extends 'BarClass';
+
+ ::throws_ok { with 'FooRole' => { -version => 42 } }
+ qr/FooRole version 42 required--this is only version 23/,
+ 'applying role with unsatisfied version requirement';
+
+ ::lives_ok { with 'FooRole' => { -version => 13 } }
+ 'applying role with satisfied version requirement';
+
+ sub blau {'FooClass::blau'} # << the role wraps this ...
+
+ sub goo {'FooClass::goo'} # << overrides the one from the role ...
+}
+
+{
+ package FooBarClass;
+ use Mouse;
+
+ extends 'FooClass';
+ with 'FooRole', 'BarRole';
+}
+
+my $foo_class_meta = FooClass->meta;
+isa_ok( $foo_class_meta, 'Mouse::Meta::Class' );
+
+my $foobar_class_meta = FooBarClass->meta;
+isa_ok( $foobar_class_meta, 'Mouse::Meta::Class' );
+
+dies_ok {
+ $foo_class_meta->does_role();
+}
+'... does_role requires a role name';
+
+dies_ok {
+ $foo_class_meta->add_role();
+}
+'... apply_role requires a role';
+
+dies_ok {
+ $foo_class_meta->add_role( bless( {} => 'Fail' ) );
+}
+'... apply_role requires a role';
+
+ok( $foo_class_meta->does_role('FooRole'),
+ '... the FooClass->meta does_role FooRole' );
+ok( !$foo_class_meta->does_role('OtherRole'),
+ '... the FooClass->meta !does_role OtherRole' );
+
+ok( $foobar_class_meta->does_role('FooRole'),
+ '... the FooBarClass->meta does_role FooRole' );
+ok( $foobar_class_meta->does_role('BarRole'),
+ '... the FooBarClass->meta does_role BarRole' );
+ok( !$foobar_class_meta->does_role('OtherRole'),
+ '... the FooBarClass->meta !does_role OtherRole' );
+
+foreach my $method_name (qw(bar baz foo boo blau goo)) {
+ ok( $foo_class_meta->has_method($method_name),
+ '... FooClass has the method ' . $method_name );
+ ok( $foobar_class_meta->has_method($method_name),
+ '... FooBarClass has the method ' . $method_name );
+}
+
+ok( !$foo_class_meta->has_method('woot'),
+ '... FooClass lacks the method woot' );
+ok( $foobar_class_meta->has_method('woot'),
+ '... FooBarClass has the method woot' );
+
+foreach my $attr_name (qw(bar baz)) {
+ ok( $foo_class_meta->has_attribute($attr_name),
+ '... FooClass has the attribute ' . $attr_name );
+ ok( $foobar_class_meta->has_attribute($attr_name),
+ '... FooBarClass has the attribute ' . $attr_name );
+}
+
+can_ok( 'FooClass', 'does' );
+ok( FooClass->does('FooRole'), '... the FooClass does FooRole' );
+ok( !FooClass->does('BarRole'), '... the FooClass does not do BarRole' );
+ok( !FooClass->does('OtherRole'), '... the FooClass does not do OtherRole' );
+
+can_ok( 'FooBarClass', 'does' );
+ok( FooBarClass->does('FooRole'), '... the FooClass does FooRole' );
+ok( FooBarClass->does('BarRole'), '... the FooBarClass does FooBarRole' );
+ok( !FooBarClass->does('OtherRole'),
+ '... the FooBarClass does not do OtherRole' );
+
+my $foo = FooClass->new();
+isa_ok( $foo, 'FooClass' );
+
+my $foobar = FooBarClass->new();
+isa_ok( $foobar, 'FooBarClass' );
+
+is( $foo->goo, 'FooClass::goo', '... got the right value of goo' );
+is( $foobar->goo, 'FooRole::goo', '... got the right value of goo' );
+
+is( $foo->boo, 'FooRole::boo -> BarClass::boo',
+ '... got the right value from ->boo' );
+is( $foobar->boo, 'FooRole::boo -> FooRole::boo -> BarClass::boo',
+ '... got the right value from ->boo (double wrapped)' );
+
+is( $foo->blau, 'FooRole::blau -> FooClass::blau',
+ '... got the right value from ->blau' );
+is( $foobar->blau, 'FooRole::blau -> FooRole::blau -> FooClass::blau',
+ '... got the right value from ->blau' );
+
+foreach my $foo ( $foo, $foobar ) {
+ can_ok( $foo, 'does' );
+ ok( $foo->does('FooRole'), '... an instance of FooClass does FooRole' );
+ ok( !$foo->does('OtherRole'),
+ '... and instance of FooClass does not do OtherRole' );
+
+ can_ok( $foobar, 'does' );
+ ok( $foobar->does('FooRole'),
+ '... an instance of FooBarClass does FooRole' );
+ ok( $foobar->does('BarRole'),
+ '... an instance of FooBarClass does BarRole' );
+ ok( !$foobar->does('OtherRole'),
+ '... and instance of FooBarClass does not do OtherRole' );
+
+ for my $method (qw/bar baz foo boo goo blau/) {
+ can_ok( $foo, $method );
+ }
+
+ is( $foo->foo, 'FooRole::foo', '... got the right value of foo' );
+
+ ok( !defined( $foo->baz ), '... $foo->baz is undefined' );
+ ok( !defined( $foo->bar ), '... $foo->bar is undefined' );
+
+ dies_ok {
+ $foo->baz(1);
+ }
+ '... baz is a read-only accessor';
+
+ dies_ok {
+ $foo->bar(1);
+ }
+ '... bar is a read-write accessor with a type constraint';
+
+ my $foo2 = FooClass->new();
+ isa_ok( $foo2, 'FooClass' );
+
+ lives_ok {
+ $foo->bar($foo2);
+ }
+ '... bar is a read-write accessor with a type constraint';
+
+ is( $foo->bar, $foo2, '... got the right value for bar now' );
+}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 22;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
=pod
ok(My::Test4->meta->excludes_role('Molecule::Inorganic'), '... My::Test4 meta excludes Molecule::Organic');
ok(!My::Test4->does('Molecule::Inorganic'), '... My::Test4 does Molecule::Inorganic');
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 15;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
=pod
sub foo { 'Class::ProvideFoo::foo' }
before 'foo' => sub { 'Class::ProvideFoo::foo:before' };
- ::isa_ok(__PACKAGE__->meta->get_method('foo'), 'Class::MOP::Method::Wrapped');
+ ::isa_ok(__PACKAGE__->meta->get_method('foo'), 'Mouse::Meta::Method');
::is(__PACKAGE__->meta->get_method('foo')->get_original_method->package_name, __PACKAGE__,
'... but the original method is from our package');
with 'Bar2::Role';
} 'required method exists in superclass as non-modifier, so we live';
}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 39;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-
{
# test no conflicts here
package Role::A;
}
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 19;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-
{
package My::Role;
use Mouse::Role;
ok(!My::Foo::Role::Other->meta->has_method('foo'), "we dont have a foo method");
ok(My::Foo::Role::Other->meta->requires_method('foo'), '... and the &foo method is required');
-
-
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+
+{
+ package My::Role;
+ use Mouse::Role;
+
+ sub foo { 'Foo::foo' }
+ sub bar { 'Foo::bar' }
+ sub baz { 'Foo::baz' }
+
+ requires 'role_bar';
+
+ package My::Class;
+ use Mouse;
+
+ ::lives_ok {
+ with 'My::Role' => { -alias => { bar => 'role_bar' } };
+ } '... this succeeds';
+
+ package My::Class::Failure;
+ use Mouse;
+
+ ::throws_ok {
+ with 'My::Role' => { -alias => { bar => 'role_bar' } };
+ } qr/Cannot create a method alias if a local method of the same name exists/, '... this succeeds';
+
+ sub role_bar { 'FAIL' }
+}
+
+ok(My::Class->meta->has_method($_), "we have a $_ method") for qw(foo baz bar role_bar);
+
+{
+ package My::OtherRole;
+ use Mouse::Role;
+
+ ::lives_ok {
+ with 'My::Role' => { -alias => { bar => 'role_bar' } };
+ } '... this succeeds';
+
+ sub bar { 'My::OtherRole::bar' }
+
+ package My::OtherRole::Failure;
+ use Mouse::Role;
+
+ ::throws_ok {
+ with 'My::Role' => { -alias => { bar => 'role_bar' } };
+ } qr/Cannot create a method alias if a local method of the same name exists/, '... cannot alias to a name that exists';
+
+ sub role_bar { 'FAIL' }
+}
+
+ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar);
+ok(My::OtherRole->meta->requires_method('bar'), '... and the &bar method is required');
+ok(!My::OtherRole->meta->requires_method('role_bar'), '... and the &role_bar method is not required');
+
+{
+ package My::AliasingRole;
+ use Mouse::Role;
+
+ ::lives_ok {
+ with 'My::Role' => { -alias => { bar => 'role_bar' } };
+ } '... this succeeds';
+}
+
+ok(My::AliasingRole->meta->has_method($_), "we have a $_ method") for qw(foo baz role_bar);
+ok(!My::AliasingRole->meta->requires_method('bar'), '... and the &bar method is not required');
+
+{
+ package Foo::Role;
+ use Mouse::Role;
+
+ sub foo { 'Foo::Role::foo' }
+
+ package Bar::Role;
+ use Mouse::Role;
+
+ sub foo { 'Bar::Role::foo' }
+
+ package Baz::Role;
+ use Mouse::Role;
+
+ sub foo { 'Baz::Role::foo' }
+
+ package My::Foo::Class;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
+ 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' },
+ 'Baz::Role';
+ } '... composed our roles correctly';
+
+ package My::Foo::Class::Broken;
+ use Mouse;
+
+ ::throws_ok {
+ with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
+ 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
+ 'Baz::Role';
+ } qr/Due to a method name conflict in roles 'Bar::Role' and 'Foo::Role', the method 'foo_foo' must be implemented or excluded by 'My::Foo::Class::Broken'/,
+ '... composed our roles correctly';
+}
+
+{
+ my $foo = My::Foo::Class->new;
+ isa_ok($foo, 'My::Foo::Class');
+ can_ok($foo, $_) for qw/foo foo_foo bar_foo/;
+ is($foo->foo, 'Baz::Role::foo', '... got the right method');
+ is($foo->foo_foo, 'Foo::Role::foo', '... got the right method');
+ is($foo->bar_foo, 'Bar::Role::foo', '... got the right method');
+}
+
+{
+ package My::Foo::Role;
+ use Mouse::Role;
+
+ ::lives_ok {
+ with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
+ 'Bar::Role' => { -alias => { 'foo' => 'bar_foo' }, -excludes => 'foo' },
+ 'Baz::Role';
+ } '... composed our roles correctly';
+}
+
+ok(My::Foo::Role->meta->has_method($_), "we have a $_ method") for qw/foo foo_foo bar_foo/;;
+ok(!My::Foo::Role->meta->requires_method('foo'), '... and the &foo method is not required');
+
+
+{
+ package My::Foo::Role::Other;
+ use Mouse::Role;
+
+ ::lives_ok {
+ with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
+ 'Bar::Role' => { -alias => { 'foo' => 'foo_foo' }, -excludes => 'foo' },
+ 'Baz::Role';
+ } '... composed our roles correctly';
+}
+
+ok(!My::Foo::Role::Other->meta->has_method('foo_foo'), "we dont have a foo_foo method");
+ok(My::Foo::Role::Other->meta->requires_method('foo_foo'), '... and the &foo method is required');
+
+{
+ package My::Foo::AliasOnly;
+ use Mouse;
+
+ ::lives_ok {
+ with 'Foo::Role' => { -alias => { 'foo' => 'foo_foo' } },
+ } '... composed our roles correctly';
+}
+
+ok(My::Foo::AliasOnly->meta->has_method('foo'), 'we have a foo method');
+ok(My::Foo::AliasOnly->meta->has_method('foo_foo'), '.. and the aliased foo_foo method');
+
+{
+ package Role::Foo;
+ use Mouse::Role;
+
+ sub x1 {}
+ sub y1 {}
+}
+
+{
+ package Role::Bar;
+ use Mouse::Role;
+
+ use Test::Exception;
+
+ lives_ok {
+ with 'Role::Foo' => {
+ -alias => { x1 => 'foo_x1' },
+ -excludes => ['y1'],
+ };
+ }
+ 'Compose Role::Foo into Role::Bar with alias and exclude';
+
+ sub x1 {}
+ sub y1 {}
+}
+
+{
+ my $bar = Role::Bar->meta;
+ ok( $bar->has_method($_), "has $_ method" )
+ for qw( x1 y1 foo_x1 );
+}
+
+{
+ package Role::Baz;
+ use Mouse::Role;
+
+ use Test::Exception;
+
+ lives_ok {
+ with 'Role::Foo' => {
+ -alias => { x1 => 'foo_x1' },
+ -excludes => ['y1'],
+ };
+ }
+ 'Compose Role::Foo into Role::Baz with alias and exclude';
+}
+
+{
+ my $baz = Role::Baz->meta;
+ ok( $baz->has_method($_), "has $_ method" )
+ for qw( x1 foo_x1 );
+ ok( ! $baz->has_method('y1'), 'Role::Baz has no y1 method' );
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+
+=pod
+
+This basically just makes sure that using +name
+on role attributes works right.
+
+=cut
+
+{
+ package Foo::Role;
+ use Mouse::Role;
+
+ has 'bar' => (
+ is => 'rw',
+ isa => 'Int',
+ default => sub { 10 },
+ );
+
+ package Foo;
+ use Mouse;
+
+ with 'Foo::Role';
+
+ ::lives_ok {
+ has '+bar' => (default => sub { 100 });
+ } '... extended the attribute successfully';
+}
+
+my $foo = Foo->new;
+isa_ok($foo, 'Foo');
+
+is($foo->bar, 100, '... got the extended attribute');
+
+
+{
+ package Bar::Role;
+ use Mouse::Role;
+
+ has 'foo' => (
+ is => 'rw',
+ isa => 'Str | Int',
+ );
+
+ package Bar;
+ use Mouse;
+
+ with 'Bar::Role';
+
+ ::lives_ok {
+ has '+foo' => (
+ isa => 'Int',
+ )
+ } "... narrowed the role's type constraint successfully";
+}
+
+my $bar = Bar->new(foo => 42);
+isa_ok($bar, 'Bar');
+is($bar->foo, 42, '... got the extended attribute');
+$bar->foo(100);
+is($bar->foo, 100, "... can change the attribute's value to an Int");
+
+throws_ok { $bar->foo("baz") } qr/^Attribute \(foo\) does not pass the type constraint because: Validation failed for 'Int' with value baz at /;
+is($bar->foo, 100, "... still has the old Int value");
+
+
+{
+ package Baz::Role;
+ use Mouse::Role;
+
+ has 'baz' => (
+ is => 'rw',
+ isa => 'Value',
+ );
+
+ package Baz;
+ use Mouse;
+
+ with 'Baz::Role';
+
+ ::lives_ok {
+ has '+baz' => (
+ isa => 'Int | ClassName',
+ )
+ } "... narrowed the role's type constraint successfully";
+}
+
+my $baz = Baz->new(baz => 99);
+isa_ok($baz, 'Baz');
+is($baz->baz, 99, '... got the extended attribute');
+$baz->baz('Foo');
+is($baz->baz, 'Foo', "... can change the attribute's value to a ClassName");
+
+throws_ok { $baz->baz("zonk") } qr/^Attribute \(baz\) does not pass the type constraint because: Validation failed for 'ClassName\|Int' with value zonk at /;
+is_deeply($baz->baz, 'Foo', "... still has the old ClassName value");
+
+
+{
+ package Quux::Role;
+ use Mouse::Role;
+
+ has 'quux' => (
+ is => 'rw',
+ isa => 'Str | Int | Ref',
+ );
+
+ package Quux;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ with 'Quux::Role';
+
+ subtype 'Positive'
+ => as 'Int'
+ => where { $_ > 0 };
+
+ ::lives_ok {
+ has '+quux' => (
+ isa => 'Positive | ArrayRef',
+ )
+ } "... narrowed the role's type constraint successfully";
+}
+
+my $quux = Quux->new(quux => 99);
+isa_ok($quux, 'Quux');
+is($quux->quux, 99, '... got the extended attribute');
+$quux->quux(100);
+is($quux->quux, 100, "... can change the attribute's value to an Int");
+$quux->quux(["hi"]);
+is_deeply($quux->quux, ["hi"], "... can change the attribute's value to an ArrayRef");
+
+throws_ok { $quux->quux("quux") } qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef\|Positive' with value quux at /;
+is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value");
+
+throws_ok { $quux->quux({a => 1}) } qr/^Attribute \(quux\) does not pass the type constraint because: Validation failed for 'ArrayRef\|Positive' with value HASH\(\w+\) at /;
+is_deeply($quux->quux, ["hi"], "... still has the old ArrayRef value");
+
+
+{
+ package Err::Role;
+ use Mouse::Role;
+
+ for (1..3) {
+ has "err$_" => (
+ isa => 'Str | Int',
+ is => 'bare',
+ );
+ }
+
+ package Err;
+ use Mouse;
+
+ with 'Err::Role';
+
+ ::lives_ok {
+ has '+err1' => (isa => 'Defined');
+ } "can get less specific in the subclass";
+
+ ::lives_ok {
+ has '+err2' => (isa => 'Bool');
+ } "or change the type completely";
+
+ ::lives_ok {
+ has '+err3' => (isa => 'Str | ArrayRef');
+ } "or add new types to the union";
+}
+
+{
+ package Role::With::PlusAttr;
+ use Mouse::Role;
+
+ with 'Foo::Role';
+
+ ::throws_ok {
+ has '+bar' => ( is => 'ro' );
+ } qr/has '\+attr' is not supported in roles/,
+ "Test has '+attr' in roles explodes";
+}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 14;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-#use Mouse::Meta::Role::Application::RoleSummation;
+use Mouse::Meta::Role::Application;
use Mouse::Meta::Role::Composite;
{
);
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this composed okay';
##... now nest 'em
);
}
}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 12;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-#use Mouse::Meta::Role::Application::RoleSummation;
+use Mouse::Meta::Role::Application;
use Mouse::Meta::Role::Composite;
{
# test simple exclusion
dies_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply(
+ Mouse::Meta::Role::Application->new->apply(
Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this lives as expected';
}
is($c->name, 'Role::Bar|Role::ExcludesFoo', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this lives as expected';
is_deeply([$c->get_excluded_roles_list], ['Role::Foo'], '... has excluded roles');
# test conflict with an "inherited" exclusion
dies_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply(
+ Mouse::Meta::Role::Application->new->apply(
Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
# test conflict with an "inherited" exclusion of an "inherited" role
dies_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply(
+ Mouse::Meta::Role::Application->new->apply(
Mouse::Meta::Role::Composite->new(
roles => [
Role::DoesFoo->meta,
);
} '... this fails as expected';
-
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 16;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-use Mouse::Meta::Role::Application::RoleSummation;
+use Mouse::Meta::Role::Application;
use Mouse::Meta::Role::Composite;
{
is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this succeeds as expected';
is_deeply(
is($c->name, 'Role::Foo|Role::ProvidesFoo', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this succeeds as expected';
is_deeply(
is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::Bar', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this succeeds as expected';
is_deeply(
is($c->name, 'Role::Foo|Role::ProvidesFoo|Role::ProvidesBar|Role::Bar', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this succeeds as expected';
is_deeply(
);
}
-
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 7;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-use Mouse::Meta::Role::Application::RoleSummation;
+use Mouse::Meta::Role::Application;
use Mouse::Meta::Role::Composite;
{
is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this succeeds as expected';
is_deeply(
# test simple conflict
dies_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply(
+ Mouse::Meta::Role::Application->new->apply(
Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
# test complex conflict
dies_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply(
+ Mouse::Meta::Role::Application->new->apply(
Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
# test simple conflict
dies_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply(
+ Mouse::Meta::Role::Application->new->apply(
Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
);
} '... this fails as expected';
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 19;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-use Mouse::Meta::Role::Application::RoleSummation;
+use Mouse::Meta::Role::Application;
use Mouse::Meta::Role::Composite;
{
is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this succeeds as expected';
is_deeply(
is($c->name, 'Role::Foo|Role::FooConflict', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this succeeds as expected';
is_deeply(
is($c->name, 'Role::Foo|Role::Bar|Role::FooConflict|Role::BarConflict', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this succeeds as expected';
is_deeply(
is($c->name, 'Role::Foo|Role::AnotherFooConflict', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this succeeds as expected';
is_deeply(
);
}
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 8;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-use Mouse::Meta::Role::Application::RoleSummation;
+use Mouse::Meta::Role::Application;
use Mouse::Meta::Role::Composite;
{
is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this lives ok';
is_deeply(
# test simple overrides w/ conflicts
dies_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply(
+ Mouse::Meta::Role::Application->new->apply(
Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
# test simple overrides w/ conflicts
dies_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply(
+ Mouse::Meta::Role::Application->new->apply(
Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
# test simple overrides w/ conflicts
dies_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply(
+ Mouse::Meta::Role::Application->new->apply(
Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
# test simple overrides w/ conflicts
dies_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply(
+ Mouse::Meta::Role::Application->new->apply(
Mouse::Meta::Role::Composite->new(
roles => [
Role::Foo->meta,
)
);
} '... this fails as expected';
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 7;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-use Mouse::Meta::Role::Application::RoleSummation;
+use Mouse::Meta::Role::Application;
use Mouse::Meta::Role::Composite;
{
is($c->name, 'Role::Foo|Role::Bar', '... got the composite role name');
lives_ok {
- Mouse::Meta::Role::Application::RoleSummation->new->apply($c);
+ Mouse::Meta::Role::Application->new->apply($c);
} '... this succeeds as expected';
is_deeply(
'... got the right list of methods'
);
}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 17;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
{
isnt( ClassA->foo, "ClassB::foo", "ClassA::foo is not confused with ClassB::foo");
-{
- local $TODO =
- "multiply-consumed roles' subs take on their most recently used name";
- is( ClassB->foo, 'ClassB::foo', 'ClassB::foo knows its name' );
- is( ClassA->foo, 'ClassA::foo', 'ClassA::foo knows its name' );
-}
+is( ClassB->foo, 'Role::Foo::foo', 'ClassB::foo knows its name' );
+is( ClassA->foo, 'Role::Foo::foo', 'ClassA::foo knows its name' );
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use strict;
+use warnings;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+
+do {
+ package My::Meta::Role;
+ use Mouse;
+ BEGIN { extends 'Mouse::Meta::Role' };
+};
+
+do {
+ package My::Role;
+ use Mouse::Role -metaclass => 'My::Meta::Role';
+};
+
+is(My::Role->meta->meta->name, 'My::Meta::Role');
+
+done_testing;
#!/usr/bin/env perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 24;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
do {
package Role::Foo;
my $aliases = $aliases[0];
my $overrides = $overrides[0];
-isa_ok($basic, 'Mouse::Meta::Role::Application::ToClass');
-isa_ok($excludes, 'Mouse::Meta::Role::Application::ToClass');
-isa_ok($aliases, 'Mouse::Meta::Role::Application::ToClass');
-isa_ok($overrides, 'Mouse::Meta::Role::Application::ToClass');
+isa_ok($basic, 'Mouse::Meta::Role::Application');
+isa_ok($excludes, 'Mouse::Meta::Role::Application');
+isa_ok($aliases, 'Mouse::Meta::Role::Application');
+isa_ok($overrides, 'Mouse::Meta::Role::Application');
is($basic->role, Role::Foo->meta);
is($excludes->role, Role::Foo->meta);
is_deeply($aliases->get_method_exclusions, []);
is_deeply($overrides->get_method_exclusions, []);
+done_testing;
#!/usr/bin/env perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 3;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
my $OPTS;
do {
is(My::Class->bar, 'My::Usual::Role', 'collateral role');
is_deeply($OPTS, { number => 1 });
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+{
+ package Bomb;
+ use Mouse::Role;
+
+ sub fuse { }
+ sub explode { }
+
+ package Spouse;
+ use Mouse::Role;
+
+ sub fuse { }
+ sub explode { }
+
+ package Caninish;
+ use Mouse::Role;
+
+ sub bark { }
+
+ package Treeve;
+ use Mouse::Role;
+
+ sub bark { }
+}
+
+{
+ package PracticalJoke;
+ use Mouse;
+
+ ::throws_ok {
+ with 'Bomb', 'Spouse';
+ } qr/Due to method name conflicts in roles 'Bomb' and 'Spouse', the methods 'explode' and 'fuse' must be implemented or excluded by 'PracticalJoke'/;
+
+ ::throws_ok {
+ with (
+ 'Bomb', 'Spouse',
+ 'Caninish', 'Treeve',
+ );
+ } qr/Due to a method name conflict in roles 'Caninish' and 'Treeve', the method 'bark' must be implemented or excluded by 'PracticalJoke'/;
+}
+
+done_testing;
--- /dev/null
+use strict;
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+use Mouse ();
+use Mouse::Meta::Role;
+use Mouse::Util;
+
+my $role1 = Mouse::Meta::Role->initialize('Foo');
+$role1->add_attribute( foo => ( is => 'ro' ) );
+
+ok( $role1->has_attribute('foo'), 'Foo role has a foo attribute' );
+
+my $foo_attr = $role1->get_attribute('foo');
+is(
+ $foo_attr->associated_role->name, 'Foo',
+ 'associated_role for foo attr is Foo role'
+);
+
+isa_ok(
+ $foo_attr->attribute_for_class('Mouse::Meta::Attribute'),
+ 'Mouse::Meta::Attribute',
+ 'attribute returned by ->attribute_for_class'
+);
+
+my $role2 = Mouse::Meta::Role->initialize('Bar');
+$role1->apply($role2);
+
+ok( $role2->has_attribute('foo'), 'Bar role has a foo attribute' );
+
+is(
+ $foo_attr->associated_role->name, 'Foo',
+ 'associated_role for foo attr is still Foo role'
+);
+
+isa_ok(
+ $foo_attr->attribute_for_class('Mouse::Meta::Attribute'),
+ 'Mouse::Meta::Attribute',
+ 'attribute returned by ->attribute_for_class'
+);
+
+my $role3 = Mouse::Meta::Role->initialize('Baz');
+my $combined = Mouse::Meta::Role->combine( [ $role1->name ], [ $role3->name ] );
+
+ok( $combined->has_attribute('foo'), 'combined role has a foo attribute' );
+
+is(
+ $foo_attr->associated_role->name, 'Foo',
+ 'associated_role for foo attr is still Foo role'
+);
+
+done_testing;
--- /dev/null
+use strict;
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+
+{
+ package Foo::Role;
+ use Mouse::Role;
+}
+
+{
+ package Bar::Role;
+ use Mouse::Role;
+}
+
+{
+ package Foo;
+ use Mouse;
+ with 'Foo::Role';
+}
+
+{
+ package Bar;
+ use Mouse;
+ extends 'Foo';
+ with 'Bar::Role';
+}
+
+{
+ package FooBar;
+ use Mouse;
+ with 'Foo::Role', 'Bar::Role';
+}
+
+{
+ package Foo::Role::User;
+ use Mouse::Role;
+ with 'Foo::Role';
+}
+
+{
+ package Foo::User;
+ use Mouse;
+ with 'Foo::Role::User';
+}
+
+is_deeply([sort Foo::Role->meta->consumers],
+ ['Bar', 'Foo', 'Foo::Role::User', 'Foo::User', 'FooBar']);
+is_deeply([sort Bar::Role->meta->consumers],
+ ['Bar', 'FooBar']);
+is_deeply([sort Foo::Role::User->meta->consumers],
+ ['Foo::User']);
+
+done_testing;
--- /dev/null
+use strict;
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+{
+ package My::Role1;
+ use Mouse::Role;
+
+ has foo => (
+ is => 'ro',
+ );
+
+}
+
+{
+ package My::Role2;
+ use Mouse::Role;
+
+ has foo => (
+ is => 'ro',
+ );
+
+ ::throws_ok { with 'My::Role1' } qr/attribute conflict.+My::Role2.+foo/,
+ 'attribute conflict when composing one role into another';
+}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 85;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
use Scalar::Util ();
-use lib 't/lib';
-use Test::Mouse;
use Mouse::Util::TypeConstraints;
ok(!defined($natural->validate(5)), '... validated successfully (no error)');
is($natural->validate(-5),
- "Validation failed for 'Natural' failed with value -5",
+ "Validation failed for 'Natural' with value -5",
'... validated unsuccessfully (got error)');
my $string = find_type_constraint('String');
# sugar was indistinguishable from calling directly.
{
+ no warnings 'redefine';
+ *Mouse::Deprecated::deprecated = sub { return };
+}
+
+{
my $type = type( 'Number2', sub { Scalar::Util::looks_like_number($_) } );
ok( $type->check(5), '... this is a Num' );
ok( ! $subtype->check('Foo'), '... this is not a Natural');
}
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+BEGIN {
+ use_ok('Mouse::Util::TypeConstraints');
+}
+
+foreach my $type_name (qw(
+ Any
+ Item
+ Bool
+ Undef
+ Defined
+ Value
+ Num
+ Int
+ Str
+ Ref
+ ScalarRef
+ ArrayRef
+ HashRef
+ CodeRef
+ RegexpRef
+ Object
+ Role
+ )) {
+ is(find_type_constraint($type_name)->name,
+ $type_name,
+ '... got the right name for ' . $type_name);
+}
+
+# TODO:
+# add tests for is_subtype_of which confirm the hierarchy
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+BEGIN {
+ use_ok('Mouse::Util::TypeConstraints');
+}
+
+{
+ package HTTPHeader;
+ use Mouse;
+
+ has 'array' => (is => 'ro');
+ has 'hash' => (is => 'ro');
+}
+
+subtype Header =>
+ => as Object
+ => where { $_->isa('HTTPHeader') };
+
+coerce Header
+ => from ArrayRef
+ => via { HTTPHeader->new(array => $_[0]) }
+ => from HashRef
+ => via { HTTPHeader->new(hash => $_[0]) };
+
+
+Mouse::Util::TypeConstraints->export_type_constraints_as_functions();
+
+my $header = HTTPHeader->new();
+isa_ok($header, 'HTTPHeader');
+
+ok(Header($header), '... this passed the type test');
+ok(!Header([]), '... this did not pass the type test');
+ok(!Header({}), '... this did not pass the type test');
+
+my $anon_type = subtype Object => where { $_->isa('HTTPHeader') };
+
+lives_ok {
+ coerce $anon_type
+ => from ArrayRef
+ => via { HTTPHeader->new(array => $_[0]) }
+ => from HashRef
+ => via { HTTPHeader->new(hash => $_[0]) };
+} 'coercion of anonymous subtype succeeds';
+
+foreach my $coercion (
+ find_type_constraint('Header')->coercion,
+ $anon_type->coercion
+ ) {
+
+ isa_ok($coercion, 'Mouse::Meta::TypeCoercion');
+
+ {
+ my $coerced = $coercion->coerce([ 1, 2, 3 ]);
+ isa_ok($coerced, 'HTTPHeader');
+
+ is_deeply(
+ $coerced->array(),
+ [ 1, 2, 3 ],
+ '... got the right array');
+ is($coerced->hash(), undef, '... nothing assigned to the hash');
+ }
+
+ {
+ my $coerced = $coercion->coerce({ one => 1, two => 2, three => 3 });
+ isa_ok($coerced, 'HTTPHeader');
+
+ is_deeply(
+ $coerced->hash(),
+ { one => 1, two => 2, three => 3 },
+ '... got the right hash');
+ is($coerced->array(), undef, '... nothing assigned to the array');
+ }
+
+ {
+ my $scalar_ref = \(my $var);
+ my $coerced = $coercion->coerce($scalar_ref);
+ is($coerced, $scalar_ref, '... got back what we put in');
+ }
+
+ {
+ my $coerced = $coercion->coerce("Foo");
+ is($coerced, "Foo", '... got back what we put in');
+ }
+}
+
+subtype 'StrWithTrailingX'
+ => as 'Str'
+ => where { /X$/ };
+
+coerce 'StrWithTrailingX'
+ => from 'Str'
+ => via { $_ . 'X' };
+
+my $tc = find_type_constraint('StrWithTrailingX');
+is($tc->coerce("foo"), "fooX", "coerce when needed");
+is($tc->coerce("fooX"), "fooX", "do not coerce when unneeded");
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 35;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
BEGIN {
ok(!$Undef->check('String'), '... Undef cannot accept an Str value');
ok($Undef->check(undef), '... Undef can accept an Undef value');
-my $Str_or_Undef = Mouse::Meta::TypeConstraint::Union->new(type_constraints => [$Str, $Undef]);
-isa_ok($Str_or_Undef, 'Mouse::Meta::TypeConstraint::Union');
+my $Str_or_Undef = Mouse::Meta::TypeConstraint->new(type_constraints => [$Str, $Undef]);
+isa_ok($Str_or_Undef, 'Mouse::Meta::TypeConstraint');
ok($Str_or_Undef->check(undef), '... (Str | Undef) can accept an Undef value');
ok($Str_or_Undef->check('String'), '... (Str | Undef) can accept a String value');
ok($Str_or_Undef->is_a_type_of($Str), "subtype of Str");
ok($Str_or_Undef->is_a_type_of($Undef), "subtype of Undef");
+cmp_ok($Str_or_Undef->find_type_for('String'), 'eq', 'Str', 'find_type_for Str');
+cmp_ok($Str_or_Undef->find_type_for(undef), 'eq', 'Undef', 'find_type_for Undef');
+ok(!defined($Str_or_Undef->find_type_for(sub { })), 'no find_type_for CodeRef');
+
ok( !$Str_or_Undef->equals($Str), "not equal to Str" );
ok( $Str_or_Undef->equals($Str_or_Undef), "equal to self" );
-ok( $Str_or_Undef->equals(Mouse::Meta::TypeConstraint::Union->new(type_constraints => [ $Str, $Undef ])), "equal to clone" );
-ok( $Str_or_Undef->equals(Mouse::Meta::TypeConstraint::Union->new(type_constraints => [ $Undef, $Str ])), "equal to reversed clone" );
+ok( $Str_or_Undef->equals(Mouse::Meta::TypeConstraint->new(type_constraints => [ $Str, $Undef ])), "equal to clone" );
+ok( $Str_or_Undef->equals(Mouse::Meta::TypeConstraint->new(type_constraints => [ $Undef, $Str ])), "equal to reversed clone" );
ok( !$Str_or_Undef->is_a_type_of("ThisTypeDoesNotExist"), "not type of non existant type" );
ok( !$Str_or_Undef->is_subtype_of("ThisTypeDoesNotExist"), "not subtype of non existant type" );
ok($HashRef->check({}), '... HashRef can accept an {} value');
ok(!$HashRef->check([]), '... HashRef cannot accept an [] value');
-my $HashOrArray = Mouse::Meta::TypeConstraint::Union->new(type_constraints => [$ArrayRef, $HashRef]);
-isa_ok($HashOrArray, 'Mouse::Meta::TypeConstraint::Union');
+my $HashOrArray = Mouse::Meta::TypeConstraint->new(type_constraints => [$ArrayRef, $HashRef]);
+isa_ok($HashOrArray, 'Mouse::Meta::TypeConstraint');
ok($HashOrArray->check([]), '... (ArrayRef | HashRef) can accept []');
ok($HashOrArray->check({}), '... (ArrayRef | HashRef) can accept {}');
ok(!defined($HashOrArray->validate({})), '... (ArrayRef | HashRef) can accept {}');
like($HashOrArray->validate(\(my $var2)),
-qr/Validation failed for \'ArrayRef\' failed with value SCALAR\(0x.+?\) and Validation failed for \'HashRef\' failed with value SCALAR\(0x.+?\) in \(ArrayRef\|HashRef\)/,
+qr/Validation failed for \'ArrayRef\' with value SCALAR\(0x.+?\) and Validation failed for \'HashRef\' with value SCALAR\(0x.+?\) in \(ArrayRef\|HashRef\)/,
'... (ArrayRef | HashRef) cannot accept scalar refs');
like($HashOrArray->validate(sub {}),
-qr/Validation failed for \'ArrayRef\' failed with value CODE\(0x.+?\) and Validation failed for \'HashRef\' failed with value CODE\(0x.+?\) in \(ArrayRef\|HashRef\)/,
+qr/Validation failed for \'ArrayRef\' with value CODE\(0x.+?\) and Validation failed for \'HashRef\' with value CODE\(0x.+?\) in \(ArrayRef\|HashRef\)/,
'... (ArrayRef | HashRef) cannot accept code refs');
is($HashOrArray->validate(50),
-'Validation failed for \'ArrayRef\' failed with value 50 and Validation failed for \'HashRef\' failed with value 50 in (ArrayRef|HashRef)',
+'Validation failed for \'ArrayRef\' with value 50 and Validation failed for \'HashRef\' with value 50 in (ArrayRef|HashRef)',
'... (ArrayRef | HashRef) cannot accept Numbers');
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
BEGIN {
use_ok('Mouse::Util::TypeConstraints');
+ use_ok('Mouse::Meta::TypeConstraint');
}
my $r = Mouse::Util::TypeConstraints->get_type_constraint_registry;
# Array of Ints
-my $array_of_ints = Mouse::Meta::TypeConstraint::Parameterized->new(
+my $array_of_ints = Mouse::Meta::TypeConstraint->new(
name => 'ArrayRef[Int]',
parent => find_type_constraint('ArrayRef'),
type_parameter => find_type_constraint('Int'),
);
-isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized');
+isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint');
isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint');
$r->add_type_constraint($array_of_ints);
# Hash of Ints
-my $hash_of_ints = Mouse::Meta::TypeConstraint::Parameterized->new(
+my $hash_of_ints = Mouse::Meta::TypeConstraint->new(
name => 'HashRef[Int]',
parent => find_type_constraint('HashRef'),
type_parameter => find_type_constraint('Int'),
);
-isa_ok($hash_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized');
+isa_ok($hash_of_ints, 'Mouse::Meta::TypeConstraint');
isa_ok($hash_of_ints, 'Mouse::Meta::TypeConstraint');
$r->add_type_constraint($hash_of_ints);
is_deeply([ sort @{$foo->bar} ], [ 1, 2, 3 ], '... our coercion worked!');
-
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 33;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
BEGIN {
use_ok('Mouse::Util::TypeConstraints');
- use_ok('Mouse::Meta::TypeConstraint::Parameterized');
+ use_ok('Mouse::Meta::TypeConstraint');
}
my $r = Mouse::Util::TypeConstraints->get_type_constraint_registry;
# Array of Ints or Strings
my $array_of_ints_or_strings = Mouse::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int|Str]');
-isa_ok($array_of_ints_or_strings, 'Mouse::Meta::TypeConstraint::Parameterized');
+isa_ok($array_of_ints_or_strings, 'Mouse::Meta::TypeConstraint');
ok($array_of_ints_or_strings->check([ 1, 'two', 3 ]), '... this passed the type check');
ok($array_of_ints_or_strings->check([ 1, 2, 3 ]), '... this passed the type check');
# Array of Ints or HashRef
my $array_of_ints_or_hash_ref = Mouse::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int | HashRef]');
-isa_ok($array_of_ints_or_hash_ref, 'Mouse::Meta::TypeConstraint::Parameterized');
+isa_ok($array_of_ints_or_hash_ref, 'Mouse::Meta::TypeConstraint');
ok($array_of_ints_or_hash_ref->check([ 1, {}, 3 ]), '... this passed the type check');
ok($array_of_ints_or_hash_ref->check([ 1, 2, 3 ]), '... this passed the type check');
# we have, so we have to do it by hand - SL
my $pure_insanity = Mouse::Util::TypeConstraints::create_type_constraint_union('ArrayRef[Int|Str] | ArrayRef[Int | HashRef]');
-isa_ok($pure_insanity, 'Mouse::Meta::TypeConstraint::Union');
+isa_ok($pure_insanity, 'Mouse::Meta::TypeConstraint');
ok($pure_insanity->check([ 1, {}, 3 ]), '... this passed the type check');
ok($pure_insanity->check([ 1, 'Str', 3 ]), '... this passed the type check');
# Array of Ints
my $array_of_ints = Mouse::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[Int]');
-isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized');
+isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint');
isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint');
ok($array_of_ints->check([ 1, 2, 3, 4 ]), '... [ 1, 2, 3, 4 ] passed successfully');
# Array of Array of Ints
my $array_of_array_of_ints = Mouse::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[ArrayRef[Int]]');
-isa_ok($array_of_array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized');
+isa_ok($array_of_array_of_ints, 'Mouse::Meta::TypeConstraint');
isa_ok($array_of_array_of_ints, 'Mouse::Meta::TypeConstraint');
ok($array_of_array_of_ints->check(
# Array of Array of Array of Ints
my $array_of_array_of_array_of_ints = Mouse::Util::TypeConstraints::create_parameterized_type_constraint('ArrayRef[ArrayRef[ArrayRef[Int]]]');
-isa_ok($array_of_array_of_array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized');
+isa_ok($array_of_array_of_array_of_ints, 'Mouse::Meta::TypeConstraint');
isa_ok($array_of_array_of_array_of_ints, 'Mouse::Meta::TypeConstraint');
ok($array_of_array_of_array_of_ints->check(
[[[ 1, 2, 3 ]], [[ qw/foo bar/ ]]]
), '... [[[ 1, 2, 3 ]], [[ qw/foo bar/ ]]] failed successfully');
-
-
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 41;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
BEGIN {
use_ok("Mouse::Util::TypeConstraints");
'... this correctly split the union (' . $_ . ')'
) for keys %split_tests;
}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 39;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
BEGIN {
is($t->name, 'MySpecialHash', '... name is correct');
my $p = $t->parent;
- isa_ok($p, 'Mouse::Meta::TypeConstraint::Parameterized');
+ isa_ok($p, 'Mouse::Meta::TypeConstraint');
isa_ok($p, 'Mouse::Meta::TypeConstraint');
is($p->name, 'HashRef[Int]', '... parent name is correct');
is($t->name, 'MySpecialHashExtended', '... name is correct');
my $p = $t->parent;
- isa_ok($p, 'Mouse::Meta::TypeConstraint::Parameterized');
+ isa_ok($p, 'Mouse::Meta::TypeConstraint');
isa_ok($p, 'Mouse::Meta::TypeConstraint');
is($p->name, 'HashRef[Int]', '... parent name is correct');
my $t = find_type_constraint('MyNonSpecialHash');
isa_ok($t, 'Mouse::Meta::TypeConstraint');
- isa_ok($t, 'Mouse::Meta::TypeConstraint::Parameterizable');
+ isa_ok($t, 'Mouse::Meta::TypeConstraint');
ok( $t->check({ one => 1, two => "foo", three => [] }), "validated" );
ok( !$t->check({ one => 1 }), "failed" );
as 'SubOfMyArrayRef[Str]';
}, qr/Str is not a subtype of BiggerInt/, 'Failed to parameterize with a bad type parameter';
}
+
+{
+ my $RefToInt = subtype as 'ScalarRef[Int]';
+
+ ok $RefToInt->check(\1), '\1 is okay';
+ ok !$RefToInt->check(1), '1 is not';
+ ok !$RefToInt->check(\"foo"), '\"foo" is not';
+}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 11;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
BEGIN {
use_ok("Mouse::Util::TypeConstraints");
- use_ok('Mouse::Meta::TypeConstraint::Parameterized');
+ use_ok('Mouse::Meta::TypeConstraint');
}
BEGIN {
ok(!$evenlist->check(MyList->new(10, "two")), '... validated it correctly (fail)');
ok(!$evenlist->check([10, 20]), '... validated it correctly (fail)');
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 20;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
BEGIN {
is( $type->class, "Foo", "class attribute" );
+ok( !$type->is_subtype_of('Foo'), "Foo is not subtype of Foo" );
+ok( !$type->is_subtype_of($type), '$foo_type is not subtype of $foo_type' );
+
ok( $type->is_subtype_of("Gorch"), "subtype of gorch" );
ok( $type->is_subtype_of("Bar"), "subtype of bar" );
ok( $type->equals($type), "equals self" );
-ok( $type->equals(Mouse::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Foo" )), "equals anon constraint of same value" );
-ok( $type->equals(Mouse::Meta::TypeConstraint::Class->new( name => "Oink", class => "Foo" )), "equals differently named constraint of same value" );
-ok( !$type->equals(Mouse::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "doesn't equal other anon constraint" );
-ok( $type->is_subtype_of(Mouse::Meta::TypeConstraint::Class->new( name => "__ANON__", class => "Bar" )), "subtype of other anon constraint" );
+ok( $type->equals(Mouse::Meta::TypeConstraint->new( name => "__ANON__", class => "Foo" )), "equals anon constraint of same value" );
+ok( $type->equals(Mouse::Meta::TypeConstraint->new( name => "Oink", class => "Foo" )), "equals differently named constraint of same value" );
+ok( !$type->equals(Mouse::Meta::TypeConstraint->new( name => "__ANON__", class => "Bar" )), "doesn't equal other anon constraint" );
+ok( $type->is_subtype_of(Mouse::Meta::TypeConstraint->new( name => "__ANON__", class => "Bar" )), "subtype of other anon constraint" );
+
+{
+ my $regexp_type = Mouse::Meta::TypeConstraint->new(name => 'Regexp', class => 'Regexp');
+ ok(!$regexp_type->check(qr//), 'a Regexp is not an instance of a class, even tho perl pretends it is');
+}
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 36;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
use Mouse::Util::TypeConstraints;
my $type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Int]');
isa_ok($type, 'Mouse::Meta::TypeConstraint');
-isa_ok($type, 'Mouse::Meta::TypeConstraint::Parameterized');
+isa_ok($type, 'Mouse::Meta::TypeConstraint');
ok( $type->equals($type), "equals self" );
ok( !$type->equals($type->parent), "not equal to parent" );
ok( !$type->equals(find_type_constraint("Maybe")), "not equal to Maybe" );
ok( $type->parent->equals(find_type_constraint("Maybe")), "parent is Maybe" );
-ok( $type->equals( Mouse::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" );
-ok( !$type->equals( Mouse::Meta::TypeConstraint::Parameterized->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Str") ) ), "not equal to clone with diff param" );
+ok( $type->equals( Mouse::Meta::TypeConstraint->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" );
+ok( !$type->equals( Mouse::Meta::TypeConstraint->new( name => "__ANON__", parent => find_type_constraint("Maybe"), type_parameter => find_type_constraint("Str") ) ), "not equal to clone with diff param" );
ok( !$type->equals( Mouse::Util::TypeConstraints::find_or_parse_type_constraint('Maybe[Str]') ), "not equal to declarative version of diff param" );
ok($type->check(10), '... checked type correctly (pass)');
{
- package Test::MouseX::Types::Maybe;
+ package Test::MooseX::Types::Maybe;
use Mouse;
has 'Maybe_Int' => (is=>'rw', isa=>'Maybe[Int]');
has 'Maybe_HashRefInt' => (is=>'rw', isa=>'Maybe[HashRef[Int]]');
}
-ok my $obj = Test::MouseX::Types::Maybe->new
+ok my $obj = Test::MooseX::Types::Maybe->new
=> 'Create good test object';
## Maybe[Int]
throws_ok sub { $obj->Maybe_Int("a") },
qr/Attribute \(Maybe_Int\) does not pass the type constraint/
=> 'failed assigned ("a")';
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 18;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
BEGIN {
ok( $type->equals($type), "equals self" );
-ok( $type->equals(Mouse::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Foo" )), "equals anon constraint of same value" );
-ok( $type->equals(Mouse::Meta::TypeConstraint::Role->new( name => "Oink", role => "Foo" )), "equals differently named constraint of same value" );
-ok( !$type->equals(Mouse::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Bar" )), "doesn't equal other anon constraint" );
-ok( $type->is_subtype_of(Mouse::Meta::TypeConstraint::Role->new( name => "__ANON__", role => "Bar" )), "subtype of other anon constraint" );
+ok( $type->equals(Mouse::Meta::TypeConstraint->new( name => "__ANON__", role => "Foo" )), "equals anon constraint of same value" );
+ok( $type->equals(Mouse::Meta::TypeConstraint->new( name => "Oink", role => "Foo" )), "equals differently named constraint of same value" );
+ok( !$type->equals(Mouse::Meta::TypeConstraint->new( name => "__ANON__", role => "Bar" )), "doesn't equal other anon constraint" );
+ok( $type->is_subtype_of(Mouse::Meta::TypeConstraint->new( name => "__ANON__", role => "Bar" )), "subtype of other anon constraint" );
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 37;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
BEGIN {
is $union1->name, $union3->name, 'names match';
is $union2->name, $union3->name, 'names match';
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 26;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
use Mouse::Util::TypeConstraints;
## Create a subclass with a custom method
{
- package Test::Mouse::Meta::TypeConstraint::AnySubType;
+ package Test::Mouse::Meta::TypeConstraint;
use Mouse;
extends 'Mouse::Meta::TypeConstraint';
}
my $Int = find_type_constraint('Int');
-ok $Int, 'Got a good type contstraint';
+ok $Int, 'Got a good type constraint';
-my $parent = Test::Mouse::Meta::TypeConstraint::AnySubType->new({
- name => "Test::Mouse::Meta::TypeConstraint::AnySubType" ,
- parent => $Int,
+my $parent = Test::Mouse::Meta::TypeConstraint->new({
+ name => "Test::Mouse::Meta::TypeConstraint" ,
+ parent => $Int,
});
ok $parent, 'Created type constraint';
ok $isa_foo->check( Foo->new ), 'Foo passes check';
ok $isa_foo->check( Bar->new ), 'Bar passes check';
ok ! $isa_foo->check( Baz->new ), 'Baz does not pass check';
-like $foo->get_message( Baz->new ), qr/^Validation failed for 'Foo' failed with value Baz=HASH\(0x\w+\) \(not isa Foo\)/, 'Better validation message';
+like $foo->get_message( Baz->new ), qr/^Validation failed for 'Foo' with value Baz=HASH\(0x\w+\) \(not isa Foo\)/, 'Better validation message';
# Maybe in the future this *should* inherit?
-like $isa_foo->get_message( Baz->new ), qr/^Validation failed for 'IsaFoo' failed with value Baz=HASH\(0x\w+\)$/, "Subtypes do not automatically inherit parent type's message";
+like $isa_foo->get_message( Baz->new ), qr/^Validation failed for 'IsaFoo' with value Baz=HASH\(0x\w+\)$/, "Subtypes do not automatically inherit parent type's message";
# Implicit types
throws_ok {
Quux->new(age => 3)
-} qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' failed with value 3 \(not isa Positive\)/;
+} qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' with value 3 \(not isa Positive\)/;
lives_ok {
Quux->new(age => (bless {}, 'Positive'));
throws_ok {
Quux->new(age => 3)
-} qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' failed with value 3 \(not isa Positive\)/;
+} qr/^Attribute \(age\) does not pass the type constraint because: Validation failed for 'Positive' with value 3 \(not isa Positive\)/;
lives_ok {
Quux->new(age => Positive->new)
lives_ok {
Quux::Ier->new(age => (bless {}, 'Negative'))
};
+
+done_testing;
use strict;
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use warnings;
-use Test::More tests => 6;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
use Mouse::Meta::TypeConstraint;
is( Mouse::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Va.lid]'),
'ArrayRef[Va.lid]',
'find_or_parse_type_constraint returns name for valid name' );
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
my @phonograph;
$t->walk;
is_deeply([splice @phonograph], ['footsteps']);
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 25;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
use Mouse::Util::TypeConstraints;
not_enough_matches( [] )
} qr/No cases matched for /, '... not enough matches';
-
-
-
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 4;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-
=pod
This test demonstrates that Mouse will respect
use strict;
use warnings;
- use base 'Class::MOP::Class';
+ use base 'Mouse::Meta::Class';
package Bar;
use strict;
qr/^Bar already has a metaclass, but it does not inherit Mouse::Meta::Class/,
'... got the right error too');
}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 7;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-
BEGIN {
package MyFramework::Base;
use Mouse;
package MyFramework;
use Mouse;
+ use Mouse::Deprecated -api_version => '0.55';
sub import {
my $CALLER = caller();
is($obj->foo, 10, '... got the right value');
-
-
-
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 8;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
# Some packages out in the wild cooperate with Mouse by using goto
# &Mouse::import. we want to make sure it still works.
{
- package MouseAlike1;
+ package MooseAlike1;
use strict;
use warnings;
{
package Foo;
- MouseAlike1->import();
+ MooseAlike1->import();
::lives_ok( sub { has( 'size', is => 'bare' ) },
- 'has was exported via MouseAlike1' );
+ 'has was exported via MooseAlike1' );
- MouseAlike1->unimport();
+ MooseAlike1->unimport();
}
ok( ! Foo->can('has'),
- 'No has sub in Foo after MouseAlike1 is unimported' );
+ 'No has sub in Foo after MooseAlike1 is unimported' );
ok( Foo->can('meta'),
'Foo has a meta method' );
isa_ok( Foo->meta(), 'Mouse::Meta::Class' );
{
- package MouseAlike2;
+ package MooseAlike2;
use strict;
use warnings;
{
package Bar;
- MouseAlike2->import();
+ MooseAlike2->import();
::lives_ok( sub { has( 'size', is => 'bare' ) },
- 'has was exported via MouseAlike2' );
+ 'has was exported via MooseAlike2' );
- MouseAlike2->unimport();
+ MooseAlike2->unimport();
}
ok( ! Bar->can('has'),
- 'No has sub in Bar after MouseAlike2 is unimported' );
+ 'No has sub in Bar after MooseAlike2 is unimported' );
ok( Bar->can('meta'),
'Bar has a meta method' );
isa_ok( Bar->meta(), 'Mouse::Meta::Class' );
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
use lib 't/lib', 'lib';
-use Test::More 'no_plan';
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
use Mouse::Util::MetaRole;
}
{
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => My::Class->meta,
- metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => My::Class->meta,
+ class_metaroles => { class => ['Role::Foo'] },
);
ok( My::Class->meta()->meta()->does_role('Role::Foo'),
}
{
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class',
- attribute_metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class',
+ class_metaroles => { attribute => ['Role::Foo'] },
);
ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
}
{
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class',
- method_metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class',
+ class_metaroles => { method => ['Role::Foo'] },
);
ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
}
{
- last; # skip
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class',
- wrapped_method_metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class',
+ class_metaroles => { wrapped_method => ['Role::Foo'] },
);
ok( My::Class->meta()->wrapped_method_metaclass()->meta()->does_role('Role::Foo'),
}
{
- last; # skip
-
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class',
- instance_metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class',
+ class_metaroles => { instance => ['Role::Foo'] },
);
ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
}
{
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class',
- constructor_class_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class',
+ class_metaroles => { constructor => ['Role::Foo'] },
);
ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
q{... My::Class->meta()'s method metaclass still does Role::Foo} );
-# ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
-# q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
+ ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
# Actually instantiating the constructor class is too freaking hard!
ok( My::Class->meta()->constructor_class()->can('foo'),
}
{
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class',
- destructor_class_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class',
+ class_metaroles => { destructor => ['Role::Foo'] },
);
ok( My::Class->meta()->destructor_class()->meta()->does_role('Role::Foo'),
q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
q{... My::Class->meta()'s method metaclass still does Role::Foo} );
-# ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
-# q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
+ ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
q{... My::Class->meta()'s constructor class still does Role::Foo} );
}
{
- last; # skip
-
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Role',
- application_to_class_class_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Role',
+ role_metaroles => { application_to_class => ['Role::Foo'] },
);
ok( My::Role->meta->application_to_class_class->meta->does_role('Role::Foo'),
}
{
- last; # skip
-
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Role',
- application_to_role_class_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Role',
+ role_metaroles => { application_to_role => ['Role::Foo'] },
);
ok( My::Role->meta->application_to_role_class->meta->does_role('Role::Foo'),
}
{
- last; # skip
-
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Role',
- application_to_instance_class_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Role',
+ role_metaroles => { application_to_instance => ['Role::Foo'] },
);
ok( My::Role->meta->application_to_instance_class->meta->does_role('Role::Foo'),
{
Mouse::Util::MetaRole::apply_base_class_roles(
- for_class => 'My::Class',
- roles => ['Role::Foo'],
+ for => 'My::Class',
+ roles => ['Role::Foo'],
);
ok( My::Class->meta()->does_role('Role::Foo'),
}
{
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class2',
- metaclass_roles => ['Role::Foo'],
- attribute_metaclass_roles => ['Role::Foo'],
- method_metaclass_roles => ['Role::Foo'],
- instance_metaclass_roles => ['Role::Foo'],
- constructor_class_roles => ['Role::Foo'],
- destructor_class_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class2',
+ class_metaroles => {
+ class => ['Role::Foo'],
+ attribute => ['Role::Foo'],
+ method => ['Role::Foo'],
+ instance => ['Role::Foo'],
+ constructor => ['Role::Foo'],
+ destructor => ['Role::Foo'],
+ },
);
ok( My::Class2->meta()->meta()->does_role('Role::Foo'),
is( My::Class2->meta()->get_method('bar')->foo(), 10,
'... call foo() on a method metaclass object' );
-# ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
-# q{apply Role::Foo to My::Class2->meta()'s instance metaclass} );
-# is( My::Class2->meta()->get_meta_instance()->foo(), 10,
-# '... call foo() on an instance metaclass object' );
+ ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s instance metaclass} );
+ is( My::Class2->meta()->get_meta_instance()->foo(), 10,
+ '... call foo() on an instance metaclass object' );
ok( My::Class2->meta()->constructor_class()->meta()->does_role('Role::Foo'),
q{apply Role::Foo to My::Class2->meta()'s constructor class} );
{
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class3',
- metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class3',
+ class_metaroles => { class => ['Role::Foo'] },
);
ok( My::Class3->meta()->meta()->does_role('Role::Foo'),
is( My::Class3->meta()->foo(), 10,
'... and call foo() on that meta object' );
ok( ( grep { $_ eq 'My::Meta::Class' } My::Class3->meta()->meta()->superclasses() ),
- 'apply_metaclass_roles() does not interfere with metaclass set via Mouse->init_meta()' );
+ 'apply_metaroles() does not interfere with metaclass set via Mouse->init_meta()' );
}
{
}
{
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class4',
- metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class4',
+ class_metaroles => { class => ['Role::Foo'] },
);
ok( My::Class4->meta()->meta()->does_role('Role::Foo'),
'apply Role::Foo to My::Class4->meta()' );
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class4',
- metaclass_roles => ['Role::Bar'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class4',
+ class_metaroles => { class => ['Role::Bar'] },
);
ok( My::Class4->meta()->meta()->does_role('Role::Bar'),
{
package My::Class5;
use Mouse;
-
+
extends 'My::Class';
}
ok( My::Class5->meta()->destructor_class()->meta()->does_role('Role::Foo'),
q{My::Class5->meta()'s destructor class also does Role::Foo} );
}
-exit;
+
{
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class5',
- metaclass_roles => ['Role::Bar'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class5',
+ class_metaroles => { class => ['Role::Bar'] },
);
ok( My::Class5->meta()->meta()->does_role('Role::Bar'),
package My::Class6;
use Mouse;
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class6',
- metaclass_roles => ['Role::Bar'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class6',
+ class_metaroles => { class => ['Role::Bar'] },
);
extends 'My::Class';
use Mouse;
# In real usage this would go in a BEGIN block so it happened
- # before apply_metaclass_roles was called by an extension.
+ # before apply_metaroles was called by an extension.
extends 'My::Class';
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class7',
- metaclass_roles => ['Role::Bar'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class7',
+ class_metaroles => { class => ['Role::Bar'] },
);
}
package My::Class8;
use Mouse;
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class8',
- metaclass_roles => ['Role::Bar'],
- attribute_metaclass_roles => ['Role::Bar'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class8',
+ class_metaroles => {
+ class => ['Role::Bar'],
+ attribute => ['Role::Bar'],
+ },
);
extends 'My::Class';
package My::Class9;
use Mouse;
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class9',
- attribute_metaclass_roles => ['Role::Bar'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class9',
+ class_metaroles => { attribute => ['Role::Bar'] },
);
extends 'My::Class';
# This tests applying meta roles to a metaclass's metaclass. This is
# completely insane, but is exactly what happens with
# Fey::Meta::Class::Table. It's a subclass of Mouse::Meta::Class
-# itself, and then it _uses_ MouseX::ClassAttribute, so the metaclass
+# itself, and then it _uses_ MooseX::ClassAttribute, so the metaclass
# for Fey::Meta::Class::Table does a role.
#
# At one point this caused a metaclass incompatibility error down
use Mouse;
extends 'Mouse::Meta::Class';
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Meta::Class2',
- metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Meta::Class2',
+ class_metaroles => { class => ['Role::Foo'] },
);
}
package My::Class10;
My::Meta2->import;
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class10',
- metaclass_roles => ['Role::Bar'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class10',
+ class_metaroles => { class => ['Role::Bar'] },
);
}
{
package My::Constructor;
- use base 'Mouse::Meta::Method::Constructor';
+ use base 'Mouse::Meta::Method';
}
{
__PACKAGE__->meta->constructor_class('My::Constructor');
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class11',
- metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class11',
+ class_metaroles => { class => ['Role::Foo'] },
);
}
}
{
- package ExportsMouse;
+ package ExportsMoose;
Mouse::Exporter->setup_import_methods(
- also => 'Mouse',
+ also => 'Mouse',
);
sub init_meta {
shift;
my %p = @_;
Mouse->init_meta(%p);
- return Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => $p{for_class},
+ return Mouse::Util::MetaRole::apply_metaroles(
+ for => $p{for_class},
# Causes us to recurse through init_meta, as we have to
# load MyMetaclassRole from disk.
- metaclass_roles => [qw/MyMetaclassRole/],
+ class_metaroles => { class => [qw/MyMetaclassRole/] },
);
}
}
lives_ok {
- package UsesExportedMouse;
- ExportsMouse->import;
+ package UsesExportedMoose;
+ ExportsMoose->import;
} 'import module which loads a role from disk during init_meta';
{
use Mouse::Role;
}
+
{
package Foo::Role;
Mouse::Exporter->setup_import_methods(
- also => 'Mouse::Role',
+ also => 'Mouse::Role',
);
sub init_meta {
shift;
my %p = @_;
+
Mouse::Role->init_meta(%p);
- return Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => $p{for_class},
- method_metaclass_roles => [ 'Foo::Meta::Role', ],
+
+ return Mouse::Util::MetaRole::apply_metaroles(
+ for => $p{for_class},
+ role_metaroles => { method => ['Foo::Meta::Role'] },
);
}
}
+
{
package Role::Baz;
sub bla {}
}
+
{
package My::Class12;
with( 'Role::Baz' );
}
+
{
ok(
My::Class12->meta->does_role( 'Role::Baz' ),
'role applied'
);
+
my $method = My::Class12->meta->get_method( 'bla' );
ok(
$method->meta->does_role( 'Foo::Meta::Role' ),
package Parent;
use Mouse;
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => __PACKAGE__,
- constructor_class_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => { constructor => ['Role::Foo'] },
);
}
'Parent constructor class has metarole from Parent'
);
-TODO:
- {
- local $TODO
- = 'Mouse does not see that the child differs from the parent because it only checks the class and instance metaclasses do determine compatibility';
- ok(
- Child->meta->constructor_class->meta->can('does_role')
- && Child->meta->constructor_class->meta->does_role(
- 'Role::Foo'),
- 'Child constructor class has metarole from Parent'
- );
- }
+ ok(
+ Child->meta->constructor_class->meta->can('does_role')
+ && Child->meta->constructor_class->meta->does_role(
+ 'Role::Foo'),
+ 'Child constructor class has metarole from Parent'
+ );
}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 8;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Mouse::Util::MetaRole;
}
{
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class',
- metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class',
+ class_metaroles => { class => ['Role::Foo'] },
);
ok( My::Class->meta()->meta()->does_role('Role::Foo'),
'apply Role::Foo to My::Class->meta()' );
has_superclass( My::Class->meta(), 'My::Meta::Class',
- 'apply_metaclass_roles works with metaclass.pm' );
+ 'apply_metaroles works with metaclass.pm' );
}
{
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => 'My::Class2',
- attribute_metaclass_roles => ['Role::Foo'],
- method_metaclass_roles => ['Role::Foo'],
- instance_metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => 'My::Class2',
+ class_metaroles => {
+ attribute => ['Role::Foo'],
+ method => ['Role::Foo'],
+ instance => ['Role::Foo'],
+ },
);
ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
ok( $supers{$parent}, $desc );
}
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 24;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
{
has foo => ( is => "ro" );
- package Baz::Error;
- use Mouse;
-
- has message => ( isa => "Str", is => "ro" );
- has attr => ( isa => "Mouse::Meta::Attribute", is => "ro" );
- has method => ( isa => "Mouse::Meta::Method", is => "ro" );
- has metaclass => ( isa => "Mouse::Meta::Class", is => "ro" );
- has data => ( is => "ro" );
- has line => ( isa => "Int", is => "ro" );
- has file => ( isa => "Str", is => "ro" );
- has last_error => ( isa => "Any", is => "ro" );
+ BEGIN {
+ package Baz::Error;
+ use Mouse;
+ extends 'Mouse::Object', 'Mouse::Error::Default';
+
+ has message => ( isa => "Str", is => "ro" );
+ has attr => ( isa => "Mouse::Meta::Attribute", is => "ro" );
+ has method => ( isa => "Mouse::Meta::Method", is => "ro" );
+ has metaclass => ( isa => "Mouse::Meta::Class", is => "ro" );
+ has data => ( is => "ro" );
+ has line => ( isa => "Int", is => "ro" );
+ has file => ( isa => "Str", is => "ro" );
+ has last_error => ( isa => "Any", is => "ro" );
+ }
package Baz;
use metaclass (
use Mouse;
extends 'Baz';
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => __PACKAGE__,
- metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => { class => ['Role::Foo'] },
);
}
use Mouse;
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => __PACKAGE__,
- metaclass_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => { class => ['Role::Foo'] },
);
}
::lives_ok { extends 'Foo::Sub' } 'error_class differs by role so incompat is handled';
- Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => __PACKAGE__,
- error_class_roles => ['Role::Foo'],
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => { error => ['Role::Foo'] },
);
}
q{Foo::Sub::Sub's error_class does Role::Foo} );
ok( Foo::Sub::Sub->meta->error_class->isa('Mouse::Error::Croak'),
q{Foo::Sub::Sub's error_class now subclasses Mouse::Error::Croak} );
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
# this functionality may be pushing toward parametric roles/classes
# it's off in a corner and may not be that important
use strict;
use warnings;
-use Test::More tests => 15;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
{
die $@ if $@;
} 'failed to use trait without required attr';
+done_testing;
#!/usr/bin/env perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 2;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
do {
package My::Meta::Class;
is(My::Class->meta->meta->name, 'My::Meta::Class');
is(My::Class::Aliased->meta->meta->name, 'My::Meta::Class');
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 13;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Mouse qw(does_ok);
{
use Mouse::Exporter;
Mouse::Exporter->setup_import_methods(
- metaclass_roles => ['Foo::Trait::Class'],
- attribute_metaclass_roles => ['Foo::Trait::Attribute'],
- base_class_roles => ['Foo::Role::Base'],
+ class_metaroles => {
+ class => ['Foo::Trait::Class'],
+ attribute => ['Foo::Trait::Attribute'],
+ },
+ role_metaroles => { role => ['Foo::Trait::Class'] },
+ base_class_roles => ['Foo::Role::Base'],
);
}
}
{
- package Foo::Exporter::WithMouse;
+ package Foo::Exporter::WithMoose;
use Mouse ();
use Mouse::Exporter;
- my ($import, $unimport, $init_meta) =
- Mouse::Exporter->build_import_methods(
- also => 'Mouse',
- metaclass_roles => ['Foo::Trait::Class'],
- attribute_metaclass_roles => ['Foo::Trait::Attribute'],
- base_class_roles => ['Foo::Role::Base'],
- install => [qw(import unimport)],
+ my ( $import, $unimport, $init_meta )
+ = Mouse::Exporter->build_import_methods(
+ also => 'Mouse',
+ class_metaroles => {
+ class => ['Foo::Trait::Class'],
+ attribute => ['Foo::Trait::Attribute'],
+ },
+ base_class_roles => ['Foo::Role::Base'],
+ install => [qw(import unimport)],
);
sub init_meta {
{
package Foo2;
- Foo::Exporter::WithMouse->import;
+ Foo::Exporter::WithMoose->import;
has(foo => (is => 'ro'));
}
{
- package Foo::Exporter::WithMouseRole;
+ package Foo::Exporter::WithMooseRole;
use Mouse::Role ();
use Mouse::Exporter;
- my ($import, $unimport, $init_meta) =
- Mouse::Exporter->build_import_methods(
- also => 'Mouse::Role',
- metaclass_roles => ['Foo::Trait::Class'],
- attribute_metaclass_roles => ['Foo::Trait::Attribute'],
- base_class_roles => ['Foo::Role::Base'],
- install => [qw(import unimport)],
+ my ( $import, $unimport, $init_meta )
+ = Mouse::Exporter->build_import_methods(
+ also => 'Mouse::Role',
+ role_metaroles => {
+ role => ['Foo::Trait::Class'],
+ attribute => ['Foo::Trait::Attribute'],
+ },
+ install => [qw(import unimport)],
);
sub init_meta {
{
package Foo2::Role;
- Foo::Exporter::WithMouseRole->import;
+ Foo::Exporter::WithMooseRole->import;
::isa_ok(Foo2::Role->meta, 'Mouse::Meta::Role');
::does_ok(Foo2::Role->meta, 'Foo::Trait::Class');
}
+
+done_testing;
use strict;
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use warnings;
use Test::More;
+$TODO = q{Mouse is not yet completed};
our @applications;
around apply_params => sub {
my ( $next, $self, @args ) = @_;
- return Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => $self->$next(@args),
- application_to_class_class_roles =>
- ['CustomApplication::Composite::ToClass'],
- application_to_role_class_roles =>
- ['CustomApplication::Composite::ToRole'],
- application_to_instance_class_roles =>
- ['CustomApplication::Composite::ToInstance'],
+ return Mouse::Util::MetaRole::apply_metaroles(
+ for => $self->$next(@args),
+ role_metaroles => {
+ application_to_class =>
+ ['CustomApplication::Composite::ToClass'],
+ application_to_role =>
+ ['CustomApplication::Composite::ToRole'],
+ application_to_instance =>
+ ['CustomApplication::Composite::ToInstance'],
+ },
);
};
}
package Role::WithCustomApplication;
use Mouse::Role;
- has '+composition_class_roles' => (
- default => ['Role::Composite'],
- );
+ around composition_class_roles => sub {
+ my ($orig, $self) = @_;
+ return $self->$orig, 'Role::Composite';
+ };
}
{
sub init_meta {
my ( $self, %options ) = @_;
- return Mouse::Util::MetaRole::apply_metaclass_roles(
- for_class => Mouse::Role->init_meta(%options),
- metaclass_roles => ['Role::WithCustomApplication'],
- application_to_class_class_roles =>
- ['CustomApplication::ToClass'],
- application_to_role_class_roles => ['CustomApplication::ToRole'],
- application_to_instance_class_roles =>
- ['CustomApplication::ToInstance'],
+ return Mouse::Util::MetaRole::apply_metaroles(
+ for => Mouse::Role->init_meta(%options),
+ role_metaroles => {
+ role => ['Role::WithCustomApplication'],
+ application_to_class =>
+ ['CustomApplication::ToClass'],
+ application_to_role => ['CustomApplication::ToRole'],
+ application_to_instance =>
+ ['CustomApplication::ToInstance'],
+ },
);
}
}
);
ok( My::Role::Special->meta->meta->does_role('Role::WithCustomApplication'),
"the role's metaobject has custom applications" );
-is_deeply( My::Role::Special->meta->composition_class_roles,
+is_deeply( [My::Role::Special->meta->composition_class_roles],
['Role::Composite'],
"the role knows about the specified composition class" );
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+# This is a copy of 015_metarole.t taken on 01/01/2010. It provides a
+# comprehensive test of backwards compatibility in the MetaRole API.
use strict;
use warnings;
use lib 't/lib', 'lib';
-use Test::More 'no_plan';
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
use Mouse::Util::MetaRole;
+{
+ no warnings 'redefine';
+ *Mouse::Deprecated::deprecated = sub { return };
+}
{
package My::Meta::Class;
}
{
- last; # skip
Mouse::Util::MetaRole::apply_metaclass_roles(
for_class => 'My::Class',
wrapped_method_metaclass_roles => ['Role::Foo'],
}
{
- last; # skip
-
Mouse::Util::MetaRole::apply_metaclass_roles(
for_class => 'My::Class',
instance_metaclass_roles => ['Role::Foo'],
q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
q{... My::Class->meta()'s method metaclass still does Role::Foo} );
-# ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
-# q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
+ ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
# Actually instantiating the constructor class is too freaking hard!
ok( My::Class->meta()->constructor_class()->can('foo'),
q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
q{... My::Class->meta()'s method metaclass still does Role::Foo} );
-# ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
-# q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
+ ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
q{... My::Class->meta()'s constructor class still does Role::Foo} );
}
{
- last; # skip
-
Mouse::Util::MetaRole::apply_metaclass_roles(
for_class => 'My::Role',
application_to_class_class_roles => ['Role::Foo'],
}
{
- last; # skip
-
Mouse::Util::MetaRole::apply_metaclass_roles(
for_class => 'My::Role',
application_to_role_class_roles => ['Role::Foo'],
}
{
- last; # skip
-
Mouse::Util::MetaRole::apply_metaclass_roles(
for_class => 'My::Role',
application_to_instance_class_roles => ['Role::Foo'],
is( My::Class2->meta()->get_method('bar')->foo(), 10,
'... call foo() on a method metaclass object' );
-# ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
-# q{apply Role::Foo to My::Class2->meta()'s instance metaclass} );
-# is( My::Class2->meta()->get_meta_instance()->foo(), 10,
-# '... call foo() on an instance metaclass object' );
+ ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s instance metaclass} );
+ is( My::Class2->meta()->get_meta_instance()->foo(), 10,
+ '... call foo() on an instance metaclass object' );
ok( My::Class2->meta()->constructor_class()->meta()->does_role('Role::Foo'),
q{apply Role::Foo to My::Class2->meta()'s constructor class} );
{
package My::Class5;
use Mouse;
-
+
extends 'My::Class';
}
ok( My::Class5->meta()->destructor_class()->meta()->does_role('Role::Foo'),
q{My::Class5->meta()'s destructor class also does Role::Foo} );
}
-exit;
+
{
Mouse::Util::MetaRole::apply_metaclass_roles(
for_class => 'My::Class5',
# This tests applying meta roles to a metaclass's metaclass. This is
# completely insane, but is exactly what happens with
# Fey::Meta::Class::Table. It's a subclass of Mouse::Meta::Class
-# itself, and then it _uses_ MouseX::ClassAttribute, so the metaclass
+# itself, and then it _uses_ MooseX::ClassAttribute, so the metaclass
# for Fey::Meta::Class::Table does a role.
#
# At one point this caused a metaclass incompatibility error down
{
package My::Constructor;
- use base 'Mouse::Meta::Method::Constructor';
+ use base 'Mouse::Meta::Method';
}
{
}
{
- package ExportsMouse;
+ package ExportsMoose;
Mouse::Exporter->setup_import_methods(
also => 'Mouse',
}
lives_ok {
- package UsesExportedMouse;
- ExportsMouse->import;
+ package UsesExportedMoose;
+ ExportsMoose->import;
} 'import module which loads a role from disk during init_meta';
{
'Parent constructor class has metarole from Parent'
);
-TODO:
- {
- local $TODO
- = 'Mouse does not see that the child differs from the parent because it only checks the class and instance metaclasses do determine compatibility';
- ok(
- Child->meta->constructor_class->meta->can('does_role')
- && Child->meta->constructor_class->meta->does_role(
- 'Role::Foo'),
- 'Child constructor class has metarole from Parent'
- );
- }
+ ok(
+ Child->meta->constructor_class->meta->can('does_role')
+ && Child->meta->constructor_class->meta->does_role(
+ 'Role::Foo'),
+ 'Child constructor class has metarole from Parent'
+ );
}
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use strict;
+use warnings;
+use lib 't/lib';
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+our $called = 0;
+{
+ package Foo::Trait::Constructor;
+ use Mouse::Role;
+
+ around _generate_BUILDALL => sub {
+ my $orig = shift;
+ my $self = shift;
+ return $self->$orig(@_) . '$::called++;';
+ }
+}
+
+{
+ package Foo;
+ use Mouse;
+ Mouse::Util::MetaRole::apply_metaroles(
+ for => __PACKAGE__,
+ class_metaroles => {
+ constructor => ['Foo::Trait::Constructor'],
+ }
+ );
+}
+
+Foo->new;
+is($called, 0, "no calls before inlining");
+Foo->meta->make_immutable;
+
+Foo->new;
+is($called, 1, "inlined constructor has trait modifications");
+
+ok(Foo->meta->constructor_class->meta->does_role('Foo::Trait::Constructor'),
+ "class has correct constructor traits");
+
+{
+ package Foo::Sub;
+ use Mouse;
+ extends 'Foo';
+}
+
+$called = 0;
+
+Foo::Sub->new;
+is($called, 0, "no calls before inlining");
+
+Foo::Sub->meta->make_immutable;
+
+Foo::Sub->new;
+is($called, 1, "inherits constructor trait properly");
+
+ok(Foo::Sub->meta->constructor_class->meta->can('does_role')
+&& Foo::Sub->meta->constructor_class->meta->does_role('Foo::Trait::Constructor'),
+ "subclass inherits constructor traits");
+
+{
+ package Foo2::Role;
+ use Mouse::Role;
+}
+{
+ package Foo2;
+ use Mouse -traits => ['Foo2::Role'];
+}
+{
+ package Bar2;
+ use Mouse;
+}
+{
+ package Baz2;
+ use Mouse;
+ my $meta = __PACKAGE__->meta;
+ ::lives_ok { $meta->superclasses('Foo2') } "can set superclasses once";
+ ::isa_ok($meta, Foo2->meta->meta->name);
+ ::lives_ok { $meta->superclasses('Bar2') } "can still set superclasses";
+ ::isa_ok($meta, Bar2->meta->meta->name);
+ ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+ ['Foo2::Role'],
+ "still have the role attached");
+ ::ok(!$meta->is_immutable,
+ "immutable superclass doesn't make this class immutable");
+ ::lives_ok { $meta->make_immutable } "can still make immutable";
+}
+{
+ package Foo3::Role;
+ use Mouse::Role;
+}
+{
+ package Bar3;
+ use Mouse -traits => ['Foo3::Role'];
+}
+{
+ package Baz3;
+ use Mouse -traits => ['Foo3::Role'];
+ my $meta = __PACKAGE__->meta;
+ ::lives_ok { $meta->superclasses('Foo2') } "can set superclasses once";
+ ::isa_ok($meta, Foo2->meta->meta->name);
+ ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+ ['Foo2::Role', 'Foo3::Role'],
+ "reconciled roles correctly");
+ ::lives_ok { $meta->superclasses('Bar3') } "can still set superclasses";
+ ::isa_ok($meta, Bar3->meta->meta->name);
+ ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+ ['Foo2::Role', 'Foo3::Role'],
+ "roles still the same");
+ ::ok(!$meta->is_immutable,
+ "immutable superclass doesn't make this class immutable");
+ ::lives_ok { $meta->make_immutable } "can still make immutable";
+}
+{
+ package Quux3;
+ use Mouse;
+}
+{
+ package Quuux3;
+ use Mouse -traits => ['Foo3::Role'];
+ my $meta = __PACKAGE__->meta;
+ ::lives_ok { $meta->superclasses('Foo2') } "can set superclasses once";
+ ::isa_ok($meta, Foo2->meta->meta->name);
+ ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+ ['Foo2::Role', 'Foo3::Role'],
+ "reconciled roles correctly");
+ ::lives_ok { $meta->superclasses('Quux3') } "can still set superclasses";
+ ::isa_ok($meta, Quux3->meta->meta->name);
+ ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+ ['Foo2::Role', 'Foo3::Role'],
+ "roles still the same");
+ ::ok(!$meta->is_immutable,
+ "immutable superclass doesn't make this class immutable");
+ ::lives_ok { $meta->make_immutable } "can still make immutable";
+}
+
+{
+ package Foo4::Role;
+ use Mouse::Role;
+}
+{
+ package Foo4;
+ use Mouse -traits => ['Foo4::Role'];
+ __PACKAGE__->meta->make_immutable;
+}
+{
+ package Bar4;
+ use Mouse;
+}
+{
+ package Baz4;
+ use Mouse;
+ my $meta = __PACKAGE__->meta;
+ ::lives_ok { $meta->superclasses('Foo4') } "can set superclasses once";
+ ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name);
+ ::lives_ok { $meta->superclasses('Bar4') } "can still set superclasses";
+ ::isa_ok($meta, Bar4->meta->meta->name);
+ ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+ ['Foo4::Role'],
+ "still have the role attached");
+ ::ok(!$meta->is_immutable,
+ "immutable superclass doesn't make this class immutable");
+ ::lives_ok { $meta->make_immutable } "can still make immutable";
+}
+{
+ package Foo5::Role;
+ use Mouse::Role;
+}
+{
+ package Bar5;
+ use Mouse -traits => ['Foo5::Role'];
+}
+{
+ package Baz5;
+ use Mouse -traits => ['Foo5::Role'];
+ my $meta = __PACKAGE__->meta;
+ ::lives_ok { $meta->superclasses('Foo4') } "can set superclasses once";
+ ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name);
+ ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+ ['Foo4::Role', 'Foo5::Role'],
+ "reconciled roles correctly");
+ ::lives_ok { $meta->superclasses('Bar5') } "can still set superclasses";
+ ::isa_ok($meta, Bar5->meta->meta->name);
+ ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+ ['Foo4::Role', 'Foo5::Role'],
+ "roles still the same");
+ ::ok(!$meta->is_immutable,
+ "immutable superclass doesn't make this class immutable");
+ ::lives_ok { $meta->make_immutable } "can still make immutable";
+}
+{
+ package Quux5;
+ use Mouse;
+}
+{
+ package Quuux5;
+ use Mouse -traits => ['Foo5::Role'];
+ my $meta = __PACKAGE__->meta;
+ ::lives_ok { $meta->superclasses('Foo4') } "can set superclasses once";
+ ::isa_ok($meta, Foo4->meta->_get_mutable_metaclass_name);
+ ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+ ['Foo4::Role', 'Foo5::Role'],
+ "reconciled roles correctly");
+ ::lives_ok { $meta->superclasses('Quux5') } "can still set superclasses";
+ ::isa_ok($meta, Quux5->meta->meta->name);
+ ::is_deeply([sort map { $_->name } $meta->meta->calculate_all_roles_with_inheritance],
+ ['Foo4::Role', 'Foo5::Role'],
+ "roles still the same");
+ ::ok(!$meta->is_immutable,
+ "immutable superclass doesn't make this class immutable");
+ ::lives_ok { $meta->make_immutable } "can still make immutable";
+}
+
+{
+ package Foo5::Meta::Role;
+ use Mouse::Role;
+}
+{
+ package Foo5::SuperClass::WithMetaRole;
+ use Mouse -traits =>'Foo5::Meta::Role';
+}
+{
+ package Foo5::SuperClass::After::Attribute;
+ use Mouse;
+}
+{
+ package Foo5;
+ use Mouse;
+ my @superclasses = ('Foo5::SuperClass::WithMetaRole');
+ extends @superclasses;
+
+ has an_attribute_generating_methods => ( is => 'ro' );
+
+ push(@superclasses, 'Foo5::SuperClass::After::Attribute');
+
+ ::lives_ok {
+ extends @superclasses;
+ } 'MI extends after_generated_methods with metaclass roles';
+ ::lives_ok {
+ extends reverse @superclasses;
+ }
+ 'MI extends after_generated_methods with metaclass roles (reverse)';
+}
+
+{
+ package Foo6::Meta::Role;
+ use Mouse::Role;
+}
+{
+ package Foo6::SuperClass::WithMetaRole;
+ use Mouse -traits =>'Foo6::Meta::Role';
+}
+{
+ package Foo6::Meta::OtherRole;
+ use Mouse::Role;
+}
+{
+ package Foo6::SuperClass::After::Attribute;
+ use Mouse -traits =>'Foo6::Meta::OtherRole';
+}
+{
+ package Foo6;
+ use Mouse;
+ my @superclasses = ('Foo6::SuperClass::WithMetaRole');
+ extends @superclasses;
+
+ has an_attribute_generating_methods => ( is => 'ro' );
+
+ push(@superclasses, 'Foo6::SuperClass::After::Attribute');
+
+ ::throws_ok {
+ extends @superclasses;
+ } qr/compat.*pristine/,
+ 'unsafe MI extends after_generated_methods with metaclass roles';
+ ::throws_ok {
+ extends reverse @superclasses;
+ } qr/compat.*pristine/,
+ 'unsafe MI extends after_generated_methods with metaclass roles (reverse)';
+}
+
+{
+ package Foo7::Meta::Trait;
+ use Mouse::Role;
+}
+
+{
+ package Foo7;
+ use Mouse -traits => ['Foo7::Meta::Trait'];
+}
+
+{
+ package Bar7;
+ # in an external file
+ use Mouse -traits => ['Bar7::Meta::Trait'];
+ ::lives_ok { extends 'Foo7' } "role reconciliation works";
+}
+
+{
+ package Bar72;
+ # in an external file
+ use Mouse -traits => ['Bar7::Meta::Trait2'];
+ ::lives_ok { extends 'Foo7' } "role reconciliation works";
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+
+{
+
+ package Elk;
+ use strict;
+ use warnings;
+
+ sub new {
+ my $class = shift;
+ bless { no_moose => "Elk" } => $class;
+ }
+
+ sub no_moose { $_[0]->{no_moose} }
+
+ package Foo::Mouse;
+ use Mouse;
+
+ extends 'Elk';
+
+ has 'moose' => ( is => 'ro', default => 'Foo' );
+
+ sub new {
+ my $class = shift;
+ my $super = $class->SUPER::new(@_);
+ return $class->meta->new_object( '__INSTANCE__' => $super, @_ );
+ }
+
+ __PACKAGE__->meta->make_immutable( inline_constructor => 0, debug => 0 );
+
+ package Bucket;
+ use metaclass 'Mouse::Meta::Class';
+
+ __PACKAGE__->meta->add_attribute(
+ 'squeegee' => ( accessor => 'squeegee' ) );
+
+ package Old::Bucket::Nose;
+
+ # see http://www.moosefoundation.org/moose_facts.htm
+ use Mouse;
+
+ extends 'Bucket';
+
+ package MyBase;
+ sub foo { }
+
+ package Custom::Meta1;
+ use base qw(Mouse::Meta::Class);
+
+ package Custom::Meta2;
+ use base qw(Mouse::Meta::Class);
+
+ package SubClass1;
+ use metaclass 'Custom::Meta1';
+ use Mouse;
+
+ extends 'MyBase';
+
+ package SubClass2;
+ use metaclass 'Custom::Meta2';
+ use Mouse;
+
+ # XXX FIXME subclassing meta-attrs and immutable-ing the subclass fails
+}
+
+my $foo_moose = Foo::Mouse->new();
+isa_ok( $foo_moose, 'Foo::Mouse' );
+isa_ok( $foo_moose, 'Elk' );
+
+is( $foo_moose->no_moose, 'Elk',
+ '... got the right value from the Elk method' );
+is( $foo_moose->moose, 'Foo',
+ '... got the right value from the Foo::Mouse method' );
+
+lives_ok {
+ Old::Bucket::Nose->meta->make_immutable( debug => 0 );
+}
+'Immutability on Mouse class extending Mouse::Meta class ok';
+
+lives_ok {
+ SubClass2->meta->superclasses('MyBase');
+}
+'Can subclass the same non-Mouse class twice with different metaclasses';
+
+done_testing;
--- /dev/null
+use strict;
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use warnings;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Mouse::Meta ();
+
+{
+ package My::Role;
+ use Mouse::Role;
+}
+
+{
+ package SomeClass;
+ use Mouse -traits => 'My::Role';
+}
+
+{
+ package SubClassUseBase;
+ use base qw/SomeClass/;
+}
+
+{
+ package SubSubClassUseBase;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends 'SubClassUseBase';
+ }
+ 'Can extend non-Mouse class with parent class that is a Mouse class with a meta role';
+}
+
+{
+ ok( SubSubClassUseBase->meta->meta->can('does_role')
+ && SubSubClassUseBase->meta->meta->does_role('My::Role'),
+ 'SubSubClassUseBase meta metaclass does the My::Role role' );
+}
+
+# Note, remove metaclasses of the 'use base' classes after each test,
+# so that they have to be re-initialized - otherwise latter tests
+# would not demonstrate the original issue.
+Mouse::Util::remove_metaclass_by_name('SubClassUseBase');
+
+{
+ package OtherClass;
+ use Mouse;
+}
+
+{
+ package OtherSubClassUseBase;
+ use base 'OtherClass';
+}
+
+{
+ package MultiParent1;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends qw( SubClassUseBase OtherSubClassUseBase );
+ }
+ 'Can extend two non-Mouse classes with parents that are different Mouse metaclasses';
+}
+
+{
+ ok( MultiParent1->meta->meta->can('does_role')
+ && MultiParent1->meta->meta->does_role('My::Role'),
+ 'MultiParent1 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiParent2;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends qw( OtherSubClassUseBase SubClassUseBase );
+ }
+ 'Can extend two non-Mouse classes with parents that are different Mouse metaclasses (reverse order)';
+}
+
+{
+ ok( MultiParent2->meta->meta->can('does_role')
+ && MultiParent2->meta->meta->does_role('My::Role'),
+ 'MultiParent2 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiParent3;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends qw( OtherClass SubClassUseBase );
+ }
+ 'Can extend one Mouse class and one non-Mouse class';
+}
+
+{
+ ok( MultiParent3->meta->meta->can('does_role')
+ && MultiParent3->meta->meta->does_role('My::Role'),
+ 'MultiParent3 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiParent4;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends qw( SubClassUseBase OtherClass );
+ }
+ 'Can extend one non-Mouse class and one Mouse class';
+}
+
+{
+ ok( MultiParent4->meta->meta->can('does_role')
+ && MultiParent4->meta->meta->does_role('My::Role'),
+ 'MultiParent4 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiChild1;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends 'MultiParent1';
+ }
+ 'Can extend class that itself extends two non-Mouse classes with Mouse parents';
+}
+
+{
+ ok( MultiChild1->meta->meta->can('does_role')
+ && MultiChild1->meta->meta->does_role('My::Role'),
+ 'MultiChild1 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiChild2;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends 'MultiParent2';
+ }
+ 'Can extend class that itself extends two non-Mouse classes with Mouse parents (reverse order)';
+}
+
+{
+ ok( MultiChild2->meta->meta->can('does_role')
+ && MultiChild2->meta->meta->does_role('My::Role'),
+ 'MultiChild2 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiChild3;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends 'MultiParent3';
+ }
+ 'Can extend class that itself extends one Mouse and one non-Mouse parent';
+}
+
+{
+ ok( MultiChild3->meta->meta->can('does_role')
+ && MultiChild3->meta->meta->does_role('My::Role'),
+ 'MultiChild3 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+{
+ package MultiChild4;
+ use Mouse;
+ use Test::More;
+$TODO = q{Mouse is not yet completed};
+ use Test::Exception;
+ lives_ok {
+ extends 'MultiParent4';
+ }
+ 'Can extend class that itself extends one non-Mouse and one Mouse parent';
+}
+
+{
+ ok( MultiChild4->meta->meta->can('does_role')
+ && MultiChild4->meta->meta->does_role('My::Role'),
+ 'MultiChild4 meta metaclass does the My::Role role' );
+}
+
+Mouse::Util::remove_metaclass_by_name($_)
+ for qw( SubClassUseBase OtherSubClassUseBase );
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Mouse ();
+
+BEGIN {
+ use_ok('Mouse::Meta::Attribute::Native');
+ use_ok('Mouse::Meta::Attribute::Native::Trait::Bool');
+ use_ok('Mouse::Meta::Attribute::Native::Trait::Hash');
+ use_ok('Mouse::Meta::Attribute::Native::Trait::Array');
+ use_ok('Mouse::Meta::Attribute::Native::Trait::Counter');
+ use_ok('Mouse::Meta::Attribute::Native::Trait::Number');
+ use_ok('Mouse::Meta::Attribute::Native::Trait::String');
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Mouse;
+
+{
+ package Real;
+ use Mouse;
+
+ has 'integer' => (
+ traits => ['Number'],
+ is => 'ro',
+ isa => 'Int',
+ default => 5,
+ handles => {
+ set => 'set',
+ add => 'add',
+ sub => 'sub',
+ mul => 'mul',
+ div => 'div',
+ mod => 'mod',
+ abs => 'abs',
+ inc => [ add => 1 ],
+ dec => [ sub => 1 ],
+ odd => [ mod => 2 ],
+ cut_in_half => [ div => 2 ],
+
+ },
+ );
+}
+
+my $real = Real->new;
+isa_ok( $real, 'Real' );
+
+can_ok( $real, $_ ) for qw[
+ set add sub mul div mod abs inc dec odd cut_in_half
+];
+
+is $real->integer, 5, 'Default to five';
+
+$real->add(10);
+
+is $real->integer, 15, 'Add ten for fithteen';
+
+$real->sub(3);
+
+is $real->integer, 12, 'Subtract three for 12';
+
+$real->set(10);
+
+is $real->integer, 10, 'Set to ten';
+
+$real->div(2);
+
+is $real->integer, 5, 'divide by 2';
+
+$real->mul(2);
+
+is $real->integer, 10, 'multiplied by 2';
+
+$real->mod(2);
+
+is $real->integer, 0, 'Mod by 2';
+
+$real->set(7);
+
+$real->mod(5);
+
+is $real->integer, 2, 'Mod by 5';
+
+$real->set(-1);
+
+$real->abs;
+
+is $real->integer, 1, 'abs 1';
+
+$real->set(12);
+
+$real->inc;
+
+is $real->integer, 13, 'inc 12';
+
+$real->dec;
+
+is $real->integer, 12, 'dec 13';
+
+## test the meta
+
+my $attr = $real->meta->get_attribute('integer');
+does_ok( $attr, 'Mouse::Meta::Attribute::Native::Trait::Number' );
+
+is_deeply(
+ $attr->handles,
+ {
+ set => 'set',
+ add => 'add',
+ sub => 'sub',
+ mul => 'mul',
+ div => 'div',
+ mod => 'mod',
+ abs => 'abs',
+ inc => [ add => 1 ],
+ dec => [ sub => 1 ],
+ odd => [ mod => 2 ],
+ cut_in_half => [ div => 2 ],
+ },
+ '... got the right handles mapping'
+);
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+use Test::Mouse 'does_ok';
+
+my $sort;
+my $less;
+my $up;
+my $prod;
+{
+ package Stuff;
+ use Mouse;
+
+ has '_options' => (
+ traits => ['Array'],
+ is => 'ro',
+ isa => 'ArrayRef[Int]',
+ init_arg => 'options',
+ default => sub { [] },
+ handles => {
+ 'num_options' => 'count',
+ 'has_no_options' => 'is_empty',
+ 'map_options', => 'map',
+ 'filter_options' => 'grep',
+ 'find_option' => 'first',
+ 'options' => 'elements',
+ 'join_options' => 'join',
+ 'get_option_at' => 'get',
+ 'sorted_options' => 'sort',
+ 'randomized_options' => 'shuffle',
+ 'unique_options' => 'uniq',
+ 'less_than_five' => [ grep => ($less = sub { $_ < 5 }) ],
+ 'up_by_one' => [ map => ($up = sub { $_ + 1 }) ],
+ 'pairwise_options' => [ natatime => 2 ],
+ 'dashify' => [ join => '-' ],
+ 'descending' => [ sort => ($sort = sub { $_[1] <=> $_[0] }) ],
+ 'product' => [ reduce => ($prod = sub { $_[0] * $_[1] }) ],
+ },
+ );
+
+}
+
+my $stuff = Stuff->new( options => [ 1 .. 10 ] );
+isa_ok( $stuff, 'Stuff' );
+
+can_ok( $stuff, $_ ) for qw[
+ _options
+ num_options
+ has_no_options
+ map_options
+ filter_options
+ find_option
+ options
+ join_options
+ get_option_at
+ sorted_options
+ randomized_options
+ unique_options
+ less_than_five
+ up_by_one
+ pairwise_options
+ dashify
+ descending
+ product
+];
+
+is_deeply( $stuff->_options, [ 1 .. 10 ], '... got options' );
+
+ok( !$stuff->has_no_options, '... we have options' );
+is( $stuff->num_options, 10, '... got 2 options' );
+cmp_ok( $stuff->get_option_at(0), '==', 1, '... get option 0' );
+
+is_deeply(
+ [ $stuff->filter_options( sub { $_ % 2 == 0 } ) ],
+ [ 2, 4, 6, 8, 10 ],
+ '... got the right filtered values'
+);
+
+is_deeply(
+ [ $stuff->map_options( sub { $_ * 2 } ) ],
+ [ 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 ],
+ '... got the right mapped values'
+);
+
+is( $stuff->find_option( sub { $_ % 2 == 0 } ), 2,
+ '.. found the right option' );
+
+is_deeply( [ $stuff->options ], [ 1 .. 10 ], '... got the list of options' );
+
+is( $stuff->join_options(':'), '1:2:3:4:5:6:7:8:9:10',
+ '... joined the list of options by :' );
+
+is_deeply(
+ [ $stuff->sorted_options ], [ sort ( 1 .. 10 ) ],
+ '... got sorted options (default sort order)'
+);
+is_deeply(
+ [ $stuff->sorted_options( sub { $_[1] <=> $_[0] } ) ],
+ [ sort { $b <=> $a } ( 1 .. 10 ) ],
+ '... got sorted options (descending sort order) '
+);
+
+throws_ok { $stuff->sorted_options('foo') }
+qr/Argument must be a code reference/,
+ 'error when sort receives a non-coderef argument';
+
+is_deeply( [ sort { $a <=> $b } $stuff->randomized_options ], [ 1 .. 10 ] );
+
+my @pairs;
+$stuff->pairwise_options(sub { push @pairs, [@_] });
+is_deeply( \@pairs, [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ], [ 7, 8 ], [ 9, 10 ] ] );
+
+# test the currying
+is_deeply( [ $stuff->less_than_five() ], [ 1 .. 4 ] );
+
+is_deeply( [ $stuff->up_by_one() ], [ 2 .. 11 ] );
+
+is( $stuff->dashify, '1-2-3-4-5-6-7-8-9-10' );
+
+is_deeply( [ $stuff->descending ], [ reverse 1 .. 10 ] );
+
+is( $stuff->product, 3628800 );
+
+my $other_stuff = Stuff->new( options => [ 1, 1, 2, 3, 5 ] );
+is_deeply( [ $other_stuff->unique_options ], [1, 2, 3, 5] );
+
+## test the meta
+
+my $options = $stuff->meta->get_attribute('_options');
+does_ok( $options, 'Mouse::Meta::Attribute::Native::Trait::Array' );
+
+is_deeply(
+ $options->handles,
+ {
+ 'num_options' => 'count',
+ 'has_no_options' => 'is_empty',
+ 'map_options', => 'map',
+ 'filter_options' => 'grep',
+ 'find_option' => 'first',
+ 'options' => 'elements',
+ 'join_options' => 'join',
+ 'get_option_at' => 'get',
+ 'sorted_options' => 'sort',
+ 'randomized_options' => 'shuffle',
+ 'unique_options' => 'uniq',
+ 'less_than_five' => [ grep => $less ],
+ 'up_by_one' => [ map => $up ],
+ 'pairwise_options' => [ natatime => 2 ],
+ 'dashify' => [ join => '-' ],
+ 'descending' => [ sort => $sort ],
+ 'product' => [ reduce => $prod ],
+ },
+ '... got the right handles mapping'
+);
+
+is( $options->type_constraint->type_parameter, 'Int',
+ '... got the right container type' );
+
+dies_ok {
+ $stuff->sort_in_place_options(undef);
+}
+'... sort rejects arg of invalid type';
+
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 15;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
{
is($blart->a, 'Foo::a', '... got the right delgated value');
-
+done_testing;
#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use strict;
use warnings;
-use Test::More tests => 36;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
-
BEGIN {
package MyRole;
use Mouse::Role;
lives_ok {
MyMetaclass->meta->make_immutable;
-} '... make MyClass immutable okay';
+} '... make MyMetaclass immutable okay';
is(MyClass->meta, $mc, '... these metas are still the same thing');
is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
lives_ok {
MyClass->meta->make_immutable;
-} '... make MyClass immutable okay';
+} '... make MyClass immutable (again) okay';
is(MyClass->meta, $mc, '... these metas are still the same thing');
is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+done_testing;
use strict;
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use warnings;
-use Test::More tests => 2;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
use Test::Exception;
{
# Removing the metaclass simulates the case where the metaclass object
# goes out of scope _before_ the object itself, which under normal
# circumstances only happens during global destruction.
-Class::MOP::remove_metaclass_by_name('MyClass');
+Mouse::Util::remove_metaclass_by_name('MyClass');
# The bug happened when DEMOLISHALL called
-# Class::MOP::class_of($object) and did not get a metaclass object
+# Mouse::Util::class_of($object) and did not get a metaclass object
# back.
lives_ok { $object->DESTROY }
'can call DESTROY on an object without a metaclass object in the CMOP cache';
MyClass->meta->make_immutable;
-Class::MOP::remove_metaclass_by_name('MyClass');
+Mouse::Util::remove_metaclass_by_name('MyClass');
# The bug didn't manifest for immutable objects, but this test should
# help us prevent it happening in the future.
lives_ok { $object->DESTROY }
'can call DESTROY on an object without a metaclass object in the CMOP cache (immutable version)';
+
+done_testing;
use strict;
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
use warnings;
-use Test::More tests => 10;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
{
package Ball;
undef $method_meta;
}
+
+done_testing;
--- /dev/null
+#!/usr/local/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+
+=pod
+
+This is an example of making Mouse behave
+more like a prototype based object system.
+
+Why?
+
+Well cause merlyn asked if it could :)
+
+=cut
+
+## ------------------------------------------------------------------
+## make some metaclasses
+
+{
+ package ProtoMoose::Meta::Instance;
+ use Mouse;
+
+ BEGIN { extends 'Mouse::Meta::Instance' };
+
+ # NOTE:
+ # do not let things be inlined by
+ # the attribute or accessor generator
+ sub is_inlinable { 0 }
+}
+
+{
+ package ProtoMoose::Meta::Method::Accessor;
+ use Mouse;
+
+ BEGIN { extends 'Mouse::Meta::Method' };
+
+ # customize the accessors to always grab
+ # the correct instance in the accessors
+
+ sub find_instance {
+ my ($self, $candidate, $accessor_type) = @_;
+
+ my $instance = $candidate;
+ my $attr = $self->associated_attribute;
+
+ # if it is a class calling it ...
+ unless (blessed($instance)) {
+ # then grab the class prototype
+ $instance = $attr->associated_class->prototype_instance;
+ }
+ # if its an instance ...
+ else {
+ # and there is no value currently
+ # associated with the instance and
+ # we are trying to read it, then ...
+ if ($accessor_type eq 'r' && !defined($attr->get_value($instance))) {
+ # again, defer the prototype in
+ # the class in which is was defined
+ $instance = $attr->associated_class->prototype_instance;
+ }
+ # otherwise, you want to assign
+ # to your local copy ...
+ }
+ return $instance;
+ }
+
+ sub _generate_accessor_method {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+ return sub {
+ if (scalar(@_) == 2) {
+ $attr->set_value(
+ $self->find_instance($_[0], 'w'),
+ $_[1]
+ );
+ }
+ $attr->get_value($self->find_instance($_[0], 'r'));
+ };
+ }
+
+ sub _generate_reader_method {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+ return sub {
+ confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+ $attr->get_value($self->find_instance($_[0], 'r'));
+ };
+ }
+
+ sub _generate_writer_method {
+ my $self = shift;
+ my $attr = $self->associated_attribute;
+ return sub {
+ $attr->set_value(
+ $self->find_instance($_[0], 'w'),
+ $_[1]
+ );
+ };
+ }
+
+ # deal with these later ...
+ sub generate_predicate_method {}
+ sub generate_clearer_method {}
+
+}
+
+{
+ package ProtoMoose::Meta::Attribute;
+ use Mouse;
+
+ BEGIN { extends 'Mouse::Meta::Attribute' };
+
+ sub accessor_metaclass { 'ProtoMoose::Meta::Method::Accessor' }
+}
+
+{
+ package ProtoMoose::Meta::Class;
+ use Mouse;
+
+ BEGIN { extends 'Mouse::Meta::Class' };
+
+ has 'prototype_instance' => (
+ is => 'rw',
+ isa => 'Object',
+ predicate => 'has_prototypical_instance',
+ lazy => 1,
+ default => sub { (shift)->new_object }
+ );
+
+ sub initialize {
+ # NOTE:
+ # I am not sure why 'around' does
+ # not work here, have to investigate
+ # it later - SL
+ (shift)->SUPER::initialize(@_,
+ instance_metaclass => 'ProtoMoose::Meta::Instance',
+ attribute_metaclass => 'ProtoMoose::Meta::Attribute',
+ );
+ }
+
+ around 'construct_instance' => sub {
+ my $next = shift;
+ my $self = shift;
+ # NOTE:
+ # we actually have to do this here
+ # to tie-the-knot, if you take it
+ # out, then you get deep recursion
+ # several levels deep :)
+ $self->prototype_instance($next->($self, @_))
+ unless $self->has_prototypical_instance;
+ return $self->prototype_instance;
+ };
+
+}
+
+{
+ package ProtoMoose::Object;
+ use metaclass 'ProtoMoose::Meta::Class';
+ use Mouse;
+
+ sub new {
+ my $prototype = blessed($_[0])
+ ? $_[0]
+ : $_[0]->meta->prototype_instance;
+ my (undef, %params) = @_;
+ my $self = $prototype->meta->clone_object($prototype, %params);
+ $self->BUILDALL(\%params);
+ return $self;
+ }
+}
+
+## ------------------------------------------------------------------
+## make some classes now
+
+{
+ package Foo;
+ use Mouse;
+
+ extends 'ProtoMoose::Object';
+
+ has 'bar' => (is => 'rw');
+}
+
+{
+ package Bar;
+ use Mouse;
+
+ extends 'Foo';
+
+ has 'baz' => (is => 'rw');
+}
+
+## ------------------------------------------------------------------
+
+## ------------------------------------------------------------------
+## Check that metaclasses are working/inheriting properly
+
+foreach my $class (qw/ProtoMoose::Object Foo Bar/) {
+ isa_ok($class->meta,
+ 'ProtoMoose::Meta::Class',
+ '... got the right metaclass for ' . $class . ' ->');
+
+ is($class->meta->instance_metaclass,
+ 'ProtoMoose::Meta::Instance',
+ '... got the right instance meta for ' . $class);
+
+ is($class->meta->attribute_metaclass,
+ 'ProtoMoose::Meta::Attribute',
+ '... got the right attribute meta for ' . $class);
+}
+
+## ------------------------------------------------------------------
+
+# get the prototype for Foo
+my $foo_prototype = Foo->meta->prototype_instance;
+isa_ok($foo_prototype, 'Foo');
+
+# set a value in the prototype
+$foo_prototype->bar(100);
+is($foo_prototype->bar, 100, '... got the value stored in the prototype');
+
+# the "class" defers to the
+# the prototype when asked
+# about attributes
+is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)');
+
+# now make an instance, which
+# is basically a clone of the
+# prototype
+my $foo = Foo->new;
+isa_ok($foo, 'Foo');
+
+# the instance is *not* the prototype
+isnt($foo, $foo_prototype, '... got a new instance of Foo');
+
+# but it has the same values ...
+is($foo->bar, 100, '... got the value stored in the instance (inherited from the prototype)');
+
+# we can even change the values
+# in the instance
+$foo->bar(300);
+is($foo->bar, 300, '... got the value stored in the instance (overwriting the one inherited from the prototype)');
+
+# and not change the one in the prototype
+is($foo_prototype->bar, 100, '... got the value stored in the prototype');
+is(Foo->bar, 100, '... got the value stored in the prototype (through the Foo class)');
+
+## subclasses
+
+# now we can check that the subclass
+# will seek out the correct prototypical
+# value from it's "parent"
+is(Bar->bar, 100, '... got the value stored in the Foo prototype (through the Bar class)');
+
+# we can then also set it's local attrs
+Bar->baz(50);
+is(Bar->baz, 50, '... got the value stored in the prototype (through the Bar class)');
+
+# now we clone the Bar prototype
+my $bar = Bar->new;
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
+
+# and we see that we got the right values
+# in the instance/clone
+is($bar->bar, 100, '... got the value stored in the instance (inherited from the Foo prototype)');
+is($bar->baz, 50, '... got the value stored in the instance (inherited from the Bar prototype)');
+
+# nowe we can change the value
+$bar->bar(200);
+is($bar->bar, 200, '... got the value stored in the instance (overriding the one inherited from the Foo prototype)');
+
+# and all our original and
+# prototypical values are still
+# the same
+is($foo->bar, 300, '... still got the original value stored in the instance (inherited from the prototype)');
+is(Foo->bar, 100, '... still got the original value stored in the prototype (through the Foo class)');
+is(Bar->bar, 100, '... still got the original value stored in the prototype (through the Bar class)');
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+
+BEGIN {
+ use_ok('Mouse::Util', ':all');
+}
+
+{ package SCBR::Role;
+ use Mouse::Role;
+}
+
+{ package SCBR::A;
+ use Mouse;
+}
+is search_class_by_role('SCBR::A', 'SCBR::Role'), undef, '... not found role returns undef';
+is search_class_by_role('SCBR::A', SCBR::Role->meta), undef, '... not found role returns undef';
+
+{ package SCBR::B;
+ use Mouse;
+ extends 'SCBR::A';
+ with 'SCBR::Role';
+}
+is search_class_by_role('SCBR::B', 'SCBR::Role'), 'SCBR::B', '... class itself returned if it does role';
+is search_class_by_role('SCBR::B', SCBR::Role->meta), 'SCBR::B', '... class itself returned if it does role';
+
+{ package SCBR::C;
+ use Mouse;
+ extends 'SCBR::B';
+}
+is search_class_by_role('SCBR::C', 'SCBR::Role'), 'SCBR::B', '... nearest class doing role returned';
+is search_class_by_role('SCBR::C', SCBR::Role->meta), 'SCBR::B', '... nearest class doing role returned';
+
+{ package SCBR::D;
+ use Mouse;
+ extends 'SCBR::C';
+ with 'SCBR::Role';
+}
+is search_class_by_role('SCBR::D', 'SCBR::Role'), 'SCBR::D', '... nearest class being direct class returned';
+is search_class_by_role('SCBR::D', SCBR::Role->meta), 'SCBR::D', '... nearest class being direct class returned';
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+
+use Mouse::Util qw( resolve_metaclass_alias resolve_metatrait_alias );
+
+use lib 't/lib';
+
+# Doing each test twice is intended to make sure that the caching
+# doesn't break name resolution. It doesn't actually test that
+# anything is cached.
+is( resolve_metaclass_alias( 'Attribute', 'Mouse::Meta::Attribute::Custom::Foo' ),
+ 'Mouse::Meta::Attribute::Custom::Foo',
+ 'resolve_metaclass_alias finds Mouse::Meta::Attribute::Custom::Foo' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Mouse::Meta::Attribute::Custom::Foo' ),
+ 'Mouse::Meta::Attribute::Custom::Foo',
+ 'resolve_metaclass_alias finds Mouse::Meta::Attribute::Custom::Foo second time' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Foo' ),
+ 'Mouse::Meta::Attribute::Custom::Foo',
+ 'resolve_metaclass_alias finds Mouse::Meta::Attribute::Custom::Foo via alias (Foo)' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Foo' ),
+ 'Mouse::Meta::Attribute::Custom::Foo',
+ 'resolve_metaclass_alias finds Mouse::Meta::Attribute::Custom::Foo via alias (Foo) a second time' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Mouse::Meta::Attribute::Custom::Bar' ),
+ 'My::Bar',
+ 'resolve_metaclass_alias finds Mouse::Meta::Attribute::Custom::Bar as My::Bar' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Mouse::Meta::Attribute::Custom::Bar' ),
+ 'My::Bar',
+ 'resolve_metaclass_alias finds Mouse::Meta::Attribute::Custom::Bar as My::Bar a second time' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Bar' ),
+ 'My::Bar',
+ 'resolve_metaclass_alias finds Mouse::Meta::Attribute::Custom::Bar as My::Bar via alias (Bar)' );
+
+is( resolve_metaclass_alias( 'Attribute', 'Bar' ),
+ 'My::Bar',
+ 'resolve_metaclass_alias finds Mouse::Meta::Attribute::Custom::Bar as My::Bar via alias (Bar) a second time' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Mouse::Meta::Attribute::Custom::Trait::Foo' ),
+ 'Mouse::Meta::Attribute::Custom::Trait::Foo',
+ 'resolve_metatrait_alias finds Mouse::Meta::Attribute::Custom::Trait::Foo' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Mouse::Meta::Attribute::Custom::Trait::Foo' ),
+ 'Mouse::Meta::Attribute::Custom::Trait::Foo',
+ 'resolve_metatrait_alias finds Mouse::Meta::Attribute::Custom::Trait::Foo second time' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Foo' ),
+ 'Mouse::Meta::Attribute::Custom::Trait::Foo',
+ 'resolve_metatrait_alias finds Mouse::Meta::Attribute::Custom::Trait::Foo via alias (Foo)' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Foo' ),
+ 'Mouse::Meta::Attribute::Custom::Trait::Foo',
+ 'resolve_metatrait_alias finds Mouse::Meta::Attribute::Custom::Trait::Foo via alias (Foo) a second time' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Mouse::Meta::Attribute::Custom::Trait::Bar' ),
+ 'My::Trait::Bar',
+ 'resolve_metatrait_alias finds Mouse::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Mouse::Meta::Attribute::Custom::Trait::Bar' ),
+ 'My::Trait::Bar',
+ 'resolve_metatrait_alias finds Mouse::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar a second time' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Bar' ),
+ 'My::Trait::Bar',
+ 'resolve_metatrait_alias finds Mouse::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar via alias (Bar)' );
+
+is( resolve_metatrait_alias( 'Attribute', 'Bar' ),
+ 'My::Trait::Bar',
+ 'resolve_metatrait_alias finds Mouse::Meta::Attribute::Custom::Trait::Bar as My::Trait::Bar via alias (Bar) a second time' );
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+
+BEGIN {
+ use_ok('Mouse::Util', ':all');
+}
+
+{
+ package Foo;
+ use Mouse::Role;
+}
+
+{
+ package Bar;
+ use Mouse::Role;
+}
+
+{
+ package Quux;
+ use Mouse;
+}
+
+is_deeply(
+ Quux->meta->roles,
+ [],
+ "no roles yet",
+);
+
+Foo->meta->apply(Quux->meta);
+
+is_deeply(
+ Quux->meta->roles,
+ [ Foo->meta ],
+ "applied Foo",
+);
+
+Foo->meta->apply(Quux->meta);
+Bar->meta->apply(Quux->meta);
+is_deeply(
+ Quux->meta->roles,
+ [ Foo->meta, Foo->meta, Bar->meta ],
+ "duplicated Foo",
+);
+
+is(does_role('Quux', 'Foo'), 1, "Quux does Foo");
+is(does_role('Quux', 'Bar'), 1, "Quux does Bar");
+ensure_all_roles('Quux', qw(Foo Bar));
+is_deeply(
+ Quux->meta->roles,
+ [ Foo->meta, Foo->meta, Bar->meta ],
+ "unchanged, since all roles are already applied",
+);
+
+my $obj = Quux->new;
+ensure_all_roles($obj, qw(Foo Bar));
+is_deeply(
+ $obj->meta->roles,
+ [ Foo->meta, Foo->meta, Bar->meta ],
+ "unchanged, since all roles are already applied",
+);
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Mouse qw(does_ok);
+
+BEGIN {
+ package Foo::Meta::Role;
+ use Mouse::Role;
+ Mouse::Util::meta_class_alias
+ FooRole => 'Foo::Meta::Role';
+
+ package Foo::Meta::Class;
+ use Mouse;
+ extends 'Mouse::Meta::Class';
+ with 'Foo::Meta::Role';
+ Mouse::Util::meta_class_alias
+ FooClass => 'Foo::Meta::Class';
+
+ package Foo::Meta::Role::Attribute;
+ use Mouse::Role;
+ Mouse::Util::meta_attribute_alias
+ FooAttrRole => 'Foo::Meta::Role::Attribute';
+
+ package Foo::Meta::Attribute;
+ use Mouse;
+ extends 'Mouse::Meta::Attribute';
+ with 'Foo::Meta::Role::Attribute';
+ Mouse::Util::meta_attribute_alias
+ FooAttrClass => 'Foo::Meta::Attribute';
+
+ package Bar::Meta::Role;
+ use Mouse::Role;
+ Mouse::Util::meta_class_alias 'BarRole';
+
+ package Bar::Meta::Class;
+ use Mouse;
+ extends 'Mouse::Meta::Class';
+ with 'Bar::Meta::Role';
+ Mouse::Util::meta_class_alias 'BarClass';
+
+ package Bar::Meta::Role::Attribute;
+ use Mouse::Role;
+ Mouse::Util::meta_attribute_alias 'BarAttrRole';
+
+ package Bar::Meta::Attribute;
+ use Mouse;
+ extends 'Mouse::Meta::Attribute';
+ with 'Bar::Meta::Role::Attribute';
+ Mouse::Util::meta_attribute_alias 'BarAttrClass';
+}
+
+package FooWithMetaClass;
+use Mouse -metaclass => 'FooClass';
+
+has bar => (
+ metaclass => 'FooAttrClass',
+ is => 'ro',
+);
+
+
+package FooWithMetaTrait;
+use Mouse -traits => 'FooRole';
+
+has bar => (
+ traits => [qw(FooAttrRole)],
+ is => 'ro',
+);
+
+package BarWithMetaClass;
+use Mouse -metaclass => 'BarClass';
+
+has bar => (
+ metaclass => 'BarAttrClass',
+ is => 'ro',
+);
+
+
+package BarWithMetaTrait;
+use Mouse -traits => 'BarRole';
+
+has bar => (
+ traits => [qw(BarAttrRole)],
+ is => 'ro',
+);
+
+package main;
+my $fwmc_meta = FooWithMetaClass->meta;
+my $fwmt_meta = FooWithMetaTrait->meta;
+isa_ok($fwmc_meta, 'Foo::Meta::Class');
+isa_ok($fwmc_meta->get_attribute('bar'), 'Foo::Meta::Attribute');
+does_ok($fwmt_meta, 'Foo::Meta::Role');
+does_ok($fwmt_meta->get_attribute('bar'), 'Foo::Meta::Role::Attribute');
+
+my $bwmc_meta = BarWithMetaClass->meta;
+my $bwmt_meta = BarWithMetaTrait->meta;
+isa_ok($bwmc_meta, 'Bar::Meta::Class');
+isa_ok($bwmc_meta->get_attribute('bar'), 'Bar::Meta::Attribute');
+does_ok($bwmt_meta, 'Bar::Meta::Role');
+does_ok($bwmt_meta->get_attribute('bar'), 'Bar::Meta::Role::Attribute');
+
+done_testing;
--- /dev/null
+use strict;
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+use Mouse::Util qw( add_method_modifier );
+
+my $COUNT = 0;
+{
+ package Foo;
+ use Mouse;
+
+ sub foo { }
+ sub bar { }
+}
+
+lives_ok {
+ add_method_modifier('Foo', 'before', [ ['foo', 'bar'], sub { $COUNT++ } ]);
+} 'method modifier with an arrayref';
+
+dies_ok {
+ add_method_modifier('Foo', 'before', [ {'foo' => 'bar'}, sub { $COUNT++ } ]);
+} 'method modifier with a hashref';
+
+my $foo = Foo->new;
+$foo->foo;
+$foo->bar;
+is($COUNT, 2, "checking that the modifiers were installed.");
+
+
+done_testing;
--- /dev/null
+#!/usr/bin/env perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use strict;
+use warnings;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Mouse;
+
+use Mouse ();
+use Mouse::Util qw(with_traits);
+
+{
+ package Foo;
+ use Mouse;
+}
+
+{
+ package Foo::Role;
+ use Mouse::Role;
+}
+
+{
+ package Foo::Role2;
+ use Mouse::Role;
+}
+
+{
+ my $traited_class = with_traits('Foo', 'Foo::Role');
+ ok($traited_class->meta->is_anon_class, "we get an anon class");
+ isa_ok($traited_class, 'Foo');
+ does_ok($traited_class, 'Foo::Role');
+}
+
+{
+ my $traited_class = with_traits('Foo', 'Foo::Role', 'Foo::Role2');
+ ok($traited_class->meta->is_anon_class, "we get an anon class");
+ isa_ok($traited_class, 'Foo');
+ does_ok($traited_class, 'Foo::Role');
+ does_ok($traited_class, 'Foo::Role2');
+}
+
+{
+ my $traited_class = with_traits('Foo');
+ is($traited_class, 'Foo', "don't apply anything if we don't get any traits");
+}
+
+{
+ my $traited_class = with_traits('Foo', 'Foo::Role');
+ my $traited_class2 = with_traits('Foo', 'Foo::Role');
+ is($traited_class, $traited_class2, "get the same class back when passing the same roles");
+}
+
+done_testing;
--- /dev/null
+#!/usr/bin/perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+
+use strict;
+use warnings;
+
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+use Test::Exception;
+
+sub req_or_has ($$) {
+ my ( $role, $method ) = @_;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ if ( $role ) {
+ ok(
+ $role->has_method($method) || $role->requires_method($method),
+ $role->name . " has or requires method $method"
+ );
+ } else {
+ fail("role has or requires method $method");
+ }
+}
+
+{
+ package Bar;
+ use Mouse::Role;
+
+ # this role eventually adds three methods, qw(foo bar xxy), but only one is
+ # known when it's still a role
+
+ has foo => ( is => "rw" );
+
+ has gorch => ( reader => "bar" );
+
+ sub xxy { "BAAAD" }
+
+ package Gorch;
+ use Mouse::Role;
+
+ # similarly this role gives attr and gorch_method
+
+ has attr => ( is => "rw" );
+
+ sub gorch_method { "gorch method" }
+
+ around dandy => sub { shift->(@_) . "bar" };
+
+ package Quxx;
+ use Mouse;
+
+ sub dandy { "foo" }
+
+ # this object will be used in an attr of Foo to test that Foo can do the
+ # Gorch interface
+
+ with qw(Gorch);
+
+ package Dancer;
+ use Mouse::Role;
+
+ requires "twist";
+
+ package Dancer::Ballerina;
+ use Mouse;
+
+ with qw(Dancer);
+
+ sub twist { }
+
+ sub pirouette { }
+
+ package Dancer::Robot;
+ use Mouse::Role;
+
+ # this doesn't fail but it produces a requires in the role
+ # the order doesn't matter
+ has twist => ( is => "rw" );
+ ::lives_ok { with qw(Dancer) };
+
+ package Dancer::Something;
+ use Mouse;
+
+ # this fail even though the method already exists
+
+ has twist => ( is => "rw" );
+
+ {
+ ::lives_ok { with qw(Dancer) };
+ }
+
+ package Dancer::80s;
+ use Mouse;
+
+ # this should pass because ::Robot has the attribute to fill in the requires
+ # but due to the deferrence logic that doesn't actually work
+ {
+ local our $TODO = "attribute accessor in role doesn't satisfy role requires";
+ ::lives_ok { with qw(Dancer::Robot) };
+ }
+
+ package Foo;
+ use Mouse;
+
+ with qw(Bar);
+
+ has oink => (
+ is => "rw",
+ handles => "Gorch", # should handles take the same arguments as 'with'? Meta::Role::Application::Delegation?
+ default => sub { Quxx->new },
+ );
+
+ has dancer => (
+ is => "rw",
+ does => "Dancer",
+ handles => "Dancer",
+ default => sub { Dancer::Ballerina->new },
+ );
+
+ sub foo { 42 }
+
+ sub bar { 33 }
+
+ sub xxy { 7 }
+
+ package Tree;
+ use Mouse::Role;
+
+ has bark => ( is => "rw" );
+
+ package Dog;
+ use Mouse::Role;
+
+ sub bark { warn "woof!" };
+
+ package EntPuppy;
+ use Mouse;
+
+ {
+ local our $TODO = "attrs and methods from a role should clash";
+ ::dies_ok { with qw(Tree Dog) }
+ }
+}
+
+# these fail because of the deferral logic winning over actual methods
+# this might be tricky to fix due to the 'sub foo {}; has foo => ( )' hack
+# we've been doing for a long while, though I doubt people relied on it for
+# anything other than fulfilling 'requires'
+{
+ local $TODO = "attributes from role overwrite class methods";
+ is( Foo->new->foo, 42, "attr did not zap overriding method" );
+ is( Foo->new->bar, 33, "attr did not zap overriding method" );
+}
+is( Foo->new->xxy, 7, "method did not zap overriding method" ); # duh
+
+# these pass, simple delegate
+# mostly they are here to contrast the next blck
+can_ok( Foo->new->oink, "dandy" );
+can_ok( Foo->new->oink, "attr" );
+can_ok( Foo->new->oink, "gorch_method" );
+
+ok( Foo->new->oink->does("Gorch"), "Quxx does Gorch" );
+
+
+# these are broken because 'attr' is not technically part of the interface
+can_ok( Foo->new, "gorch_method" );
+{
+ local $TODO = "accessor methods from a role are omitted in handles role";
+ can_ok( Foo->new, "attr" );
+}
+
+{
+ local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class";
+ ok( Foo->new->does("Gorch"), "Foo does Gorch" );
+}
+
+
+# these work
+can_ok( Foo->new->dancer, "pirouette" );
+can_ok( Foo->new->dancer, "twist" );
+
+can_ok( Foo->new, "twist" );
+ok( !Foo->new->can("pirouette"), "can't pirouette, not part of the iface" );
+
+{
+ local $TODO = "handles role doesn't add the role to the ->does of the delegate's parent class";
+ ok( Foo->new->does("Dancer") );
+}
+
+
+
+
+my $gorch = Gorch->meta;
+
+isa_ok( $gorch, "Mouse::Meta::Role" );
+
+ok( $gorch->has_attribute("attr"), "has attribute 'attr'" );
+isa_ok( $gorch->get_attribute("attr"), "Mouse::Meta::Role::Attribute" );
+
+req_or_has($gorch, "gorch_method");
+ok( $gorch->has_method("gorch_method"), "has_method gorch_method" );
+ok( !$gorch->requires_method("gorch_method"), "requires gorch method" );
+isa_ok( $gorch->get_method("gorch_method"), "Mouse::Meta::Method" );
+
+{
+ local $TODO = "method modifier doesn't yet create a method requirement or meta object";
+ req_or_has($gorch, "dandy" );
+
+ # this specific test is maybe not backwards compat, but in theory it *does*
+ # require that method to exist
+ ok( $gorch->requires_method("dandy"), "requires the dandy method for the modifier" );
+}
+
+{
+ local $TODO = "attribute related methods are not yet known by the role";
+ # we want this to be a part of the interface, somehow
+ req_or_has($gorch, "attr");
+ ok( $gorch->has_method("attr"), "has_method attr" );
+ isa_ok( $gorch->get_method("attr"), "Mouse::Meta::Method" );
+ isa_ok( $gorch->get_method("attr"), "Mouse::Meta::Method" );
+}
+
+my $robot = Dancer::Robot->meta;
+
+isa_ok( $robot, "Mouse::Meta::Role" );
+
+ok( $robot->has_attribute("twist"), "has attr 'twist'" );
+isa_ok( $robot->get_attribute("twist"), "Mouse::Meta::Role::Attribute" );
+
+{
+ req_or_has($robot, "twist");
+
+ local $TODO = "attribute related methods are not yet known by the role";
+ ok( $robot->has_method("twist"), "has twist method" );
+ isa_ok( $robot->get_method("twist"), "Mouse::Meta::Method" );
+ isa_ok( $robot->get_method("twist"), "Mouse::Meta::Method" );
+}
+
+done_testing;
+
+__END__
+
+I think Attribute needs to be refactored in some way to better support roles.
+
+There are several possible ways to do this, all of them seem plausible to me.
+
+The first approach would be to change the attribute class to allow it to be
+queried about the methods it would install.
+
+Then we instantiate the attribute in the role, and instead of deferring the
+arguments, we just make an C<unpack>ish method.
+
+Then we can interrogate the attr when adding it to the role, and generate stub
+methods for all the methods it would produce.
+
+A second approach is kinda like the Immutable hack: wrap the attr in an
+anonmyous class that disables part of its interface.
+
+A third method would be to create an Attribute::Partial object that would
+provide a more role-ish behavior, and to do this independently of the actual
+Attribute class.
+
+Something similar can be done for method modifiers, but I think that's even simpler.
+
+
+
+The benefits of doing this are:
+
+* Much better introspection of roles
+
+* More correctness in many cases (in my opinion anyway)
+
+* More roles are more usable as interface declarations, without having to split
+ them into two pieces (one for the interface with a bunch of requires(), and
+ another for the actual impl with the problematic attrs (and stub methods to
+ fix the accessors) and method modifiers (dunno if this can even work at all)
+
+
--- /dev/null
+#!/usr/bin/env perl
+# This is automatically generated by author/import-moose-test.pl.
+# DO NOT EDIT THIS FILE. ANY CHANGES WILL BE LOST!!!
+use t::lib::MooseCompat;
+use strict;
+use warnings;
+use Test::More;
+$TODO = q{Mouse is not yet completed};
+
+{
+ package Foo::Role;
+ use Mouse::Role;
+ has 'a' => (is => 'ro');
+ has 'b' => (is => 'ro');
+ has 'c' => (is => 'ro');
+}
+
+{
+ package Foo;
+ use Mouse;
+ has 'd' => (is => 'ro');
+ with 'Foo::Role';
+ has 'e' => (is => 'ro');
+}
+
+my %role_insertion_order = (
+ a => 0,
+ b => 1,
+ c => 2,
+);
+
+is_deeply({ map { $_->name => $_->insertion_order } map { Foo::Role->meta->get_attribute($_) } Foo::Role->meta->get_attribute_list }, \%role_insertion_order, "right insertion order within the role");
+
+my %class_insertion_order = (
+ d => 0,
+ a => 1,
+ b => 2,
+ c => 3,
+ e => 4,
+);
+
+{ local $TODO = "insertion order is lost during role application";
+is_deeply({ map { $_->name => $_->insertion_order } Foo->meta->get_all_attributes }, \%class_insertion_order, "right insertion order within the class");
+}
+
+done_testing;
+++ /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/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;
-
-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/env perl
-use strict;
-use warnings;
-use Test::More tests => 1;
-
-do {
- package My::Meta::Role;
- use Mouse;
- BEGIN { extends 'Mouse::Meta::Role' };
-};
-
-do {
- package My::Role;
- use Mouse::Role -metaclass => 'My::Meta::Role';
-};
-
-is(My::Role->meta->meta->name, 'My::Meta::Role');
-
+++ /dev/null
-#!/usr/bin/perl
-use strict;
-use warnings;
-
-use Test::More tests => 2;
-use Test::Exception;
-
-{
- package Bomb;
- use Mouse::Role;
-
- sub fuse { }
- sub explode { }
-
- package Spouse;
- use Mouse::Role;
-
- sub fuse { }
- sub explode { }
-
- package Caninish;
- use Mouse::Role;
-
- sub bark { }
-
- package Treeve;
- use Mouse::Role;
-
- sub bark { }
-}
-
-package PracticalJoke;
-use Mouse;
-
-::throws_ok {
- with 'Bomb', 'Spouse';
-} qr/Due to method name conflicts in roles 'Bomb' and 'Spouse', the methods 'explode' and 'fuse' must be implemented or excluded by 'PracticalJoke'/;
-
-::throws_ok {
- with (
- 'Bomb', 'Spouse',
- 'Caninish', 'Treeve',
- );
-} qr/Due to a method name conflict in roles 'Caninish' and 'Treeve', the method 'bark' must be implemented or excluded by 'PracticalJoke'/;
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 4;
-use Test::Exception;
-
-{
- package Foo;
-
- use Mouse::Util::TypeConstraints;
-
- eval {
- type MyRef => where { ref($_) };
- };
- ::ok( !$@, '... successfully exported &type to Foo package' );
-
- eval {
- subtype MyArrayRef => as MyRef => where { ref($_) eq 'ARRAY' };
- };
- ::ok( !$@, '... successfully exported &subtype to Foo package' );
-
- Mouse::Util::TypeConstraints->export_type_constraints_as_functions();
-
- ::ok( MyRef( {} ), '... Ref worked correctly' );
- ::ok( MyArrayRef( [] ), '... ArrayRef worked correctly' );
-}
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use lib 't/lib', 'lib';
-
-use Test::More tests => 4;
-use Test::Exception;
-
-
-
-$SIG{__WARN__} = sub { 0 };
-
-eval { require Foo; };
-ok(!$@, '... loaded Foo successfully') || diag $@;
-
-delete $INC{'Foo.pm'};
-
-eval { require Foo; };
-ok(!$@, '... re-loaded Foo successfully') || diag $@;
-
-eval { require Bar; };
-ok(!$@, '... loaded Bar successfully') || diag $@;
-
-delete $INC{'Bar.pm'};
-
-eval { require Bar; };
-ok(!$@, '... re-loaded Bar successfully') || diag $@;
\ No newline at end of file
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 24;
-use Test::Exception;
-
-BEGIN {
- use_ok('Mouse::Util::TypeConstraints');
- use_ok('Mouse::Meta::TypeConstraint::Parameterized');
-}
-
-# Array of Ints
-
-my $array_of_ints = Mouse::Meta::TypeConstraint::Parameterized->new(
- name => 'ArrayRef[Int]',
- parent => find_type_constraint('ArrayRef'),
- type_parameter => find_type_constraint('Int'),
-);
-isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized');
-isa_ok($array_of_ints, 'Mouse::Meta::TypeConstraint');
-
-ok($array_of_ints->check([ 1, 2, 3, 4 ]), '... [ 1, 2, 3, 4 ] passed successfully');
-ok(!$array_of_ints->check([qw/foo bar baz/]), '... [qw/foo bar baz/] failed successfully');
-ok(!$array_of_ints->check([ 1, 2, 3, qw/foo bar/]), '... [ 1, 2, 3, qw/foo bar/] failed successfully');
-
-ok(!$array_of_ints->check(1), '... 1 failed successfully');
-ok(!$array_of_ints->check({}), '... {} failed successfully');
-ok(!$array_of_ints->check(sub { () }), '... sub { () } failed successfully');
-
-# Hash of Ints
-
-my $hash_of_ints = Mouse::Meta::TypeConstraint::Parameterized->new(
- name => 'HashRef[Int]',
- parent => find_type_constraint('HashRef'),
- type_parameter => find_type_constraint('Int'),
-);
-isa_ok($hash_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized');
-isa_ok($hash_of_ints, 'Mouse::Meta::TypeConstraint');
-
-ok($hash_of_ints->check({ one => 1, two => 2, three => 3 }), '... { one => 1, two => 2, three => 3 } passed successfully');
-ok(!$hash_of_ints->check({ 1 => 'one', 2 => 'two', 3 => 'three' }), '... { 1 => one, 2 => two, 3 => three } failed successfully');
-ok(!$hash_of_ints->check({ 1 => 'one', 2 => 'two', three => 3 }), '... { 1 => one, 2 => two, three => 3 } failed successfully');
-
-ok(!$hash_of_ints->check(1), '... 1 failed successfully');
-ok(!$hash_of_ints->check([]), '... [] failed successfully');
-ok(!$hash_of_ints->check(sub { () }), '... sub { () } failed successfully');
-
-# Array of Array of Ints
-
-my $array_of_array_of_ints = Mouse::Meta::TypeConstraint::Parameterized->new(
- name => 'ArrayRef[ArrayRef[Int]]',
- parent => find_type_constraint('ArrayRef'),
- type_parameter => $array_of_ints,
-);
-isa_ok($array_of_array_of_ints, 'Mouse::Meta::TypeConstraint::Parameterized');
-isa_ok($array_of_array_of_ints, 'Mouse::Meta::TypeConstraint');
-
-ok($array_of_array_of_ints->check(
- [[ 1, 2, 3 ], [ 4, 5, 6 ]]
-), '... [[ 1, 2, 3 ], [ 4, 5, 6 ]] passed successfully');
-ok(!$array_of_array_of_ints->check(
- [[ 1, 2, 3 ], [ qw/foo bar/ ]]
-), '... [[ 1, 2, 3 ], [ qw/foo bar/ ]] failed successfully');
-
-{
- my $anon_type = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('ArrayRef[Foo]');
- isa_ok( $anon_type, 'Mouse::Meta::TypeConstraint::Parameterized' );
-
- my $param_type = $anon_type->type_parameter;
- isa_ok( $param_type, 'Mouse::Meta::TypeConstraint::Class' );
-}
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 28;
-use Test::Exception;
-
-BEGIN {
- use_ok("Mouse::Util::TypeConstraints");
- use_ok('Mouse::Meta::TypeConstraint::Parameterized');
-}
-
-lives_ok {
- subtype 'AlphaKeyHash' => as 'HashRef'
- => where {
- # no keys match non-alpha
- (grep { /[^a-zA-Z]/ } keys %$_) == 0
- };
-} '... created the subtype special okay';
-
-lives_ok {
- subtype 'Trihash' => as 'AlphaKeyHash'
- => where {
- keys(%$_) == 3
- };
-} '... created the subtype special okay';
-
-lives_ok {
- subtype 'Noncon' => as 'Item';
-} '... created the subtype special okay';
-
-{
- my $t = find_type_constraint('AlphaKeyHash');
- isa_ok($t, 'Mouse::Meta::TypeConstraint');
-
- is($t->name, 'AlphaKeyHash', '... name is correct');
-
- my $p = $t->parent;
- isa_ok($p, 'Mouse::Meta::TypeConstraint');
-
- is($p->name, 'HashRef', '... parent name is correct');
-
- ok($t->check({ one => 1, two => 2 }), '... validated it correctly');
- ok(!$t->check({ one1 => 1, two2 => 2 }), '... validated it correctly');
-
- ok( $t->equals($t), "equals to self" );
- ok( !$t->equals($t->parent), "not equal to parent" );
-}
-
-my $hoi = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('AlphaKeyHash[Int]');
-
-ok($hoi->check({ one => 1, two => 2 }), '... validated it correctly');
-ok(!$hoi->check({ one1 => 1, two2 => 2 }), '... validated it correctly');
-ok(!$hoi->check({ one => 'uno', two => 'dos' }), '... validated it correctly');
-ok(!$hoi->check({ one1 => 'un', two2 => 'deux' }), '... validated it correctly');
-
-ok( $hoi->equals($hoi), "equals to self" );
-ok( !$hoi->equals($hoi->parent), "equals to self" );
-ok( !$hoi->equals(find_type_constraint('AlphaKeyHash')), "not equal to unparametrized self" );
-ok( $hoi->equals( Mouse::Meta::TypeConstraint::Parameterized->new( name => "Blah", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Int") ) ), "equal to clone" );
-ok( !$hoi->equals( Mouse::Meta::TypeConstraint::Parameterized->new( name => "Oink", parent => find_type_constraint("AlphaKeyHash"), type_parameter => find_type_constraint("Str") ) ), "not equal to different parameter" );
-
-my $th = Mouse::Util::TypeConstraints::find_or_parse_type_constraint('Trihash[Bool]');
-
-ok(!$th->check({ one => 1, two => 1 }), '... validated it correctly');
-ok($th->check({ one => 1, two => 0, three => 1 }), '... validated it correctly');
-ok(!$th->check({ one => 1, two => 2, three => 1 }), '... validated it correctly');
-ok(!$th->check({foo1 => 1, bar2 => 0, baz3 => 1}), '... validated it correctly');
-
-dies_ok {
- Mouse::Meta::TypeConstraint::Parameterized->new(
- name => 'Str[Int]',
- parent => find_type_constraint('Str'),
- type_parameter => find_type_constraint('Int'),
- );
-} 'non-containers cannot be parameterized';
-
-dies_ok {
- Mouse::Meta::TypeConstraint::Parameterized->new(
- name => 'Noncon[Int]',
- parent => find_type_constraint('Noncon'),
- type_parameter => find_type_constraint('Int'),
- );
-} 'non-containers cannot be parameterized';
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 12;
-use Test::Exception;
-
-BEGIN {
- use_ok('Mouse::Util::TypeConstraints');
-}
-
-# testing the parameterize method
-
-{
- my $parameterizable = subtype 'parameterizable_hashref', as 'HashRef';
-
- my $parameterized = subtype 'parameterized_hashref', as 'HashRef[Int]';
-
- my $int = Mouse::Util::TypeConstraints::find_type_constraint('Int');
-
- my $from_parameterizable = $parameterizable->parameterize($int);
-
- isa_ok $parameterizable,
- 'Mouse::Meta::TypeConstraint::Parameterizable', =>
- 'Got expected type instance';
-
- package Test::Mouse::Meta::TypeConstraint::Parameterizable;
- use Mouse;
-
- has parameterizable => ( is => 'rw', isa => $parameterizable );
- has parameterized => ( is => 'rw', isa => $parameterized );
- has from_parameterizable => ( is => 'rw', isa => $from_parameterizable );
-}
-
-# Create and check a dummy object
-
-ok my $params = Test::Mouse::Meta::TypeConstraint::Parameterizable->new() =>
- 'Create Dummy object for testing';
-
-isa_ok $params, 'Test::Mouse::Meta::TypeConstraint::Parameterizable' =>
- 'isa correct type';
-
-# test parameterizable
-
-lives_ok sub {
- $params->parameterizable( { a => 'Hello', b => 'World' } );
-} => 'No problem setting parameterizable';
-
-is_deeply $params->parameterizable,
- { a => 'Hello', b => 'World' } => 'Got expected values';
-
-# test parameterized
-
-lives_ok sub {
- $params->parameterized( { a => 1, b => 2 } );
-} => 'No problem setting parameterized';
-
-is_deeply $params->parameterized, { a => 1, b => 2 } => 'Got expected values';
-
-throws_ok sub {
- $params->parameterized( { a => 'Hello', b => 'World' } );
- }, qr/Attribute \(parameterized\) does not pass the type constraint/ =>
- 'parameterized throws expected error';
-
-# test from_parameterizable
-
-lives_ok sub {
- $params->from_parameterizable( { a => 1, b => 2 } );
-} => 'No problem setting from_parameterizable';
-
-is_deeply $params->from_parameterizable,
- { a => 1, b => 2 } => 'Got expected values';
-
-throws_ok sub {
- $params->from_parameterizable( { a => 'Hello', b => 'World' } );
- },
- qr/Attribute \(from_parameterizable\) does not pass the type constraint/
- => 'from_parameterizable throws expected error';
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 4;
-
-use Mouse::Util::TypeConstraints;
-
-
-{
- package Foo;
-
- sub new {
- my $class = shift;
-
- return bless {@_}, $class;
- }
-}
-
-subtype 'FooWithSize'
- => as 'Foo'
- => where { $_[0]->{size} };
-
-
-my $type = find_type_constraint('FooWithSize');
-ok( $type, 'made a FooWithSize constraint' );
-ok( $type->parent, 'type has a parent type' );
-is( $type->parent->name, 'Foo', 'parent type is Foo' );
-isa_ok( $type->parent, 'Mouse::Meta::TypeConstraint::Class',
- 'parent type constraint is a class type' );
+++ /dev/null
-use strict;
-use warnings;
-
-use Test::More tests => 1;
-
-use Mouse::Util::TypeConstraints;
-
-
-eval { Mouse::Util::TypeConstraints::create_type_constraint_union() };
-
-like( $@, qr/\QYou must pass in at least 2 type names to make a union/,
- 'can throw a proper error without Mouse being loaded by the caller' );
+++ /dev/null
-#!/usr/bin/perl
-use strict;
-use warnings;
-
-use Test::More tests => 5;
-use Test::Exception;
-
-{
-
- package Duck;
- use Mouse;
-
- sub quack { }
-
-}
-
-{
-
- package Swan;
- use Mouse;
-
- sub honk { }
-
-}
-
-{
-
- package RubberDuck;
- use Mouse;
-
- sub quack { }
-
-}
-
-{
-
- package DucktypeTest;
- use Mouse;
- use Mouse::Util::TypeConstraints;
-
- duck_type 'DuckType' => qw(quack);
- duck_type 'SwanType' => [qw(honk)];
-
- has duck => (
- isa => 'DuckType',
- is => 'ro',
- lazy_build => 1,
- );
-
- sub _build_duck { Duck->new }
-
- has swan => (
- isa => duck_type( [qw(honk)] ),
- is => 'ro',
- );
-
- has other_swan => (
- isa => 'SwanType',
- is => 'ro',
- );
-
-}
-
-# try giving it a duck
-lives_ok { DucktypeTest->new( duck => Duck->new ) } 'the Duck lives okay';
-
-# try giving it a swan which is like a duck, but not close enough
-throws_ok { DucktypeTest->new( duck => Swan->new ) }
-qr/Swan is missing methods 'quack'/,
- "the Swan doesn't quack";
-
-# try giving it a rubber RubberDuckey
-lives_ok { DucktypeTest->new( swan => Swan->new ) } 'but a Swan can honk';
-
-# try giving it a rubber RubberDuckey
-lives_ok { DucktypeTest->new( duck => RubberDuck->new ) }
-'the RubberDuck lives okay';
-
-# try with the other constraint form
-lives_ok { DucktypeTest->new( other_swan => Swan->new ) } 'but a Swan can honk';
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 16;
-use Test::Exception;
-
-
-
-=pod
-
-This test demonstrates the ability to extend
-Mouse meta-level classes using Mouse itself.
-
-=cut
-
-{
- package My::Meta::Class;
- use Mouse;
-
- extends 'Mouse::Meta::Class';
-
- around 'create_anon_class' => sub {
- my $next = shift;
- my ($self, %options) = @_;
- $options{superclasses} = [ 'Mouse::Object' ]
- unless exists $options{superclasses};
- $next->($self, %options);
- };
-}
-
-my $anon = My::Meta::Class->create_anon_class();
-isa_ok($anon, 'My::Meta::Class');
-isa_ok($anon, 'Mouse::Meta::Class');
-isa_ok($anon, 'Class::MOP::Class');
-
-is_deeply(
- [ $anon->superclasses ],
- [ 'Mouse::Object' ],
- '... got the default superclasses');
-
-{
- package My::Meta::Attribute::DefaultReadOnly;
- use Mouse;
-
- extends 'Mouse::Meta::Attribute';
-
- around 'new' => sub {
- my $next = shift;
- my ($self, $name, %options) = @_;
- $options{is} = 'ro'
- unless exists $options{is};
- $next->($self, $name, %options);
- };
-}
-
-{
- my $attr = My::Meta::Attribute::DefaultReadOnly->new('foo');
- isa_ok($attr, 'My::Meta::Attribute::DefaultReadOnly');
- isa_ok($attr, 'Mouse::Meta::Attribute');
- isa_ok($attr, 'Class::MOP::Attribute');
-
- ok($attr->has_reader, '... the attribute has a reader (as expected)');
- ok(!$attr->has_writer, '... the attribute does not have a writer (as expected)');
- ok(!$attr->has_accessor, '... the attribute does not have an accessor (as expected)');
-}
-
-{
- my $attr = My::Meta::Attribute::DefaultReadOnly->new('foo', (is => 'rw'));
- isa_ok($attr, 'My::Meta::Attribute::DefaultReadOnly');
- isa_ok($attr, 'Mouse::Meta::Attribute');
- isa_ok($attr, 'Class::MOP::Attribute');
-
- ok(!$attr->has_reader, '... the attribute does not have a reader (as expected)');
- ok(!$attr->has_writer, '... the attribute does not have a writer (as expected)');
- ok($attr->has_accessor, '... the attribute does have an accessor (as expected)');
-}
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More;
-use Test::Exception;
-BEGIN {
- eval "use Test::Output;";
- plan skip_all => "Test::Output is required for this test" if $@;
- plan tests => 65;
-}
-
-
-{
- package HasOwnImmutable;
-
- use Mouse;
-
- no Mouse;
-
- ::stderr_is( sub { eval q[sub make_immutable { return 'foo' }] },
- '',
- 'no warning when defining our own make_immutable sub' );
-}
-
-{
- is( HasOwnImmutable->make_immutable(), 'foo',
- 'HasOwnImmutable->make_immutable does not get overwritten' );
-}
-
-{
- package MouseX::Empty;
-
- use Mouse ();
- Mouse::Exporter->setup_import_methods( also => 'Mouse' );
-}
-
-{
- package WantsMouse;
-
- MouseX::Empty->import();
-
- sub foo { 1 }
-
- ::can_ok( 'WantsMouse', 'has' );
- ::can_ok( 'WantsMouse', 'with' );
- ::can_ok( 'WantsMouse', 'foo' );
-
- MouseX::Empty->unimport();
-}
-
-{
- # Note: it's important that these methods be out of scope _now_,
- # after unimport was called. We tried a
- # namespace::clean(0.08)-based solution, but had to abandon it
- # because it cleans the namespace _later_ (when the file scope
- # ends).
- ok( ! WantsMouse->can('has'), 'WantsMouse::has() has been cleaned' );
- ok( ! WantsMouse->can('with'), 'WantsMouse::with() has been cleaned' );
- can_ok( 'WantsMouse', 'foo' );
-
- # This makes sure that Mouse->init_meta() happens properly
- isa_ok( WantsMouse->meta(), 'Mouse::Meta::Class' );
- isa_ok( WantsMouse->new(), 'Mouse::Object' );
-
-}
-
-{
- package MouseX::Sugar;
-
- use Mouse ();
-
- sub wrapped1 {
- my $meta = shift;
- return $meta->name . ' called wrapped1';
- }
-
- Mouse::Exporter->setup_import_methods(
- with_meta => ['wrapped1'],
- also => 'Mouse',
- );
-}
-
-{
- package WantsSugar;
-
- MouseX::Sugar->import();
-
- sub foo { 1 }
-
- ::can_ok( 'WantsSugar', 'has' );
- ::can_ok( 'WantsSugar', 'with' );
- ::can_ok( 'WantsSugar', 'wrapped1' );
- ::can_ok( 'WantsSugar', 'foo' );
- ::is( wrapped1(), 'WantsSugar called wrapped1',
- 'wrapped1 identifies the caller correctly' );
-
- MouseX::Sugar->unimport();
-}
-
-{
- ok( ! WantsSugar->can('has'), 'WantsSugar::has() has been cleaned' );
- ok( ! WantsSugar->can('with'), 'WantsSugar::with() has been cleaned' );
- ok( ! WantsSugar->can('wrapped1'), 'WantsSugar::wrapped1() has been cleaned' );
- can_ok( 'WantsSugar', 'foo' );
-}
-
-{
- package MouseX::MoreSugar;
-
- use Mouse ();
-
- sub wrapped2 {
- my $caller = shift;
- return $caller . ' called wrapped2';
- }
-
- sub as_is1 {
- return 'as_is1';
- }
-
- Mouse::Exporter->setup_import_methods(
- with_caller => ['wrapped2'],
- as_is => ['as_is1'],
- also => 'MouseX::Sugar',
- );
-}
-
-{
- package WantsMoreSugar;
-
- MouseX::MoreSugar->import();
-
- sub foo { 1 }
-
- ::can_ok( 'WantsMoreSugar', 'has' );
- ::can_ok( 'WantsMoreSugar', 'with' );
- ::can_ok( 'WantsMoreSugar', 'wrapped1' );
- ::can_ok( 'WantsMoreSugar', 'wrapped2' );
- ::can_ok( 'WantsMoreSugar', 'as_is1' );
- ::can_ok( 'WantsMoreSugar', 'foo' );
- ::is( wrapped1(), 'WantsMoreSugar called wrapped1',
- 'wrapped1 identifies the caller correctly' );
- ::is( wrapped2(), 'WantsMoreSugar called wrapped2',
- 'wrapped2 identifies the caller correctly' );
- ::is( as_is1(), 'as_is1',
- 'as_is1 works as expected' );
-
- MouseX::MoreSugar->unimport();
-}
-
-{
- ok( ! WantsMoreSugar->can('has'), 'WantsMoreSugar::has() has been cleaned' );
- ok( ! WantsMoreSugar->can('with'), 'WantsMoreSugar::with() has been cleaned' );
- ok( ! WantsMoreSugar->can('wrapped1'), 'WantsMoreSugar::wrapped1() has been cleaned' );
- ok( ! WantsMoreSugar->can('wrapped2'), 'WantsMoreSugar::wrapped2() has been cleaned' );
- ok( ! WantsMoreSugar->can('as_is1'), 'WantsMoreSugar::as_is1() has been cleaned' );
- can_ok( 'WantsMoreSugar', 'foo' );
-}
-
-{
- package My::Metaclass;
- use Mouse;
- BEGIN { extends 'Mouse::Meta::Class' }
-
- package My::Object;
- use Mouse;
- BEGIN { extends 'Mouse::Object' }
-
- package HasInitMeta;
-
- use Mouse ();
-
- sub init_meta {
- shift;
- return Mouse->init_meta( @_,
- metaclass => 'My::Metaclass',
- base_class => 'My::Object',
- );
- }
-
- Mouse::Exporter->setup_import_methods( also => 'Mouse' );
-}
-
-{
- package NewMeta;
-
- HasInitMeta->import();
-}
-
-{
- isa_ok( NewMeta->meta(), 'My::Metaclass' );
- isa_ok( NewMeta->new(), 'My::Object' );
-}
-
-{
- package MouseX::CircularAlso;
-
- use Mouse ();
-
- ::dies_ok(
- sub {
- Mouse::Exporter->setup_import_methods(
- also => [ 'Mouse', 'MouseX::CircularAlso' ],
- );
- },
- 'a circular reference in also dies with an error'
- );
-
- ::like(
- $@,
- qr/\QCircular reference in 'also' parameter to Mouse::Exporter between MouseX::CircularAlso and MouseX::CircularAlso/,
- 'got the expected error from circular reference in also'
- );
-}
-
-{
- package MouseX::NoAlso;
-
- use Mouse ();
-
- ::dies_ok(
- sub {
- Mouse::Exporter->setup_import_methods(
- also => [ 'NoSuchThing' ],
- );
- },
- 'a package which does not use Mouse::Exporter in also dies with an error'
- );
-
- ::like(
- $@,
- qr/\QPackage in also (NoSuchThing) does not seem to use Mouse::Exporter (is it loaded?) at /,
- 'got the expected error from a reference in also to a package which is not loaded'
- );
-}
-
-{
- package MouseX::NotExporter;
-
- use Mouse ();
-
- ::dies_ok(
- sub {
- Mouse::Exporter->setup_import_methods(
- also => [ 'Mouse::Meta::Method' ],
- );
- },
- 'a package which does not use Mouse::Exporter in also dies with an error'
- );
-
- ::like(
- $@,
- qr/\QPackage in also (Mouse::Meta::Method) does not seem to use Mouse::Exporter at /,
- 'got the expected error from a reference in also to a package which does not use Mouse::Exporter'
- );
-}
-
-{
- package MouseX::OverridingSugar;
-
- use Mouse ();
-
- sub has {
- my $caller = shift;
- return $caller . ' called has';
- }
-
- Mouse::Exporter->setup_import_methods(
- with_caller => ['has'],
- also => 'Mouse',
- );
-}
-
-{
- package WantsOverridingSugar;
-
- MouseX::OverridingSugar->import();
-
- ::can_ok( 'WantsOverridingSugar', 'has' );
- ::can_ok( 'WantsOverridingSugar', 'with' );
- ::is( has('foo'), 'WantsOverridingSugar called has',
- 'has from MouseX::OverridingSugar is called, not has from Mouse' );
-
- MouseX::OverridingSugar->unimport();
-}
-
-{
- ok( ! WantsSugar->can('has'), 'WantsSugar::has() has been cleaned' );
- ok( ! WantsSugar->can('with'), 'WantsSugar::with() has been cleaned' );
-}
-
-{
- package NonExistentExport;
-
- use Mouse ();
-
- ::stderr_like {
- Mouse::Exporter->setup_import_methods(
- also => ['Mouse'],
- with_caller => ['does_not_exist'],
- );
- } qr/^Trying to export undefined sub NonExistentExport::does_not_exist/,
- "warns when a non-existent method is requested to be exported";
-}
-
-{
- package WantsNonExistentExport;
-
- NonExistentExport->import;
-
- ::ok(!__PACKAGE__->can('does_not_exist'),
- "undefined subs do not get exported");
-}
-
-{
- package AllOptions;
- use Mouse ();
- use Mouse::Exporter;
-
- Mouse::Exporter->setup_import_methods(
- also => ['Mouse'],
- with_meta => [ 'with_meta1', 'with_meta2' ],
- with_caller => [ 'with_caller1', 'with_caller2' ],
- as_is => ['as_is1'],
- );
-
- sub with_caller1 {
- return @_;
- }
-
- sub with_caller2 (&) {
- return @_;
- }
-
- sub as_is1 {2}
-
- sub with_meta1 {
- return @_;
- }
-
- sub with_meta2 (&) {
- return @_;
- }
-}
-
-{
- package UseAllOptions;
-
- AllOptions->import();
-}
-
-{
- can_ok( 'UseAllOptions', $_ )
- for qw( with_meta1 with_meta2 with_caller1 with_caller2 as_is1 );
-
- {
- my ( $caller, $arg1 ) = UseAllOptions::with_caller1(42);
- is( $caller, 'UseAllOptions', 'with_caller wrapped sub gets the right caller' );
- is( $arg1, 42, 'with_caller wrapped sub returns argument it was passed' );
- }
-
- {
- my ( $meta, $arg1 ) = UseAllOptions::with_meta1(42);
- isa_ok( $meta, 'Mouse::Meta::Class', 'with_meta first argument' );
- is( $arg1, 42, 'with_meta1 returns argument it was passed' );
- }
-
- is(
- prototype( UseAllOptions->can('with_caller2') ),
- prototype( AllOptions->can('with_caller2') ),
- 'using correct prototype on with_meta function'
- );
-
- is(
- prototype( UseAllOptions->can('with_meta2') ),
- prototype( AllOptions->can('with_meta2') ),
- 'using correct prototype on with_meta function'
- );
-}
-
-{
- package UseAllOptions;
- AllOptions->unimport();
-}
-
-{
- ok( ! UseAllOptions->can($_), "UseAllOptions::$_ has been unimported" )
- for qw( with_meta1 with_meta2 with_caller1 with_caller2 as_is1 );
-}
+++ /dev/null
-use lib "t/lib";
-package MyExporter::User;
-use MyExporter;
-
-use Test::More (tests => 4);
-use Test::Exception;
-
-lives_and {
- with_prototype {
- my $caller = caller(0);
- is($caller, 'MyExporter', "With_caller prototype code gets called from MyMouseX");
- };
-} "check function with prototype";
-
-lives_and {
- as_is_prototype {
- my $caller = caller(0);
- is($caller, 'MyExporter', "As-is prototype code gets called from MyMouseX");
- };
-} "check function with prototype";
+++ /dev/null
-use strict;
-use warnings;
-{
- package My::Role;
- use Mouse::Role;
-}
-{
- package SomeClass;
- use Mouse -traits => 'My::Role';
-}
-{
- package SubClassUseBase;
- use base qw/SomeClass/;
-}
-{
- package SubSubClassUseBase;
- use base qw/SubClassUseBase/;
-}
-
-use Test::More tests => 2;
-use Mouse::Util qw/find_meta does_role/;
-
-my $subsubclass_meta = Mouse->init_meta( for_class => 'SubSubClassUseBase' );
-ok does_role($subsubclass_meta, 'My::Role'),
- 'SubSubClass metaclass does role from grandparent metaclass';
-my $subclass_meta = find_meta('SubClassUseBase');
-ok does_role($subclass_meta, 'My::Role'),
- 'SubClass metaclass does role from parent metaclass';
projects / gitmo/Mouse.git / commitdiff