has 'bar' => (is => 'rw', does => 'Bar::Role');
has 'baz' => (
is => 'rw',
- does => role_type('Bar::Role')
+ does => 'Bar::Role'
);
package Bar::Role;
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+=pod
+
+This is a test for a bug found by Purge on #moose:
+The code:
+
+ subtype Stuff
+ => as Object
+ => where { ... }
+
+will break if the Object:: namespace exists. So the
+solution is to quote 'Object', like so:
+
+ subtype Stuff
+ => as 'Object'
+ => where { ... }
+
+Mouse 0.03 did this, now it doesn't, so all should
+be well from now on.
+
+=cut
+
+{ package Object::Test; }
+
+package Foo;
+::use_ok('Mouse');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib 't/lib', 'lib';
+
+use Test::More tests => 2;
+
+
+
+use_ok('MyMouseA');
+use_ok('MyMouseB');
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib 't/lib', 'lib';
+
+use Test::More tests => 1;
+
+use_ok('MyMouseObject');
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+
+
+=pod
+
+This just makes sure that the Bar gets
+a metaclass initialized for it correctly.
+
+=cut
+
+{
+ package Foo;
+ use Mouse;
+
+ package Bar;
+ use strict;
+ use warnings;
+
+ use base 'Foo';
+}
+
+my $bar = Bar->new;
+isa_ok($bar, 'Bar');
+isa_ok($bar, 'Foo');
\ No newline at end of file
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+use Test::Exception;
+
+
+
+=pod
+
+This was a bug, but it is fixed now. This
+test makes sure it does not creep back in.
+
+=cut
+
+{
+ package Foo;
+ use Mouse;
+
+ ::lives_ok {
+ has 'bar' => (
+ is => 'ro',
+ isa => 'Int',
+ lazy => 1,
+ default => 10,
+ );
+ } '... this didnt die';
+}
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+{
+ package Foo;
+ use Mouse;
+ has 'foo' => ( is => 'ro', reader => 'get_foo' );
+}
+
+{
+ my $foo = Foo->new(foo => 10);
+ my $reader = $foo->meta->get_attribute('foo')->reader;
+ is($reader, 'get_foo',
+ 'reader => "get_foo" has correct presedence');
+ can_ok($foo, 'get_foo');
+ is($foo->$reader, 10, "Reader works as expected");
+}
+
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ sub foo { 'Foo::foo(' . (inner() || '') . ')' };
+
+ package Bar;
+ use Mouse;
+
+ extends 'Foo';
+
+ package Baz;
+ use Mouse;
+
+ extends 'Foo';
+
+ my $foo_call_counter;
+ augment 'foo' => sub {
+ die "infinite loop on Baz::foo" if $foo_call_counter++ > 1;
+ return 'Baz::foo and ' . Bar->new->foo;
+ };
+}
+
+my $baz = Baz->new();
+isa_ok($baz, 'Baz');
+isa_ok($baz, 'Foo');
+
+=pod
+
+When a subclass which augments foo(), calls a subclass which does not augment
+foo(), there is a chance for some confusion. If Mouse does not realize that
+Bar does not augment foo(), because it is in the call flow of Baz which does,
+then we may have an infinite loop.
+
+=cut
+
+is($baz->foo,
+ 'Foo::foo(Baz::foo and Foo::foo())',
+ '... got the right value for 1 augmented subclass calling non-augmented subclass');
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+
+
+
+{
+ package Foo;
+ use Mouse;
+
+ our $foo_default_called = 0;
+
+ has foo => (
+ is => 'rw',
+ isa => 'Str',
+ default => sub { $foo_default_called++; 'foo' },
+ );
+
+ our $bar_default_called = 0;
+
+ has bar => (
+ is => 'rw',
+ isa => 'Str',
+ lazy => 1,
+ default => sub { $bar_default_called++; 'bar' },
+ );
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+my $foo = Foo->new();
+
+is($Foo::foo_default_called, 1, "foo default was only called once during constructor");
+
+$foo->bar();
+
+is($Foo::bar_default_called, 1, "bar default was only called once when lazy attribute is accessed");
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use FindBin;
+
+use Test::More tests => 144;
+use Test::Exception;
+
+use Mouse::Util::TypeConstraints;
+
+subtype 'FilePath'
+ => as 'Str'
+ # This used to try to _really_ check for a valid Unix or Windows
+ # path, but the regex wasn't quite right, and all we care about
+ # for the tests is that it rejects '/'
+ => where { $_ ne '/' };
+{
+ package Baz;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ has 'path' => (
+ is => 'ro',
+ isa => 'FilePath',
+ required => 1,
+ );
+
+ sub BUILD {
+ my ( $self, $params ) = @_;
+ confess $params->{path} . " does not exist"
+ unless -e $params->{path};
+ }
+
+ # Defining this causes the FIRST call to Baz->new w/o param to fail,
+ # if no call to ANY Mouse::Object->new was done before.
+ sub DEMOLISH {
+ my ( $self ) = @_;
+ }
+}
+
+{
+ package Qee;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ has 'path' => (
+ is => 'ro',
+ isa => 'FilePath',
+ required => 1,
+ );
+
+ sub BUILD {
+ my ( $self, $params ) = @_;
+ confess $params->{path} . " does not exist"
+ unless -e $params->{path};
+ }
+
+ # Defining this causes the FIRST call to Qee->new w/o param to fail...
+ # if no call to ANY Mouse::Object->new was done before.
+ sub DEMOLISH {
+ my ( $self ) = @_;
+ }
+}
+
+{
+ package Foo;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ has 'path' => (
+ is => 'ro',
+ isa => 'FilePath',
+ required => 1,
+ );
+
+ sub BUILD {
+ my ( $self, $params ) = @_;
+ confess $params->{path} . " does not exist"
+ unless -e $params->{path};
+ }
+
+ # Having no DEMOLISH, everything works as expected...
+}
+
+check_em ( 'Baz' ); # 'Baz plain' will fail, aka NO error
+check_em ( 'Qee' ); # ok
+check_em ( 'Foo' ); # ok
+
+check_em ( 'Qee' ); # 'Qee plain' will fail, aka NO error
+check_em ( 'Baz' ); # ok
+check_em ( 'Foo' ); # ok
+
+check_em ( 'Foo' ); # ok
+check_em ( 'Baz' ); # ok !
+check_em ( 'Qee' ); # ok
+
+
+sub check_em {
+ my ( $pkg ) = @_;
+ my ( %param, $obj );
+
+ # Uncomment to see, that it is really any first call.
+ # Subsequents calls will not fail, aka giving the correct error.
+ {
+ local $@;
+ my $obj = eval { $pkg->new; };
+ ::like( $@, qr/is required/, "... $pkg plain" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new(); };
+ ::like( $@, qr/is required/, "... $pkg empty" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( notanattr => 1 ); };
+ ::like( $@, qr/is required/, "... $pkg undef" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( %param ); };
+ ::like( $@, qr/is required/, "... $pkg undef param" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( path => '/' ); };
+ ::like( $@, qr/does not pass the type constraint/, "... $pkg root path forbidden" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( path => '/this_path/does/not_exist' ); };
+ ::like( $@, qr/does not exist/, "... $pkg non existing path" );
+ ::is( $obj, undef, "... the object is undef" );
+ }
+ {
+ local $@;
+ my $obj = eval { $pkg->new ( path => $FindBin::Bin ); };
+ ::is( $@, '', "... $pkg no error" );
+ ::isa_ok( $obj, $pkg );
+ ::isa_ok( $obj, 'Mouse::Object' );
+ ::is( $obj->path, $FindBin::Bin, "... $pkg got the right value" );
+ }
+}
+
+1;
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 12;
+use Test::Exception;
+
+
+{
+ package Foo;
+ use Mouse;
+
+ has 'bar' => (
+ is => 'ro',
+ required => 1,
+ );
+
+ # Defining this causes the FIRST call to Baz->new w/o param to fail,
+ # if no call to ANY Mouse::Object->new was done before.
+ sub DEMOLISH {
+ my ( $self ) = @_;
+ # ... Mouse (kinda) eats exceptions in DESTROY/DEMOLISH";
+ }
+}
+
+{
+ my $obj = eval { Foo->new; };
+ like( $@, qr/is required/, "... Foo plain" );
+ is( $obj, undef, "... the object is undef" );
+}
+
+{
+ package Bar;
+
+ sub new { die "Bar died"; }
+
+ sub DESTROY {
+ die "Vanilla Perl eats exceptions in DESTROY too";
+ }
+}
+
+{
+ my $obj = eval { Bar->new; };
+ like( $@, qr/Bar died/, "... Bar plain" );
+ is( $obj, undef, "... the object is undef" );
+}
+
+{
+ package Baz;
+ use Mouse;
+
+ sub DEMOLISH {
+ $? = 0;
+ }
+}
+
+{
+ local $@ = 42;
+ local $? = 84;
+
+ {
+ Baz->new;
+ }
+
+ is( $@, 42, '$@ is still 42 after object is demolished without dying' );
+ is( $?, 84, '$? is still 84 after object is demolished without dying' );
+
+ local $@ = 0;
+
+ {
+ Baz->new;
+ }
+
+ is( $@, 0, '$@ is still 0 after object is demolished without dying' );
+
+ Baz->meta->make_immutable, redo
+ if Baz->meta->is_mutable
+}
+
+{
+ package Quux;
+ use Mouse;
+
+ sub DEMOLISH {
+ die "foo\n";
+ }
+}
+
+{
+ local $@ = 42;
+
+ eval { my $obj = Quux->new };
+
+ like( $@, qr/foo/, '$@ contains error from demolish when demolish dies' );
+
+ Quux->meta->make_immutable, redo
+ if Quux->meta->is_mutable
+}
+
--- /dev/null
+package Foo;
+use Mouse;
+
+## Problem:
+## lazy_build sets required => 1
+## required does not permit setting to undef
+
+## Possible solutions:
+#### remove required => 1
+#### check the attr to see if it accepts Undef (Maybe[], | Undef)
+#### or, make required accept undef and use a predicate test
+
+
+has 'foo' => ( isa => 'Int | Undef', is => 'rw', coerce => 1, lazy_build => 1 );
+has 'bar' => ( isa => 'Int | Undef', is => 'rw', coerce => 1 );
+
+sub _build_foo { undef }
+
+package main;
+use Test::More tests => 4;
+
+ok ( !defined(Foo->new->bar), 'NonLazyBuild: Undef default' );
+ok ( !defined(Foo->new->bar(undef)), 'NonLazyBuild: Undef explicit' );
+
+ok ( !defined(Foo->new->foo), 'LazyBuild: Undef default/lazy_build' );
+
+## This test fails at the time of creation.
+ok ( !defined(Foo->new->foo(undef)), 'LazyBuild: Undef explicit' );
+
+
+1;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 5;
+
+my @called;
+
+do {
+ package Class;
+ use Mouse;
+
+ sub DEMOLISH {
+ push @called, 'Class::DEMOLISH';
+ }
+
+ sub DEMOLISHALL {
+ my $self = shift;
+ push @called, 'Class::DEMOLISHALL';
+ $self->SUPER::DEMOLISHALL(@_);
+ }
+
+ package Child;
+ use Mouse;
+ extends 'Class';
+
+ sub DEMOLISH {
+ push @called, 'Child::DEMOLISH';
+ }
+
+ sub DEMOLISHALL {
+ my $self = shift;
+ push @called, 'Child::DEMOLISHALL';
+ $self->SUPER::DEMOLISHALL(@_);
+ }
+};
+
+is_deeply([splice @called], [], "no DEMOLISH calls yet");
+
+do {
+ my $object = Class->new;
+
+ is_deeply([splice @called], [], "no DEMOLISH calls yet");
+};
+
+is_deeply([splice @called], ['Class::DEMOLISHALL', 'Class::DEMOLISH']);
+
+do {
+ my $child = Child->new;
+ is_deeply([splice @called], [], "no DEMOLISH calls yet");
+
+};
+
+is_deeply([splice @called], ['Child::DEMOLISHALL', 'Class::DEMOLISHALL', 'Child::DEMOLISH', 'Class::DEMOLISH']);
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+use Test::Exception;
+
+
+
+{
+ package My::Role;
+ use Mouse::Role;
+}
+{
+ package My::Class;
+ use Mouse;
+
+ ::throws_ok {
+ extends 'My::Role';
+ } qr/You cannot inherit from a Mouse Role \(My\:\:Role\)/,
+ '... this croaks correctly';
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+use Test::Exception;
+
+
+
+# RT #37569
+
+{
+ package MyObject;
+ use Mouse;
+
+ package Foo;
+ use Mouse;
+ use Mouse::Util::TypeConstraints;
+
+ subtype 'MyArrayRef'
+ => as 'ArrayRef'
+ => where { defined $_->[0] }
+ => message { ref $_ ? "ref: ". ref $_ : 'scalar' } # stringy
+ ;
+
+ subtype 'MyObjectType'
+ => as 'Object'
+ => where { $_->isa('MyObject') }
+ => message {
+ if ( $_->isa('SomeObject') ) {
+ return 'More detailed error message';
+ }
+ elsif ( blessed $_ ) {
+ return 'Well it is an object';
+ }
+ else {
+ return 'Doh!';
+ }
+ }
+ ;
+
+ type 'NewType'
+ => where { $_->isa('MyObject') }
+ => message { blessed $_ ? 'blessed' : 'scalar' }
+ ;
+
+ has 'obj' => ( is => 'rw', isa => 'MyObjectType' );
+ has 'ar' => ( is => 'rw', isa => 'MyArrayRef' );
+ has 'nt' => ( is => 'rw', isa => 'NewType' );
+}
+
+my $foo = Foo->new;
+my $obj = MyObject->new;
+
+throws_ok {
+ $foo->ar( [] );
+}
+qr/Attribute \(ar\) does not pass the type constraint because: ref: ARRAY/,
+ '... got the right error message';
+
+throws_ok {
+ $foo->obj($foo); # Doh!
+}
+qr/Attribute \(obj\) does not pass the type constraint because: Well it is an object/,
+ '... got the right error message';
+
+throws_ok {
+ $foo->nt($foo); # scalar
+}
+qr/Attribute \(nt\) does not pass the type constraint because: blessed/,
+ '... got the right error message';
+
--- /dev/null
+#!/usr/bin/env perl
+use Test::More tests => 10;
+
+{
+ my $package = qq{
+package Test::Mouse::Go::Boom;
+use Mouse;
+use lib qw(lib);
+
+has id => (
+ isa => 'Str',
+ is => 'ro',
+ default => '019600', # this caused the original failure
+);
+
+no Mouse;
+
+__PACKAGE__->meta->make_immutable;
+};
+
+ eval $package;
+ $@ ? ::fail($@) : ::pass('quoted 019600 default works');
+ my $obj = Test::Mouse::Go::Boom->new;
+ ::is( $obj->id, '019600', 'value is still the same' );
+}
+
+{
+ my $package = qq{
+package Test::Mouse::Go::Boom2;
+use Mouse;
+use lib qw(lib);
+
+has id => (
+ isa => 'Str',
+ is => 'ro',
+ default => 017600,
+);
+
+no Mouse;
+
+__PACKAGE__->meta->make_immutable;
+};
+
+ eval $package;
+ $@ ? ::fail($@) : ::pass('017600 octal default works');
+ my $obj = Test::Mouse::Go::Boom2->new;
+ ::is( $obj->id, 8064, 'value is still the same' );
+}
+
+{
+ my $package = qq{
+package Test::Mouse::Go::Boom3;
+use Mouse;
+use lib qw(lib);
+
+has id => (
+ isa => 'Str',
+ is => 'ro',
+ default => 0xFF,
+);
+
+no Mouse;
+
+__PACKAGE__->meta->make_immutable;
+};
+
+ eval $package;
+ $@ ? ::fail($@) : ::pass('017600 octal default works');
+ my $obj = Test::Mouse::Go::Boom3->new;
+ ::is( $obj->id, 255, 'value is still the same' );
+}
+
+{
+ my $package = qq{
+package Test::Mouse::Go::Boom4;
+use Mouse;
+use lib qw(lib);
+
+has id => (
+ isa => 'Str',
+ is => 'ro',
+ default => '0xFF',
+);
+
+no Mouse;
+
+__PACKAGE__->meta->make_immutable;
+};
+
+ eval $package;
+ $@ ? ::fail($@) : ::pass('017600 octal default works');
+ my $obj = Test::Mouse::Go::Boom4->new;
+ ::is( $obj->id, '0xFF', 'value is still the same' );
+}
+
+{
+ my $package = qq{
+package Test::Mouse::Go::Boom5;
+use Mouse;
+use lib qw(lib);
+
+has id => (
+ isa => 'Str',
+ is => 'ro',
+ default => '0 but true',
+);
+
+no Mouse;
+
+__PACKAGE__->meta->make_immutable;
+};
+
+ eval $package;
+ $@ ? ::fail($@) : ::pass('017600 octal default works');
+ my $obj = Test::Mouse::Go::Boom5->new;
+ ::is( $obj->id, '0 but true', 'value is still the same' );
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+
+{
+ package A;
+ use Mouse;
+
+ sub foo {
+ ::BAIL_OUT('A::foo called twice') if $main::seen{'A::foo'}++;
+ return 'a';
+ }
+
+ sub bar {
+ ::BAIL_OUT('A::bar called twice') if $main::seen{'A::bar'}++;
+ return 'a';
+ }
+
+ sub baz {
+ ::BAIL_OUT('A::baz called twice') if $main::seen{'A::baz'}++;
+ return 'a';
+ }
+}
+
+{
+ package B;
+ use Mouse;
+ extends qw(A);
+
+ sub foo {
+ ::BAIL_OUT('B::foo called twice') if $main::seen{'B::foo'}++;
+ return 'b' . super();
+ }
+
+ sub bar {
+ ::BAIL_OUT('B::bar called twice') if $main::seen{'B::bar'}++;
+ return 'b' . ( super() || '' );
+ }
+
+ override baz => sub {
+ ::BAIL_OUT('B::baz called twice') if $main::seen{'B::baz'}++;
+ return 'b' . super();
+ };
+}
+
+{
+ package C;
+ use Mouse;
+ extends qw(B);
+
+ sub foo { return 'c' . ( super() || '' ) }
+
+ override bar => sub {
+ ::BAIL_OUT('C::bar called twice') if $main::seen{'C::bar'}++;
+ return 'c' . super();
+ };
+
+ override baz => sub {
+ ::BAIL_OUT('C::baz called twice') if $main::seen{'C::baz'}++;
+ return 'c' . super();
+ };
+}
+
+is( C->new->foo, 'c' );
+is( C->new->bar, 'cb' );
+is( C->new->baz, 'cba' );
--- /dev/null
+## This test ensures that sub DEMOLISHALL fires even if there is no sub DEMOLISH
+## Currently fails because of a bad optimization in DESTROY
+## Feb 12, 2009 -- Evan Carroll me@evancarroll.com
+package Role::DemolishAll;
+use Mouse::Role;
+our $ok = 0;
+
+sub BUILD { $ok = 0 };
+after 'DEMOLISHALL' => sub { $Role::DemolishAll::ok++ };
+
+package DemolishAll::WithoutDemolish;
+use Mouse;
+with 'Role::DemolishAll';
+
+package DemolishAll::WithDemolish;
+use Mouse;
+with 'Role::DemolishAll';
+sub DEMOLISH {};
+
+
+package main;
+use Test::More tests => 2;
+
+my $m = DemolishAll::WithDemolish->new;
+undef $m;
+is ( $Role::DemolishAll::ok, 1, 'DemolishAll w/ explicit DEMOLISH sub' );
+
+$m = DemolishAll::WithoutDemolish->new;
+undef $m;
+is ( $Role::DemolishAll::ok, 1, 'DemolishAll wo/ explicit DEMOLISH sub' );
+
+1;
--- /dev/null
+package MyRole;
+
+use Mouse::Role;
+
+sub foo { return (caller(0))[3] }
+
+no Mouse::Role;
+
+package MyClass1; use Mouse; with 'MyRole'; no Mouse;
+package MyClass2; use Mouse; with 'MyRole'; no Mouse;
+
+package main;
+
+use Test::More tests => 4;
+
+{
+ local $TODO = 'Role composition does not clone methods yet';
+ is(MyClass1->foo, 'MyClass1::foo',
+ 'method from role has correct name in caller()');
+ is(MyClass2->foo, 'MyClass2::foo',
+ 'method from role has correct name in caller()');
+}
+
+isnt(MyClass1->foo, "MyClass2::foo", "role method is not confused with other class" );
+isnt(MyClass2->foo, "MyClass1::foo", "role method is not confused with other class" );
--- /dev/null
+use strict;
+use warnings;
+
+use Test::Exception;
+use Test::More tests => 2;
+
+{
+
+ package FakeBar;
+ use Mouse::Role;
+
+ around isa => sub {
+ my ( $orig, $self, $v ) = @_;
+ return 1 if $v eq 'Bar';
+ return $orig->( $self, $v );
+ };
+
+ package Foo;
+ use Mouse;
+
+ use Test::More; # for $TODO
+
+ local $TODO = 'UNIVERSAL methods should be wrappable';
+
+ ::lives_ok { with 'FakeBar' } 'applied role';
+
+ my $foo = Foo->new;
+ ::isa_ok $foo, 'Bar';
+}
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+use Test::Exception;
+
+use Mouse::Meta::Class;
+
+$SIG{__WARN__} = sub { die if shift =~ /recurs/ };
+
+TODO:
+{
+# local $TODO
+# = 'Loading Mouse::Meta::Class without loading Mouse.pm causes weird problems';
+
+ my $meta;
+ lives_ok {
+ $meta = Mouse::Meta::Class->create_anon_class(
+ superclasses => [ 'Mouse::Object', ],
+ );
+ }
+ 'Class is created successfully';
+}
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+use Test::More tests => 1;
+
+{
+ package Foo;
+
+ use Mouse;
+
+ use overload '""' => sub {''};
+
+ sub bug { 'plenty' }
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+ok(Foo->new()->bug(), 'call constructor on object reference with overloading');
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 15;
+use Test::Exception;
+
+{
+ package Foo;
+
+ sub new {
+ bless({}, 'Foo')
+ }
+
+ sub a { 'Foo::a' }
+}
+
+{
+ package Bar;
+ use Mouse;
+
+ ::lives_ok {
+ has 'baz' => (
+ is => 'ro',
+ isa => 'Foo',
+ lazy => 1,
+ default => sub { Foo->new() },
+ handles => qr/^a$/,
+ );
+ } '... can create the attribute with delegations';
+
+}
+
+my $bar;
+lives_ok {
+ $bar = Bar->new;
+} '... created the object ok';
+isa_ok($bar, 'Bar');
+
+is($bar->a, 'Foo::a', '... got the right delgated value');
+
+my @w;
+$SIG{__WARN__} = sub { push @w, "@_" };
+{
+ package Baz;
+ use Mouse;
+
+ ::lives_ok {
+ has 'bar' => (
+ is => 'ro',
+ isa => 'Foo',
+ lazy => 1,
+ default => sub { Foo->new() },
+ handles => qr/.*/,
+ );
+ } '... can create the attribute with delegations';
+
+}
+
+is(@w, 0, "no warnings");
+
+
+my $baz;
+lives_ok {
+ $baz = Baz->new;
+} '... created the object ok';
+isa_ok($baz, 'Baz');
+
+is($baz->a, 'Foo::a', '... got the right delgated value');
+
+
+
+
+
+@w = ();
+
+{
+ package Blart;
+ use Mouse;
+
+ ::lives_ok {
+ has 'bar' => (
+ is => 'ro',
+ isa => 'Foo',
+ lazy => 1,
+ default => sub { Foo->new() },
+ handles => [qw(a new)],
+ );
+ } '... can create the attribute with delegations';
+
+}
+
+{
+ local $TODO = "warning not yet implemented";
+
+ is(@w, 1, "one warning");
+ like($w[0], qr/not delegating.*new/i, "warned");
+}
+
+
+
+my $blart;
+lives_ok {
+ $blart = Blart->new;
+} '... created the object ok';
+isa_ok($blart, 'Blart');
+
+is($blart->a, 'Foo::a', '... got the right delgated value');
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 36;
+use Test::Exception;
+
+
+
+BEGIN {
+ package MyRole;
+ use Mouse::Role;
+
+ requires 'foo';
+
+ package MyMetaclass;
+ use Mouse qw(extends with);
+ extends 'Mouse::Meta::Class';
+ with 'MyRole';
+
+ sub foo { 'i am foo' }
+}
+
+{
+ package MyClass;
+ use metaclass ('MyMetaclass');
+ use Mouse;
+}
+
+my $mc = MyMetaclass->initialize('MyClass');
+isa_ok($mc, 'MyMetaclass');
+
+ok($mc->meta->does_role('MyRole'), '... the metaclass does the role');
+
+is(MyClass->meta, $mc, '... these metas are the same thing');
+is(MyClass->meta->meta, $mc->meta, '... these meta-metas are the same thing');
+
+my $a = MyClass->new;
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
+lives_ok {
+ MyClass->meta->make_immutable;
+} '... make MyClass 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');
+
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
+lives_ok {
+ MyClass->meta->make_mutable;
+} '... make MyClass mutable 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( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
+lives_ok {
+ MyMetaclass->meta->make_immutable;
+} '... make MyClass 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');
+
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
+lives_ok {
+ MyClass->meta->make_immutable;
+} '... make MyClass 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');
+
+ok( $a->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( $a->meta->foo, 'i am foo', '... foo method returns expected value' );
+ok( MyClass->meta->meta->does_role('MyRole'), 'metaclass does MyRole' );
+is( MyClass->meta->foo, 'i am foo', '... foo method returns expected value' );
+
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use Test::Exception;
+
+{
+ package MyClass;
+ use Mouse;
+
+ sub DEMOLISH { }
+}
+
+my $object = MyClass->new;
+
+# 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');
+
+# The bug happened when DEMOLISHALL called
+# Class::MOP::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');
+
+# 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)';
--- /dev/null
+use strict;
+use warnings;
+use Test::More tests => 10;
+
+{
+ package Ball;
+ use Mouse;
+}
+
+{
+ package Arbitrary::Roll;
+ use Mouse::Role;
+}
+
+my $method_meta = Mouse::Meta::Class->create_anon_class(
+ superclasses => ['Mouse::Meta::Method'],
+ roles => ['Arbitrary::Roll'],
+);
+
+# For comparing identity without actually keeping $original_meta around
+my $original_meta = "$method_meta";
+
+my $method_class = $method_meta->name;
+
+my $method_object = $method_class->wrap(
+ sub {'ok'},
+ associated_metaclass => Ball->meta,
+ package_name => 'Ball',
+ name => 'bounce',
+);
+
+Ball->meta->add_method( bounce => $method_object );
+
+for ( 1, 2 ) {
+ is( Ball->bounce, 'ok', "method still exists on Ball" );
+ is( Ball->meta->get_method('bounce')->meta->name, $method_class,
+ "method's package still exists" );
+
+ is( Ball->meta->get_method('bounce'), $method_object,
+ 'original method object is preserved' );
+
+ is( Ball->meta->get_method('bounce')->meta . '', $original_meta,
+ "method's metaclass still exists" );
+ ok( Ball->meta->get_method('bounce')->meta->does_role('Arbitrary::Roll'),
+ "method still does Arbitrary::Roll" );
+
+ undef $method_meta;
+}
--- /dev/null
+package MyMouseA;
+
+use Mouse;
+
+has 'b' => (is => 'rw', isa => 'MyMouseB');
+
+1;
\ No newline at end of file
--- /dev/null
+package MyMouseB;
+
+use Mouse;
+
+1;
\ No newline at end of file
--- /dev/null
+package MyMouseObject;
+
+use strict;
+use warnings;
+use base 'Mouse::Object';
+
+1;
\ No newline at end of file
projects / gitmo/Mouse.git / commitdiff