From: gfx Date: Sun, 4 Oct 2009 07:27:12 +0000 (+0900) Subject: Import Moose/t/010_basics/*.t X-Git-Tag: 0.37_02~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=60ad2cb7bf657ab608ab73b9fc7895008d220b7b;p=gitmo%2FMouse.git Import Moose/t/010_basics/*.t --- diff --git a/t/010_basics/001_basic_class_setup.t b/t/010_basics/001_basic_class_setup.t new file mode 100755 index 0000000..348d41a --- /dev/null +++ b/t/010_basics/001_basic_class_setup.t @@ -0,0 +1,51 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 29; +use Test::Exception; + + + +{ + package Foo; + use Mouse; + use Mouse::Util::TypeConstraints; +} + +can_ok('Foo', 'meta'); +isa_ok(Foo->meta, 'Mouse::Meta::Class'); + +ok(Foo->meta->has_method('meta'), '... we got the &meta method'); +ok(Foo->isa('Mouse::Object'), '... Foo is automagically a Mouse::Object'); + +dies_ok { + Foo->meta->has_method() +} '... has_method requires an arg'; + +can_ok('Foo', 'does'); + +foreach my $function (qw( + extends + has + before after around + blessed confess + type subtype as where + coerce from via + find_type_constraint + )) { + ok(!Foo->meta->has_method($function), '... the meta does not treat "' . $function . '" as a method'); +} + +foreach my $import (qw( + blessed + try + catch + in_global_destruction +)) { + ok(!Mouse::Object->can($import), "no namespace pollution in Mouse::Object ($import)" ); + + local $TODO = $import eq 'blessed' ? "no automatic namespace cleaning yet" : undef; + ok(!Foo->can($import), "no namespace pollution in Mouse::Object ($import)" ); +} diff --git a/t/010_basics/002_require_superclasses.t b/t/010_basics/002_require_superclasses.t new file mode 100755 index 0000000..da4776a --- /dev/null +++ b/t/010_basics/002_require_superclasses.t @@ -0,0 +1,47 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use lib 't/lib', 'lib'; + +use Test::More tests => 4; +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'; +} + diff --git a/t/010_basics/003_super_and_override.t b/t/010_basics/003_super_and_override.t new file mode 100755 index 0000000..600d5db --- /dev/null +++ b/t/010_basics/003_super_and_override.t @@ -0,0 +1,81 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 16; +use Test::Exception; + + + +{ + package Foo; + use Mouse; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + package Bar; + use Mouse; + + extends 'Foo'; + + override bar => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use Mouse; + + extends 'Bar'; + + override bar => sub { 'Baz::bar -> ' . super() }; + override baz => sub { 'Baz::baz -> ' . super() }; + + no Mouse; # ensure super() still works after unimport +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +is($baz->foo(), 'Foo::foo', '... got the right value from &foo'); +is($baz->bar(), 'Baz::bar -> Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($baz->baz(), 'Baz::baz -> Foo::baz', '... got the right value from &baz'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo(), 'Foo::foo', '... got the right value from &foo'); +is($bar->bar(), 'Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($bar->baz(), 'Foo::baz', '... got the right value from &baz'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is($foo->foo(), 'Foo::foo', '... got the right value from &foo'); +is($foo->bar(), 'Foo::bar', '... got the right value from &bar'); +is($foo->baz(), 'Foo::baz', '... got the right value from &baz'); + +# some error cases + +{ + package Bling; + use Mouse; + + sub bling { 'Bling::bling' } + + package Bling::Bling; + use Mouse; + + extends 'Bling'; + + sub bling { 'Bling::bling' } + + ::dies_ok { + override 'bling' => sub {}; + } '... cannot override a method which has a local equivalent'; + +} + diff --git a/t/010_basics/004_inner_and_augment.t b/t/010_basics/004_inner_and_augment.t new file mode 100755 index 0000000..14c4de1 --- /dev/null +++ b/t/010_basics/004_inner_and_augment.t @@ -0,0 +1,86 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 16; +use Test::Exception; + + + +{ + package Foo; + use Mouse; + + sub foo { 'Foo::foo(' . (inner() || '') . ')' } + sub bar { 'Foo::bar(' . (inner() || '') . ')' } + sub baz { 'Foo::baz(' . (inner() || '') . ')' } + + package Bar; + use Mouse; + + extends 'Foo'; + + augment foo => sub { 'Bar::foo(' . (inner() || '') . ')' }; + augment bar => sub { 'Bar::bar' }; + + no Mouse; # ensure inner() still works after unimport + + package Baz; + use Mouse; + + extends 'Bar'; + + augment foo => sub { 'Baz::foo' }; + augment baz => sub { 'Baz::baz' }; + + # this will actually never run, + # because Bar::bar does not call inner() + augment bar => sub { 'Baz::bar' }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +is($baz->foo(), 'Foo::foo(Bar::foo(Baz::foo))', '... got the right value from &foo'); +is($baz->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar'); +is($baz->baz(), 'Foo::baz(Baz::baz)', '... got the right value from &baz'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo(), 'Foo::foo(Bar::foo())', '... got the right value from &foo'); +is($bar->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar'); +is($bar->baz(), 'Foo::baz()', '... got the right value from &baz'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is($foo->foo(), 'Foo::foo()', '... got the right value from &foo'); +is($foo->bar(), 'Foo::bar()', '... got the right value from &bar'); +is($foo->baz(), 'Foo::baz()', '... got the right value from &baz'); + +# some error cases + +{ + package Bling; + use Mouse; + + sub bling { 'Bling::bling' } + + package Bling::Bling; + use Mouse; + + extends 'Bling'; + + sub bling { 'Bling::bling' } + + ::dies_ok { + augment 'bling' => sub {}; + } '... cannot augment a method which has a local equivalent'; + +} + diff --git a/t/010_basics/005_override_augment_inner_super.t b/t/010_basics/005_override_augment_inner_super.t new file mode 100755 index 0000000..c7ae92a --- /dev/null +++ b/t/010_basics/005_override_augment_inner_super.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 5; + + + +{ + package Foo; + use Mouse; + + sub foo { 'Foo::foo(' . (inner() || '') . ')' }; + sub bar { 'Foo::bar(' . (inner() || '') . ')' } + + package Bar; + use Mouse; + + extends 'Foo'; + + augment 'foo' => sub { 'Bar::foo' }; + override 'bar' => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use Mouse; + + extends 'Bar'; + + override 'foo' => sub { 'Baz::foo -> ' . super() }; + augment 'bar' => sub { 'Baz::bar' }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +=pod + +Let em clarify what is happening here. Baz::foo is calling +super(), which calls Bar::foo, which is an augmented sub +that calls Foo::foo, then calls inner() which actually +then calls Bar::foo. Confusing I know,.. but this is +*exactly* what is it supposed to do :) + +=cut + +is($baz->foo, + 'Baz::foo -> Foo::foo(Bar::foo)', + '... got the right value from mixed augment/override foo'); + +=pod + +Allow me to clarify this one now ... + +Since Baz::bar is an augment routine, it needs to find the +correct inner() to be called by. In this case it is Foo::bar. +However, Bar::bar is in-between us, so it should actually be +called first. Bar::bar is an overriden sub, and calls super() +which in turn then calls our Foo::bar, which calls inner(), +which calls Baz::bar. + +Confusing I know, but it is correct :) + +=cut + +{ + local $TODO = 'mixed augment/override is not supported'; + is($baz->bar, + 'Bar::bar -> Foo::bar(Baz::bar)', + '... got the right value from mixed augment/override bar'); +} diff --git a/t/010_basics/006_override_and_foreign_classes.t b/t/010_basics/006_override_and_foreign_classes.t new file mode 100755 index 0000000..043d733 --- /dev/null +++ b/t/010_basics/006_override_and_foreign_classes.t @@ -0,0 +1,73 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 15; + + + +=pod + +This just tests the interaction of override/super +with non-Mouse superclasses. It really should not +cause issues, the only thing it does is to create +a metaclass for Foo so that it can find the right +super method. + +This may end up being a sensitive issue for some +non-Mouse classes, but in 99% of the cases it +should be just fine. + +=cut + +{ + package Foo; + use strict; + use warnings; + + sub new { bless {} => shift() } + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + package Bar; + use Mouse; + + extends 'Foo'; + + override bar => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use Mouse; + + extends 'Bar'; + + override bar => sub { 'Baz::bar -> ' . super() }; + override baz => sub { 'Baz::baz -> ' . super() }; +} + +my $baz = Baz->new(); +isa_ok($baz, 'Baz'); +isa_ok($baz, 'Bar'); +isa_ok($baz, 'Foo'); + +is($baz->foo(), 'Foo::foo', '... got the right value from &foo'); +is($baz->bar(), 'Baz::bar -> Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($baz->baz(), 'Baz::baz -> Foo::baz', '... got the right value from &baz'); + +my $bar = Bar->new(); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo(), 'Foo::foo', '... got the right value from &foo'); +is($bar->bar(), 'Bar::bar -> Foo::bar', '... got the right value from &bar'); +is($bar->baz(), 'Foo::baz', '... got the right value from &baz'); + +my $foo = Foo->new(); +isa_ok($foo, 'Foo'); + +is($foo->foo(), 'Foo::foo', '... got the right value from &foo'); +is($foo->bar(), 'Foo::bar', '... got the right value from &bar'); +is($foo->baz(), 'Foo::baz', '... got the right value from &baz'); \ No newline at end of file diff --git a/t/010_basics/007_always_strict_warnings.t b/t/010_basics/007_always_strict_warnings.t new file mode 100755 index 0000000..6de1617 --- /dev/null +++ b/t/010_basics/007_always_strict_warnings.t @@ -0,0 +1,71 @@ +#!/usr/bin/perl + +use Test::More tests => 10; + +# for classes ... +{ + package Foo; + use Mouse; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... got the right error'); + + { + my $warn; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + + ::ok(!$warn, '... no warning yet'); + + eval 'my $bar = 1 + "hello"'; + + ::ok($warn, '... got a warning'); + ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); + } +} + +# and for roles ... +{ + package Bar; + use Mouse::Role; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... got the right error'); + + { + my $warn; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + + ::ok(!$warn, '... no warning yet'); + + eval 'my $bar = 1 + "hello"'; + + ::ok($warn, '... got a warning'); + ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); + } +} +__END__ +# Mouse::Export does not yet exist + +# and for exporters +{ + package Bar; + use Mouse::Exporter; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name at/, '... got the right error'); + + { + my $warn; + local $SIG{__WARN__} = sub { $warn = $_[0] }; + + ::ok(!$warn, '... no warning yet'); + + eval 'my $bar = 1 + "hello"'; + + ::ok($warn, '... got a warning'); + ::like($warn, qr/Argument \"hello\" isn\'t numeric in addition \(\+\)/, '.. and it is the right warning'); + } +} diff --git a/t/010_basics/008_wrapped_method_cxt_propagation.t b/t/010_basics/008_wrapped_method_cxt_propagation.t new file mode 100755 index 0000000..664b187 --- /dev/null +++ b/t/010_basics/008_wrapped_method_cxt_propagation.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 7; + + + +{ + package TouchyBase; + use Mouse; + + has x => ( is => 'rw', default => 0 ); + + sub inc { $_[0]->x( 1 + $_[0]->x ) } + + sub scalar_or_array { + wantarray ? (qw/a b c/) : "x"; + } + + sub void { + die "this must be void context" if defined wantarray; + } + + package AfterSub; + use Mouse; + + extends "TouchyBase"; + + after qw/scalar_or_array void/ => sub { + my $self = shift; + $self->inc; + } +} + +my $base = TouchyBase->new; +my $after = AfterSub->new; + +foreach my $obj ( $base, $after ) { + my $class = ref $obj; + my @array = $obj->scalar_or_array; + my $scalar = $obj->scalar_or_array; + + is_deeply(\@array, [qw/a b c/], "array context ($class)"); + is($scalar, "x", "scalar context ($class)"); + + { + local $@; + eval { $obj->void }; + ok( !$@, "void context ($class)" ); + } + + if ( $obj->isa("AfterSub") ) { + is( $obj->x, 3, "methods were wrapped" ); + } +} + diff --git a/t/010_basics/009_import_unimport.t b/t/010_basics/009_import_unimport.t new file mode 100755 index 0000000..373eb2b --- /dev/null +++ b/t/010_basics/009_import_unimport.t @@ -0,0 +1,75 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 41; + + +my @moose_exports = qw( + extends with + has + before after around + override + augment + super inner +); + +{ + package Foo; + + eval 'use Mouse'; + die $@ if $@; +} + +can_ok('Foo', $_) for @moose_exports; + +{ + package Foo; + + eval 'no Mouse'; + die $@ if $@; +} + +ok(!Foo->can($_), '... Foo can no longer do ' . $_) for @moose_exports; + +# and check the type constraints as well + +my @moose_type_constraint_exports = qw( + type subtype as where message + coerce from via + enum + find_type_constraint +); + +{ + package Bar; + + eval 'use Mouse::Util::TypeConstraints'; + die $@ if $@; +} + +can_ok('Bar', $_) for @moose_type_constraint_exports; + +{ + package Bar; + + eval 'no Mouse::Util::TypeConstraints'; + die $@ if $@; +} + +{ + local $TODO = 'Mouse::Util::TypeConstraints->unimport is not yet supported'; + ok(!Bar->can($_), '... Bar can no longer do ' . $_) for @moose_type_constraint_exports; +} + +{ + package Baz; + + use Scalar::Util qw( blessed ); + use Mouse; + + no Mouse; +} + +can_ok( 'Baz', 'blessed' ); diff --git a/t/010_basics/011_moose_respects_type_constraints.t b/t/010_basics/011_moose_respects_type_constraints.t new file mode 100755 index 0000000..f5193f0 --- /dev/null +++ b/t/010_basics/011_moose_respects_type_constraints.t @@ -0,0 +1,62 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 7; +use Test::Exception; + +use Mouse::Util::TypeConstraints; + +=pod + +This tests demonstrates that Mouse will not override +a preexisting type constraint of the same name when +making constraints for a Mouse-class. + +It also tests that an attribute which uses a 'Foo' for +it's isa option will get the subtype Foo, and not a +type representing the Foo moose class. + +=cut + +BEGIN { + # create this subtype first (in BEGIN) + subtype Foo + => as 'Value' + => where { $_ eq 'Foo' }; +} + +{ # now seee if Mouse will override it + package Foo; + use Mouse; +} + +my $foo_constraint = find_type_constraint('Foo'); +isa_ok($foo_constraint, 'Mouse::Meta::TypeConstraint'); + +is($foo_constraint->parent->name, 'Value', '... got the Value subtype for Foo'); + +ok($foo_constraint->check('Foo'), '... my constraint passed correctly'); +ok(!$foo_constraint->check('Bar'), '... my constraint failed correctly'); + +{ + package Bar; + use Mouse; + + has 'foo' => (is => 'rw', isa => 'Foo'); +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +lives_ok { + $bar->foo('Foo'); +} '... checked the type constraint correctly'; + +dies_ok { + $bar->foo(Foo->new); +} '... checked the type constraint correctly'; + + + diff --git a/t/010_basics/013_create.t b/t/010_basics/013_create.t new file mode 100755 index 0000000..ba4ac52 --- /dev/null +++ b/t/010_basics/013_create.t @@ -0,0 +1,60 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 7; +use Test::Exception; + +{ + package Class; + use Mouse; + + package Foo; + use Mouse::Role; + sub foo_role_applied { 1 } + + package Conflicts::With::Foo; + use Mouse::Role; + sub foo_role_applied { 0 } + + package Not::A::Role; + sub lol_wut { 42 } +} + +my $new_class; + +lives_ok { + $new_class = Mouse::Meta::Class->create( + 'Class::WithFoo', + superclasses => ['Class'], + roles => ['Foo'], + ); +} 'creating lives'; +ok $new_class; + +my $with_foo = Class::WithFoo->new; + +ok $with_foo->foo_role_applied; +isa_ok $with_foo, 'Class', '$with_foo'; + +throws_ok { + Mouse::Meta::Class->create( + 'Made::Of::Fail', + superclasses => ['Class'], + roles => 'Foo', # "oops" + ); +} qr/You must pass an ARRAY ref of roles/; + +ok !Made::Of::Fail->isa('UNIVERSAL'), "did not create Made::Of::Fail"; + +dies_ok { + Mouse::Meta::Class->create( + 'Continuing::To::Fail', + superclasses => ['Class'], + roles => ['Foo', 'Conflicts::With::Foo'], + ); +} 'conflicting roles == death'; + +# XXX: Continuing::To::Fail gets created anyway + diff --git a/t/010_basics/014_create_anon.t b/t/010_basics/014_create_anon.t new file mode 100755 index 0000000..6e681d0 --- /dev/null +++ b/t/010_basics/014_create_anon.t @@ -0,0 +1,72 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 8; + +use Mouse::Meta::Class; + +{ + package Class; + use Mouse; + + package Foo; + use Mouse::Role; + sub foo_role_applied { 1 } + + package Bar; + use Mouse::Role; + sub bar_role_applied { 1 } +} + +# try without caching first + +{ + my $class_and_foo_1 = Mouse::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + ); + + my $class_and_foo_2 = Mouse::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + ); + + isnt $class_and_foo_1->name, $class_and_foo_2->name, + 'creating the same class twice without caching results in 2 classes'; + + map { ok $_->name->foo_role_applied } ($class_and_foo_1, $class_and_foo_2); +} + +# now try with caching + +{ + my $class_and_foo_1 = Mouse::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + cache => 1, + ); + + my $class_and_foo_2 = Mouse::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + cache => 1, + ); + + is $class_and_foo_1->name, $class_and_foo_2->name, + 'with cache, the same class is the same class'; + + map { ok $_->name->foo_role_applied } ($class_and_foo_1, $class_and_foo_2); + + my $class_and_bar = Mouse::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Bar'], + cache => 1, + ); + + isnt $class_and_foo_1->name, $class_and_bar, + 'class_and_foo and class_and_bar are different'; + + ok $class_and_bar->name->bar_role_applied; +} diff --git a/t/010_basics/015_buildargs.t b/t/010_basics/015_buildargs.t new file mode 100755 index 0000000..4b9b1f3 --- /dev/null +++ b/t/010_basics/015_buildargs.t @@ -0,0 +1,43 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 14; + +{ + package Foo; + use Mouse; + + has bar => ( is => "rw" ); + has baz => ( is => "rw" ); + + sub BUILDARGS { + my ( $self, @args ) = @_; + unshift @args, "bar" if @args % 2 == 1; + return {@args}; + } + + package Bar; + use Mouse; + + extends qw(Foo); +} + +foreach my $class qw(Foo Bar) { + is( $class->new->bar, undef, "no args" ); + is( $class->new( bar => 42 )->bar, 42, "normal args" ); + is( $class->new( 37 )->bar, 37, "single arg" ); + { + my $o = $class->new(bar => 42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right bar'); + } + { + my $o = $class->new(42, baz => 47); + is($o->bar, 42, '... got the right bar'); + is($o->baz, 47, '... got the right bar'); + } +} + + diff --git a/t/010_basics/016_load_into_main.t b/t/010_basics/016_load_into_main.t new file mode 100755 index 0000000..58737b7 --- /dev/null +++ b/t/010_basics/016_load_into_main.t @@ -0,0 +1,19 @@ +#!/usr/bin/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 => 2; +} + +stderr_like( sub { package main; eval 'use Mouse' }, + qr/\QMouse does not export its sugar to the 'main' package/, + 'Mouse warns when loaded from the main package' ); + +stderr_like( sub { package main; eval 'use Mouse::Role' }, + qr/\QMouse::Role does not export its sugar to the 'main' package/, + 'Mouse::Role warns when loaded from the main package' ); diff --git a/t/010_basics/017_error_handling.t b/t/010_basics/017_error_handling.t new file mode 100755 index 0000000..fee2964 --- /dev/null +++ b/t/010_basics/017_error_handling.t @@ -0,0 +1,22 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 3; +use Test::Exception; + +# This tests the error handling in Mouse::Object only + +{ + package Foo; + use Mouse; +} + +throws_ok { Foo->new('bad') } qr/^\QSingle parameters to new() must be a HASH ref/, + 'A single non-hashref arg to a constructor throws an error'; +throws_ok { Foo->new(undef) } qr/^\QSingle parameters to new() must be a HASH ref/, + 'A single non-hashref arg to a constructor throws an error'; + +throws_ok { Foo->does() } qr/^\QYou must supply a role name to does()/, + 'Cannot call does() without a role name'; diff --git a/t/010_basics/019-destruction.t b/t/010_basics/019-destruction.t new file mode 100755 index 0000000..72cd82a --- /dev/null +++ b/t/010_basics/019-destruction.t @@ -0,0 +1,51 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 3; + +our @demolished; +package Foo; +use Mouse; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package Foo::Sub; +use Mouse; +extends 'Foo'; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package Foo::Sub::Sub; +use Mouse; +extends 'Foo::Sub'; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package main; +{ + my $foo = Foo->new; +} +is_deeply(\@demolished, ['Foo'], "Foo demolished properly"); +@demolished = (); +{ + my $foo_sub = Foo::Sub->new; +} +is_deeply(\@demolished, ['Foo::Sub', 'Foo'], "Foo::Sub demolished properly"); +@demolished = (); +{ + my $foo_sub_sub = Foo::Sub::Sub->new; +} +is_deeply(\@demolished, ['Foo::Sub::Sub', 'Foo::Sub', 'Foo'], + "Foo::Sub::Sub demolished properly"); +@demolished = (); diff --git a/t/010_basics/failing/010_method_modifier_with_regexp.t b/t/010_basics/failing/010_method_modifier_with_regexp.t new file mode 100755 index 0000000..786b8c3 --- /dev/null +++ b/t/010_basics/failing/010_method_modifier_with_regexp.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 9; +use Test::Exception; + +{ + + package Dog; + use Mouse; + + sub bark_once { + my $self = shift; + return 'bark'; + } + + sub bark_twice { + return 'barkbark'; + } + + around qr/bark.*/ => sub { + 'Dog::around(' . $_[0]->() . ')'; + }; + +} + +my $dog = Dog->new; +is( $dog->bark_once, 'Dog::around(bark)', 'around modifier is called' ); +is( $dog->bark_twice, 'Dog::around(barkbark)', 'around modifier is called' ); + +{ + + package Cat; + use Mouse; + our $BEFORE_BARK_COUNTER = 0; + our $AFTER_BARK_COUNTER = 0; + + sub bark_once { + my $self = shift; + return 'bark'; + } + + sub bark_twice { + return 'barkbark'; + } + + before qr/bark.*/ => sub { + $BEFORE_BARK_COUNTER++; + }; + + after qr/bark.*/ => sub { + $AFTER_BARK_COUNTER++; + }; + +} + +my $cat = Cat->new; +$cat->bark_once; +is( $Cat::BEFORE_BARK_COUNTER, 1, 'before modifier is called once' ); +is( $Cat::AFTER_BARK_COUNTER, 1, 'after modifier is called once' ); +$cat->bark_twice; +is( $Cat::BEFORE_BARK_COUNTER, 2, 'before modifier is called twice' ); +is( $Cat::AFTER_BARK_COUNTER, 2, 'after modifier is called twice' ); + +{ + package Dog::Role; + use Mouse::Role; + + ::dies_ok { + before qr/bark.*/ => sub {}; + } '... this is not currently supported'; + + ::dies_ok { + around qr/bark.*/ => sub {}; + } '... this is not currently supported'; + + ::dies_ok { + after qr/bark.*/ => sub {}; + } '... this is not currently supported'; + +} + diff --git a/t/010_basics/failing/012_rebless.t b/t/010_basics/failing/012_rebless.t new file mode 100755 index 0000000..e8c6722 --- /dev/null +++ b/t/010_basics/failing/012_rebless.t @@ -0,0 +1,85 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 11; +use Test::Exception; +use Scalar::Util 'blessed'; + +use Mouse::Util::TypeConstraints; + +subtype 'Positive' + => as 'Num' + => where { $_ > 0 }; + +{ + package Parent; + use Mouse; + + has name => ( + is => 'rw', + isa => 'Str', + ); + + has lazy_classname => ( + is => 'ro', + lazy => 1, + default => sub { "Parent" }, + ); + + has type_constrained => ( + is => 'rw', + isa => 'Num', + default => 5.5, + ); + + package Child; + use Mouse; + extends 'Parent'; + + has '+name' => ( + default => 'Junior', + ); + + has '+lazy_classname' => ( + default => sub { "Child" }, + ); + + has '+type_constrained' => ( + isa => 'Int', + default => 100, + ); +} + +my $foo = Parent->new; +my $bar = Parent->new; + +is(blessed($foo), 'Parent', 'Parent->new gives a Parent object'); +is($foo->name, undef, 'No name yet'); +is($foo->lazy_classname, 'Parent', "lazy attribute initialized"); +lives_ok { $foo->type_constrained(10.5) } "Num type constraint for now.."; + +# 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/, +'... 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/, +'... this failed cause of type check';; + +$foo->type_constrained(10); +$bar->type_constrained(5); + +Child->meta->rebless_instance($foo); +Child->meta->rebless_instance($bar); + +is(blessed($foo), 'Child', 'successfully reblessed into Child'); +is($foo->name, 'Junior', "Child->name's default came through"); + +is($foo->lazy_classname, 'Parent', "lazy attribute was already initialized"); +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/, +'... this failed cause of type check'; diff --git a/t/010_basics/failing/018_methods.t b/t/010_basics/failing/018_methods.t new file mode 100755 index 0000000..bb683bc --- /dev/null +++ b/t/010_basics/failing/018_methods.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 6; + + +my $test1 = Mouse::Meta::Class->create_anon_class; +$test1->add_method( 'foo1', sub { } ); + +my $t1 = $test1->new_object; +my $t1_am = $t1->meta->get_method('foo1')->associated_metaclass; + +ok( $t1_am, 'associated_metaclass is defined' ); + +isa_ok( + $t1_am, 'Mouse::Meta::Class', + 'associated_metaclass is correct class' +); + +like( $t1_am->name(), qr/::__ANON__::/, + 'associated_metaclass->name looks like an anonymous class' ); + +{ + package Test2; + + use Mouse; + + sub foo2 { } +} + +my $t2 = Test2->new; +my $t2_am = $t2->meta->get_method('foo2')->associated_metaclass; + +ok( $t2_am, 'associated_metaclass is defined' ); + +isa_ok( + $t2_am, 'Mouse::Meta::Class', + 'associated_metaclass is correct class' +); + +is( $t2_am->name(), 'Test2', + 'associated_metaclass->name is Test2' ); diff --git a/t/010_basics/failing/020-global-destruction-helper.pl b/t/010_basics/failing/020-global-destruction-helper.pl new file mode 100755 index 0000000..a0defbe --- /dev/null +++ b/t/010_basics/failing/020-global-destruction-helper.pl @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +use warnings; + + +{ + package Foo; + use Mouse; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + + print $igd; + } +} + +{ + package Bar; + use Mouse; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + + print $igd; + } + + __PACKAGE__->meta->make_immutable; +} + +our $foo = Foo->new; +our $bar = Bar->new; diff --git a/t/010_basics/failing/020-global-destruction.t b/t/010_basics/failing/020-global-destruction.t new file mode 100755 index 0000000..484a722 --- /dev/null +++ b/t/010_basics/failing/020-global-destruction.t @@ -0,0 +1,50 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 4; + +{ + package Foo; + use Mouse; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + ::ok( + !$igd, + 'in_global_destruction state is passed to DEMOLISH properly (false)' + ); + } +} + +{ + my $foo = Foo->new; +} + +{ + package Bar; + use Mouse; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + ::ok( + !$igd, + 'in_global_destruction state is passed to DEMOLISH properly (false)' + ); + } + + __PACKAGE__->meta->make_immutable; +} + +{ + my $bar = Bar->new; +} + +ok( + $_, + 'in_global_destruction state is passed to DEMOLISH properly (true)' +) for split //, `$^X t/010_basics/020-global-destruction-helper.pl`; + diff --git a/t/010_basics/failing/021-instance-new.t b/t/010_basics/failing/021-instance-new.t new file mode 100755 index 0000000..1c7d84d --- /dev/null +++ b/t/010_basics/failing/021-instance-new.t @@ -0,0 +1,25 @@ +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 => 2; +} + +{ + package Foo; + use Mouse; +} + +{ + my $foo = Foo->new(); + stderr_like { $foo->new() } + qr/\QCalling new() on an instance is deprecated/, + '$object->new() is deprecated'; + + Foo->meta->make_immutable, redo + if Foo->meta->is_mutable; +} diff --git a/t/lib/Bar.pm b/t/lib/Bar.pm new file mode 100755 index 0000000..c9d0ab0 --- /dev/null +++ b/t/lib/Bar.pm @@ -0,0 +1,10 @@ + +package Bar; +use Mouse; +use Mouse::Util::TypeConstraints; + +type Baz => where { 1 }; + +subtype Bling => as Baz => where { 1 }; + +1; \ No newline at end of file diff --git a/t/lib/Foo.pm b/t/lib/Foo.pm new file mode 100755 index 0000000..6cbac0f --- /dev/null +++ b/t/lib/Foo.pm @@ -0,0 +1,7 @@ + +package Foo; +use Mouse; + +has 'bar' => (is => 'rw'); + +1; \ No newline at end of file