From: gfx Date: Sat, 10 Oct 2009 08:55:07 +0000 (+0900) Subject: Import Moose/t/100_bugs X-Git-Tag: 0.37_06~13 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=4c98ebb0cca8d5d49d3a91eaf735f9861d00ccb0 Import Moose/t/100_bugs --- diff --git a/t/020_attributes/005_attribute_does.t b/t/020_attributes/005_attribute_does.t index c61f826..a895bdb 100644 --- a/t/020_attributes/005_attribute_does.t +++ b/t/020_attributes/005_attribute_does.t @@ -19,7 +19,7 @@ use Test::Exception; has 'bar' => (is => 'rw', does => 'Bar::Role'); has 'baz' => ( is => 'rw', - does => role_type('Bar::Role') + does => 'Bar::Role' ); package Bar::Role; diff --git a/t/100_bugs/001_subtype_quote_bug.t b/t/100_bugs/001_subtype_quote_bug.t new file mode 100644 index 0000000..406cafa --- /dev/null +++ b/t/100_bugs/001_subtype_quote_bug.t @@ -0,0 +1,32 @@ +#!/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'); diff --git a/t/100_bugs/002_subtype_conflict_bug.t b/t/100_bugs/002_subtype_conflict_bug.t new file mode 100644 index 0000000..7ae2de3 --- /dev/null +++ b/t/100_bugs/002_subtype_conflict_bug.t @@ -0,0 +1,13 @@ +#!/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 diff --git a/t/100_bugs/003_Moose_Object_error.t b/t/100_bugs/003_Moose_Object_error.t new file mode 100644 index 0000000..6dedb64 --- /dev/null +++ b/t/100_bugs/003_Moose_Object_error.t @@ -0,0 +1,10 @@ +#!/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 diff --git a/t/100_bugs/004_subclass_use_base_bug.t b/t/100_bugs/004_subclass_use_base_bug.t new file mode 100644 index 0000000..33a7a44 --- /dev/null +++ b/t/100_bugs/004_subclass_use_base_bug.t @@ -0,0 +1,30 @@ +#!/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 diff --git a/t/100_bugs/005_inline_reader_bug.t b/t/100_bugs/005_inline_reader_bug.t new file mode 100644 index 0000000..021c3ad --- /dev/null +++ b/t/100_bugs/005_inline_reader_bug.t @@ -0,0 +1,31 @@ +#!/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'; +} + diff --git a/t/100_bugs/007_reader_precedence_bug.t b/t/100_bugs/007_reader_precedence_bug.t new file mode 100644 index 0000000..0f6d608 --- /dev/null +++ b/t/100_bugs/007_reader_precedence_bug.t @@ -0,0 +1,25 @@ +#!/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"); +} + + + + diff --git a/t/100_bugs/009_augment_recursion_bug.t b/t/100_bugs/009_augment_recursion_bug.t new file mode 100644 index 0000000..cd401d9 --- /dev/null +++ b/t/100_bugs/009_augment_recursion_bug.t @@ -0,0 +1,49 @@ +#!/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'); + diff --git a/t/100_bugs/010_immutable_n_default_x2.t b/t/100_bugs/010_immutable_n_default_x2.t new file mode 100644 index 0000000..72f6493 --- /dev/null +++ b/t/100_bugs/010_immutable_n_default_x2.t @@ -0,0 +1,40 @@ +#!/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"); diff --git a/t/100_bugs/011_DEMOLISH_eats_exceptions.t b/t/100_bugs/011_DEMOLISH_eats_exceptions.t new file mode 100644 index 0000000..c83a2ce --- /dev/null +++ b/t/100_bugs/011_DEMOLISH_eats_exceptions.t @@ -0,0 +1,153 @@ +#!/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; + diff --git a/t/100_bugs/012_DEMOLISH_eats_mini.t b/t/100_bugs/012_DEMOLISH_eats_mini.t new file mode 100644 index 0000000..454a0a5 --- /dev/null +++ b/t/100_bugs/012_DEMOLISH_eats_mini.t @@ -0,0 +1,100 @@ +#!/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 +} + diff --git a/t/100_bugs/013_lazybuild_required_undef.t b/t/100_bugs/013_lazybuild_required_undef.t new file mode 100644 index 0000000..2c07718 --- /dev/null +++ b/t/100_bugs/013_lazybuild_required_undef.t @@ -0,0 +1,31 @@ +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; diff --git a/t/100_bugs/014_DEMOLISHALL.t b/t/100_bugs/014_DEMOLISHALL.t new file mode 100644 index 0000000..f3cb306 --- /dev/null +++ b/t/100_bugs/014_DEMOLISHALL.t @@ -0,0 +1,54 @@ +#!/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']); + diff --git a/t/100_bugs/016_inheriting_from_roles.t b/t/100_bugs/016_inheriting_from_roles.t new file mode 100644 index 0000000..269efcb --- /dev/null +++ b/t/100_bugs/016_inheriting_from_roles.t @@ -0,0 +1,23 @@ +#!/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'; +} diff --git a/t/100_bugs/017_type_constraint_messages.t b/t/100_bugs/017_type_constraint_messages.t new file mode 100644 index 0000000..4965eda --- /dev/null +++ b/t/100_bugs/017_type_constraint_messages.t @@ -0,0 +1,73 @@ +#!/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'; + diff --git a/t/100_bugs/019_moose_octal_defaults.t b/t/100_bugs/019_moose_octal_defaults.t new file mode 100644 index 0000000..1766946 --- /dev/null +++ b/t/100_bugs/019_moose_octal_defaults.t @@ -0,0 +1,117 @@ +#!/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' ); +} diff --git a/t/100_bugs/020_super_recursion.t b/t/100_bugs/020_super_recursion.t new file mode 100644 index 0000000..ff691f9 --- /dev/null +++ b/t/100_bugs/020_super_recursion.t @@ -0,0 +1,67 @@ +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' ); diff --git a/t/100_bugs/021_DEMOLISHALL_shortcutted.t b/t/100_bugs/021_DEMOLISHALL_shortcutted.t new file mode 100644 index 0000000..ba1833e --- /dev/null +++ b/t/100_bugs/021_DEMOLISHALL_shortcutted.t @@ -0,0 +1,32 @@ +## 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; diff --git a/t/100_bugs/022_role_caller.t b/t/100_bugs/022_role_caller.t new file mode 100644 index 0000000..6df661d --- /dev/null +++ b/t/100_bugs/022_role_caller.t @@ -0,0 +1,25 @@ +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" ); diff --git a/t/100_bugs/025_universal_methods_wrappable.t b/t/100_bugs/025_universal_methods_wrappable.t new file mode 100644 index 0000000..c995172 --- /dev/null +++ b/t/100_bugs/025_universal_methods_wrappable.t @@ -0,0 +1,29 @@ +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'; +} diff --git a/t/100_bugs/026_create_anon_recursion.t b/t/100_bugs/026_create_anon_recursion.t new file mode 100644 index 0000000..c1f9159 --- /dev/null +++ b/t/100_bugs/026_create_anon_recursion.t @@ -0,0 +1,23 @@ +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'; +} diff --git a/t/100_bugs/027_constructor_object_overload.t b/t/100_bugs/027_constructor_object_overload.t new file mode 100644 index 0000000..0dfba1c --- /dev/null +++ b/t/100_bugs/027_constructor_object_overload.t @@ -0,0 +1,19 @@ +#!/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'); + diff --git a/t/100_bugs/failing/006_handles_foreign_class_bug.t b/t/100_bugs/failing/006_handles_foreign_class_bug.t new file mode 100644 index 0000000..c48d9d5 --- /dev/null +++ b/t/100_bugs/failing/006_handles_foreign_class_bug.t @@ -0,0 +1,111 @@ +#!/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'); + + diff --git a/t/100_bugs/failing/018_immutable_metaclass_does_role.t b/t/100_bugs/failing/018_immutable_metaclass_does_role.t new file mode 100644 index 0000000..4f4b03f --- /dev/null +++ b/t/100_bugs/failing/018_immutable_metaclass_does_role.t @@ -0,0 +1,92 @@ +#!/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' ); + diff --git a/t/100_bugs/failing/023_DEMOLISH_fails_without_metaclass.t b/t/100_bugs/failing/023_DEMOLISH_fails_without_metaclass.t new file mode 100644 index 0000000..a038456 --- /dev/null +++ b/t/100_bugs/failing/023_DEMOLISH_fails_without_metaclass.t @@ -0,0 +1,34 @@ +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)'; diff --git a/t/100_bugs/failing/024_anon_method_metaclass.t b/t/100_bugs/failing/024_anon_method_metaclass.t new file mode 100644 index 0000000..e8f639b --- /dev/null +++ b/t/100_bugs/failing/024_anon_method_metaclass.t @@ -0,0 +1,48 @@ +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; +} diff --git a/t/lib/MyMouseA.pm b/t/lib/MyMouseA.pm new file mode 100644 index 0000000..10ddc13 --- /dev/null +++ b/t/lib/MyMouseA.pm @@ -0,0 +1,7 @@ +package MyMouseA; + +use Mouse; + +has 'b' => (is => 'rw', isa => 'MyMouseB'); + +1; \ No newline at end of file diff --git a/t/lib/MyMouseB.pm b/t/lib/MyMouseB.pm new file mode 100644 index 0000000..542ae00 --- /dev/null +++ b/t/lib/MyMouseB.pm @@ -0,0 +1,5 @@ +package MyMouseB; + +use Mouse; + +1; \ No newline at end of file diff --git a/t/lib/MyMouseObject.pm b/t/lib/MyMouseObject.pm new file mode 100644 index 0000000..d60a6f4 --- /dev/null +++ b/t/lib/MyMouseObject.pm @@ -0,0 +1,7 @@ +package MyMouseObject; + +use strict; +use warnings; +use base 'Mouse::Object'; + +1; \ No newline at end of file