diff options
Diffstat (limited to 't/basics')
26 files changed, 1681 insertions, 0 deletions
diff --git a/t/basics/always_strict_warnings.t b/t/basics/always_strict_warnings.t new file mode 100644 index 0000000..ca62682 --- /dev/null +++ b/t/basics/always_strict_warnings.t @@ -0,0 +1,71 @@ +use Test::More; + +# very intentionally not doing use strict; use warnings here... + +# for classes ... +{ + package Foo; + use Moose; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name /, '... 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 Moose::Role; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name /, '... 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 exporters +{ + package Bar; + use Moose::Exporter; + + eval '$foo = 5;'; + ::ok($@, '... got an error because strict is on'); + ::like($@, qr/Global symbol \"\$foo\" requires explicit package name /, '... 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'); + } +} + +done_testing; diff --git a/t/basics/basic_class_setup.t b/t/basics/basic_class_setup.t new file mode 100644 index 0000000..64a5779 --- /dev/null +++ b/t/basics/basic_class_setup.t @@ -0,0 +1,50 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; +} + +can_ok('Foo', 'meta'); +isa_ok(Foo->meta, 'Moose::Meta::Class'); + +ok(Foo->meta->has_method('meta'), '... we got the &meta method'); +ok(Foo->isa('Moose::Object'), '... Foo is automagically a Moose::Object'); + +isnt( exception { + Foo->meta->has_method() +}, undef, '... 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(!Moose::Object->can($import), "no namespace pollution in Moose::Object ($import)" ); + + local $TODO = $import eq 'blessed' ? "no automatic namespace cleaning yet" : undef; + ok(!Foo->can($import), "no namespace pollution in Moose::Object ($import)" ); +} + +done_testing; diff --git a/t/basics/buildargs.t b/t/basics/buildargs.t new file mode 100644 index 0000000..f7b5b5d --- /dev/null +++ b/t/basics/buildargs.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use Moose; + + 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 Moose; + + 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'); + } +} + +done_testing; diff --git a/t/basics/buildargs_warning.t b/t/basics/buildargs_warning.t new file mode 100644 index 0000000..5b1a415 --- /dev/null +++ b/t/basics/buildargs_warning.t @@ -0,0 +1,32 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; +use Test::Moose qw( with_immutable ); + +use Test::Requires 'Test::Output'; + +{ + package Baz; + use Moose; +} + +with_immutable { + is( exception { + stderr_like { Baz->new( x => 42, 'y' ) } + qr{\QThe new() method for Baz expects a hash reference or a key/value list. You passed an odd number of arguments at $0 line \E\d+}, + 'warning when passing an odd number of args to new()'; + + stderr_unlike { Baz->new( x => 42, 'y' ) } + qr{\QOdd number of elements in anonymous hash}, + 'we suppress the standard warning from Perl for an odd number of elements in a hash'; + + stderr_is { Baz->new( { x => 42 } ) } + q{}, + 'we handle a single hashref to new without errors'; + }, undef ); +} +'Baz'; + +done_testing; diff --git a/t/basics/create.t b/t/basics/create.t new file mode 100644 index 0000000..37dcf57 --- /dev/null +++ b/t/basics/create.t @@ -0,0 +1,61 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Class::Load 'is_class_loaded'; + +{ + package Class; + use Moose; + + package Foo; + use Moose::Role; + sub foo_role_applied { 1 } + + package Conflicts::With::Foo; + use Moose::Role; + sub foo_role_applied { 0 } + + package Not::A::Role; + sub lol_wut { 42 } +} + +my $new_class; + +is( exception { + $new_class = Moose::Meta::Class->create( + 'Class::WithFoo', + superclasses => ['Class'], + roles => ['Foo'], + ); +}, undef, 'creating lives' ); +ok $new_class; + +my $with_foo = Class::WithFoo->new; + +ok $with_foo->foo_role_applied; +isa_ok $with_foo, 'Class', '$with_foo'; + +like( exception { + Moose::Meta::Class->create( + 'Made::Of::Fail', + superclasses => ['Class'], + roles => 'Foo', # "oops" + ); +}, qr/You must pass an ARRAY ref of roles/ ); + +ok !is_class_loaded('Made::Of::Fail'), "did not create Made::Of::Fail"; + +isnt( exception { + Moose::Meta::Class->create( + 'Continuing::To::Fail', + superclasses => ['Class'], + roles => ['Foo', 'Conflicts::With::Foo'], + ); +}, undef, 'conflicting roles == death' ); + +# XXX: Continuing::To::Fail gets created anyway + +done_testing; diff --git a/t/basics/create_anon.t b/t/basics/create_anon.t new file mode 100644 index 0000000..b36b2a8 --- /dev/null +++ b/t/basics/create_anon.t @@ -0,0 +1,125 @@ +use strict; +use warnings; + +use Test::More; + +use Moose::Meta::Class; + +{ + package Class; + use Moose; + + package Foo; + use Moose::Role; + sub foo_role_applied { 1 } + + package Bar; + use Moose::Role; + sub bar_role_applied { 1 } +} + +# try without caching first + +{ + my $class_and_foo_1 = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + ); + + my $class_and_foo_2 = Moose::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 = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + roles => ['Foo'], + cache => 1, + ); + + my $class_and_foo_2 = Moose::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 = Moose::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; +} + +# This tests that a cached metaclass can be reinitialized and still retain its +# metaclass object. +{ + my $name = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + cache => 1, + )->name; + + $name->meta->reinitialize( $name ); + + can_ok( $name, 'meta' ); +} + +{ + my $name; + { + my $meta = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + cache => 1, + ); + $name = $meta->name; + ok(!Class::MOP::metaclass_is_weak($name), "cache implies weaken => 0"); + } + ok(Class::MOP::class_of($name), "cache implies weaken => 0"); + Class::MOP::remove_metaclass_by_name($name); +} + +{ + my $name; + { + my $meta = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + cache => 1, + weaken => 1, + ); + my $name = $meta->name; + ok(Class::MOP::metaclass_is_weak($name), "but we can override this"); + } + ok(!Class::MOP::class_of($name), "but we can override this"); +} + +{ + my $meta = Moose::Meta::Class->create_anon_class( + superclasses => ['Class'], + cache => 1, + ); + ok(!Class::MOP::metaclass_is_weak($meta->name), + "creates a nonweak metaclass"); + Scalar::Util::weaken($meta); + Class::MOP::remove_metaclass_by_name($meta->name); + ok(!$meta, "removing a cached anon class means it's actually gone"); +} + +done_testing; diff --git a/t/basics/deprecations.t b/t/basics/deprecations.t new file mode 100644 index 0000000..1eb7a9c --- /dev/null +++ b/t/basics/deprecations.t @@ -0,0 +1,23 @@ +use strict; +use warnings; + +use Test::More; + +use Moose (); +use Moose::Util::TypeConstraints; + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + enum Foo => qw(Bar Baz Quux); + like($warnings, qr/Passing a list of values to enum is deprecated\. Enum values should be wrapped in an arrayref\./); +} + +{ + my $warnings; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + duck_type Bar => qw(baz quux); + like($warnings, qr/Passing a list of values to duck_type is deprecated\. The method names should be wrapped in an arrayref\./); +} + +done_testing; diff --git a/t/basics/destruction.t b/t/basics/destruction.t new file mode 100644 index 0000000..55cb78e --- /dev/null +++ b/t/basics/destruction.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test::More; + +our @demolished; +package Foo; +use Moose; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package Foo::Sub; +use Moose; +extends 'Foo'; + +sub DEMOLISH { + my $self = shift; + push @::demolished, __PACKAGE__; +} + +package Foo::Sub::Sub; +use Moose; +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 = (); + +done_testing; diff --git a/t/basics/error_handling.t b/t/basics/error_handling.t new file mode 100644 index 0000000..250aa30 --- /dev/null +++ b/t/basics/error_handling.t @@ -0,0 +1,19 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +# This tests the error handling in Moose::Object only + +{ + package Foo; + use Moose; +} + +like( exception { Foo->new('bad') }, qr/^\QSingle parameters to new() must be a HASH ref/, 'A single non-hashref arg to a constructor throws an error' ); +like( exception { Foo->new(undef) }, qr/^\QSingle parameters to new() must be a HASH ref/, 'A single non-hashref arg to a constructor throws an error' ); + +like( exception { Foo->does() }, qr/^\QYou must supply a role name to does()/, 'Cannot call does() without a role name' ); + +done_testing; diff --git a/t/basics/global-destruction-helper.pl b/t/basics/global-destruction-helper.pl new file mode 100644 index 0000000..a5b75c6 --- /dev/null +++ b/t/basics/global-destruction-helper.pl @@ -0,0 +1,34 @@ +#!/usr/bin/perl + +use strict; +use warnings; + + +{ + package Foo; + use Moose; + + sub DEMOLISH { + my $self = shift; + my ($igd) = @_; + + print $igd; + } +} + +{ + package Bar; + use Moose; + + 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/basics/global_destruction.t b/t/basics/global_destruction.t new file mode 100644 index 0000000..53a4db1 --- /dev/null +++ b/t/basics/global_destruction.t @@ -0,0 +1,49 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Foo; + use Moose; + + 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 Moose; + + 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/basics/global-destruction-helper.pl`; + +done_testing; diff --git a/t/basics/import_unimport.t b/t/basics/import_unimport.t new file mode 100644 index 0000000..b44fea7 --- /dev/null +++ b/t/basics/import_unimport.t @@ -0,0 +1,98 @@ +use strict; +use warnings; + +use Test::More; + + +my @moose_exports = qw( + extends with + has + before after around + override + augment + super inner + blessed confess +); + +{ + package Foo; + + eval 'use Moose'; + die $@ if $@; +} + +can_ok('Foo', $_) for @moose_exports; + +{ + package Foo; + + eval 'no Moose'; + 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 Moose::Util::TypeConstraints'; + die $@ if $@; +} + +can_ok('Bar', $_) for @moose_type_constraint_exports; + +{ + package Bar; + + eval 'no Moose::Util::TypeConstraints'; + die $@ if $@; +} + +ok(!Bar->can($_), '... Bar can no longer do ' . $_) for @moose_type_constraint_exports; + + +{ + package Baz; + + use Moose; + use Scalar::Util qw( blessed ); + + no Moose; +} + +can_ok( 'Baz', 'blessed' ); + +{ + package Moo; + + use Scalar::Util qw( blessed ); + use Moose; + + no Moose; +} + +can_ok( 'Moo', 'blessed' ); + +my $blessed; +{ + package Quux; + + use Scalar::Util qw( blessed ); + use Moose blessed => { -as => \$blessed }; + + no Moose; +} + +can_ok( 'Quux', 'blessed' ); +is( $blessed, \&Scalar::Util::blessed ); + +done_testing; diff --git a/t/basics/inner_and_augment.t b/t/basics/inner_and_augment.t new file mode 100644 index 0000000..c343c38 --- /dev/null +++ b/t/basics/inner_and_augment.t @@ -0,0 +1,117 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + sub foo { 'Foo::foo(' . (inner() || '') . ')' } + sub bar { 'Foo::bar(' . (inner() || '') . ')' } + sub baz { 'Foo::baz(' . (inner() || '') . ')' } + + package Bar; + use Moose; + + extends 'Foo'; + + augment foo => sub { 'Bar::foo(' . (inner() || '') . ')' }; + augment bar => sub { 'Bar::bar' }; + + no Moose; # ensure inner() still works after unimport + + package Baz; + use Moose; + + 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'); + +# test saved state when crossing objects + +{ + package X; + use Moose; + has name => (is => 'rw'); + sub run { + "$_[0]->{name}.X", inner() + } + + package Y; + use Moose; + extends 'X'; + augment 'run' => sub { + "$_[0]->{name}.Y", ($_[1] ? $_[1]->() : ()), inner(); + }; + + package Z; + use Moose; + extends 'Y'; + augment 'run' => sub { + "$_[0]->{name}.Z" + } +} + +is('a.X a.Y b.X b.Y b.Z a.Z', + do { + my $a = Z->new(name => 'a'); + my $b = Z->new(name => 'b'); + join(' ', $a->run(sub { $b->run })) + }, + 'State is saved when cross-calling augmented methods on different objects'); + +# some error cases + +{ + package Bling; + use Moose; + + sub bling { 'Bling::bling' } + + package Bling::Bling; + use Moose; + + extends 'Bling'; + + sub bling { 'Bling::bling' } + + ::isnt( ::exception { + augment 'bling' => sub {}; + }, undef, '... cannot augment a method which has a local equivalent' ); + +} + +done_testing; diff --git a/t/basics/load_into_main.t b/t/basics/load_into_main.t new file mode 100644 index 0000000..ddfb834 --- /dev/null +++ b/t/basics/load_into_main.t @@ -0,0 +1,16 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +is( exception { + eval 'use Moose'; +}, undef, "export to main" ); + +isa_ok( main->meta, "Moose::Meta::Class" ); + +isa_ok( main->new, "main"); +isa_ok( main->new, "Moose::Object" ); + +done_testing; diff --git a/t/basics/method_modifier_with_regexp.t b/t/basics/method_modifier_with_regexp.t new file mode 100644 index 0000000..8f9319b --- /dev/null +++ b/t/basics/method_modifier_with_regexp.t @@ -0,0 +1,84 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + + package Dog; + use Moose; + + 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 Moose; + 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 Moose::Role; + + ::isnt( ::exception { + before qr/bark.*/ => sub {}; + }, undef, '... this is not currently supported' ); + + ::isnt( ::exception { + around qr/bark.*/ => sub {}; + }, undef, '... this is not currently supported' ); + + ::isnt( ::exception { + after qr/bark.*/ => sub {}; + }, undef, '... this is not currently supported' ); + +} + +done_testing; diff --git a/t/basics/methods.t b/t/basics/methods.t new file mode 100644 index 0000000..da34a07 --- /dev/null +++ b/t/basics/methods.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test::More; + + +my $test1 = Moose::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, 'Moose::Meta::Class', + 'associated_metaclass is correct class' +); + +like( $t1_am->name(), qr/::__ANON__::/, + 'associated_metaclass->name looks like an anonymous class' ); + +{ + package Test2; + + use Moose; + + 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, 'Moose::Meta::Class', + 'associated_metaclass is correct class' +); + +is( $t2_am->name(), 'Test2', + 'associated_metaclass->name is Test2' ); + +done_testing; diff --git a/t/basics/moose_object_does.t b/t/basics/moose_object_does.t new file mode 100644 index 0000000..87338af --- /dev/null +++ b/t/basics/moose_object_does.t @@ -0,0 +1,158 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + +{ + package Role::A; + use Moose::Role +} + +{ + package Role::B; + use Moose::Role +} + +{ + package Foo; + use Moose; +} + +{ + package Bar; + use Moose; + + with 'Role::A'; +} + +{ + package Baz; + use Moose; + + with qw( Role::A Role::B ); +} + +{ + package Foo::Child; + use Moose; + + extends 'Foo'; +} + +{ + package Bar::Child; + use Moose; + + extends 'Bar'; +} + +{ + package Baz::Child; + use Moose; + + extends 'Baz'; +} + +with_immutable { + + for my $thing ( 'Foo', Foo->new, 'Foo::Child', Foo::Child->new ) { + my $name = ref $thing ? (ref $thing) . ' object' : "$thing class"; + $name .= ' (immutable)' if $thing->meta->is_immutable; + + ok( + !$thing->does('Role::A'), + "$name does not do Role::A" + ); + ok( + !$thing->does('Role::B'), + "$name does not do Role::B" + ); + + ok( + !$thing->does( Role::A->meta ), + "$name does not do Role::A (passed as object)" + ); + ok( + !$thing->does( Role::B->meta ), + "$name does not do Role::B (passed as object)" + ); + + ok( + !$thing->DOES('Role::A'), + "$name does not do Role::A (using DOES)" + ); + ok( + !$thing->DOES('Role::B'), + "$name does not do Role::B (using DOES)" + ); + } + + for my $thing ( 'Bar', Bar->new, 'Bar::Child', Bar::Child->new ) { + my $name = ref $thing ? (ref $thing) . ' object' : "$thing class"; + $name .= ' (immutable)' if $thing->meta->is_immutable; + + ok( + $thing->does('Role::A'), + "$name does Role::A" + ); + ok( + !$thing->does('Role::B'), + "$name does not do Role::B" + ); + + ok( + $thing->does( Role::A->meta ), + "$name does Role::A (passed as object)" + ); + ok( + !$thing->does( Role::B->meta ), + "$name does not do Role::B (passed as object)" + ); + + ok( + $thing->DOES('Role::A'), + "$name does Role::A (using DOES)" + ); + ok( + !$thing->DOES('Role::B'), + "$name does not do Role::B (using DOES)" + ); + } + + for my $thing ( 'Baz', Baz->new, 'Baz::Child', Baz::Child->new ) { + my $name = ref $thing ? (ref $thing) . ' object' : "$thing class"; + $name .= ' (immutable)' if $thing->meta->is_immutable; + + ok( + $thing->does('Role::A'), + "$name does Role::A" + ); + ok( + $thing->does('Role::B'), + "$name does Role::B" + ); + + ok( + $thing->does( Role::A->meta ), + "$name does Role::A (passed as object)" + ); + ok( + $thing->does( Role::B->meta ), + "$name does Role::B (passed as object)" + ); + + ok( + $thing->DOES('Role::A'), + "$name does Role::A (using DOES)" + ); + ok( + $thing->DOES('Role::B'), + "$name does Role::B (using DOES)" + ); + } + +} +qw( Foo Bar Baz Foo::Child Bar::Child Baz::Child ); + +done_testing; diff --git a/t/basics/moose_respects_type_constraints.t b/t/basics/moose_respects_type_constraints.t new file mode 100644 index 0000000..5dba161 --- /dev/null +++ b/t/basics/moose_respects_type_constraints.t @@ -0,0 +1,59 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +=pod + +This tests demonstrates that Moose will not override +a preexisting type constraint of the same name when +making constraints for a Moose-class. + +It also tests that an attribute which uses a 'Foo' for +its 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 Moose will override it + package Foo; + use Moose; +} + +my $foo_constraint = find_type_constraint('Foo'); +isa_ok($foo_constraint, 'Moose::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 Moose; + + has 'foo' => (is => 'rw', isa => 'Foo'); +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +is( exception { + $bar->foo('Foo'); +}, undef, '... checked the type constraint correctly' ); + +isnt( exception { + $bar->foo(Foo->new); +}, undef, '... checked the type constraint correctly' ); + +done_testing; diff --git a/t/basics/override_and_foreign_classes.t b/t/basics/override_and_foreign_classes.t new file mode 100644 index 0000000..f671fe9 --- /dev/null +++ b/t/basics/override_and_foreign_classes.t @@ -0,0 +1,72 @@ +use strict; +use warnings; + +use Test::More; + + +=pod + +This just tests the interaction of override/super +with non-Moose 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-Moose 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 Moose; + + extends 'Foo'; + + override bar => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use Moose; + + 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'); + +done_testing; diff --git a/t/basics/override_augment_inner_super.t b/t/basics/override_augment_inner_super.t new file mode 100644 index 0000000..7ec35ea --- /dev/null +++ b/t/basics/override_augment_inner_super.t @@ -0,0 +1,69 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package Foo; + use Moose; + + sub foo { 'Foo::foo(' . (inner() || '') . ')' }; + sub bar { 'Foo::bar(' . (inner() || '') . ')' } + + package Bar; + use Moose; + + extends 'Foo'; + + augment 'foo' => sub { 'Bar::foo' }; + override 'bar' => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use Moose; + + 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 + +is($baz->bar, + 'Bar::bar -> Foo::bar(Baz::bar)', + '... got the right value from mixed augment/override bar'); + +done_testing; diff --git a/t/basics/rebless.t b/t/basics/rebless.t new file mode 100644 index 0000000..db08d6b --- /dev/null +++ b/t/basics/rebless.t @@ -0,0 +1,136 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Moose qw(with_immutable); +use Scalar::Util 'blessed'; + +use Moose::Util::TypeConstraints; + +subtype 'Positive' + => as 'Num' + => where { $_ > 0 }; + +{ + package Parent; + use Moose; + + 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 Moose; + extends 'Parent'; + + has '+name' => ( + default => 'Junior', + ); + + has '+lazy_classname' => ( + default => sub {"Child"}, + ); + + has '+type_constrained' => ( + isa => 'Int', + default => 100, + ); + + our %trigger_calls; + our %initializer_calls; + + has new_attr => ( + is => 'rw', + isa => 'Str', + trigger => sub { + my ( $self, $val, $attr ) = @_; + $trigger_calls{new_attr}++; + }, + initializer => sub { + my ( $self, $value, $set, $attr ) = @_; + $initializer_calls{new_attr}++; + $set->($value); + }, + ); +} + +my @classes = qw(Parent Child); + +with_immutable { + 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" ); + is( + exception { $foo->type_constrained(10.5) }, undef, + "Num type constraint for now.." + ); + + # try to rebless, except it will fail due to Child's stricter type constraint + like( + exception { Child->meta->rebless_instance($foo) }, + qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, + '... this failed because of type check' + ); + like( + exception { Child->meta->rebless_instance($bar) }, + qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 5\.5/, + '... this failed because of type check' + ); + + $foo->type_constrained(10); + $bar->type_constrained(5); + + Child->meta->rebless_instance($foo); + Child->meta->rebless_instance( $bar, new_attr => 'blah' ); + + 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" + ); + + like( + exception { $foo->type_constrained(10.5) }, + qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, + '... this failed because of type check' + ); + + is_deeply( + \%Child::trigger_calls, { new_attr => 1 }, + 'Trigger fired on rebless_instance' + ); + is_deeply( + \%Child::initializer_calls, { new_attr => 1 }, + 'Initializer fired on rebless_instance' + ); + + undef %Child::trigger_calls; + undef %Child::initializer_calls; + +} +@classes; + +done_testing; diff --git a/t/basics/require_superclasses.t b/t/basics/require_superclasses.t new file mode 100644 index 0000000..f2b1683 --- /dev/null +++ b/t/basics/require_superclasses.t @@ -0,0 +1,64 @@ +use strict; +use warnings; + +use lib 't/lib'; + +use Test::More; +use Test::Fatal; + + +{ + + package Bar; + use Moose; + + ::is( ::exception { extends 'Foo' }, undef, 'loaded Foo superclass correctly' ); +} + +{ + + package Baz; + use Moose; + + ::is( ::exception { extends 'Bar' }, undef, 'loaded (inline) Bar superclass correctly' ); +} + +{ + + package Foo::Bar; + use Moose; + + ::is( ::exception { extends 'Foo', 'Bar' }, undef, 'loaded Foo and (inline) Bar superclass correctly' ); +} + +{ + + package Bling; + use Moose; + + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= $_[0] }; + ::is( ::exception { extends 'No::Class' }, undef, "extending an empty package is a valid thing to do" ); + ::like( $warnings, qr/^Can't locate package No::Class for \@Bling::ISA/, "but it does give a warning" ); +} + +{ + package Affe; + our $VERSION = 23; +} + +{ + package Tiger; + use Moose; + + ::is( ::exception { extends 'Foo', Affe => { -version => 13 } }, undef, 'extends with version requirement' ); +} + +{ + package Birne; + use Moose; + + ::like( ::exception { extends 'Foo', Affe => { -version => 42 } }, qr/Affe version 42 required--this is only version 23/, 'extends with unsatisfied version requirement' ); +} + +done_testing; diff --git a/t/basics/super_and_override.t b/t/basics/super_and_override.t new file mode 100644 index 0000000..edebc71 --- /dev/null +++ b/t/basics/super_and_override.t @@ -0,0 +1,79 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + sub foo { 'Foo::foo' } + sub bar { 'Foo::bar' } + sub baz { 'Foo::baz' } + + package Bar; + use Moose; + + extends 'Foo'; + + override bar => sub { 'Bar::bar -> ' . super() }; + + package Baz; + use Moose; + + extends 'Bar'; + + override bar => sub { 'Baz::bar -> ' . super() }; + override baz => sub { 'Baz::baz -> ' . super() }; + + no Moose; # 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 Moose; + + sub bling { 'Bling::bling' } + + package Bling::Bling; + use Moose; + + extends 'Bling'; + + sub bling { 'Bling::bling' } + + ::isnt( ::exception { + override 'bling' => sub {}; + }, undef, '... cannot override a method which has a local equivalent' ); + +} + +done_testing; diff --git a/t/basics/super_warns_on_args.t b/t/basics/super_warns_on_args.t new file mode 100644 index 0000000..3600d9f --- /dev/null +++ b/t/basics/super_warns_on_args.t @@ -0,0 +1,44 @@ +use strict; +use warnings; + +use Test::Requires 'Test::Output'; +use Test::More; + +{ + package Parent; + use Moose; + + sub foo { 42 } + sub bar { 42 } + + package Child; + use Moose; + + extends 'Parent'; + + override foo => sub { + super( 1, 2, 3 ); + }; + + override bar => sub { + super(); + }; +} + +{ + my $file = __FILE__; + + stderr_like( + sub { Child->new->foo }, + qr/\QArguments passed to super() are ignored at $file/, + 'got a warning when passing args to super() call' + ); + + stderr_is( + sub { Child->new->bar }, + q{}, + 'no warning on super() call without arguments' + ); +} + +done_testing(); diff --git a/t/basics/universal_methods_wrappable.t b/t/basics/universal_methods_wrappable.t new file mode 100644 index 0000000..350688c --- /dev/null +++ b/t/basics/universal_methods_wrappable.t @@ -0,0 +1,29 @@ +use strict; +use warnings; + +use Test::Fatal; +use Test::More; + +{ + + package FakeBar; + use Moose::Role; + + around isa => sub { + my ( $orig, $self, $v ) = @_; + return 1 if $v eq 'Bar'; + return $orig->( $self, $v ); + }; + + package Foo; + use Moose; + + use Test::More; + + ::is( ::exception { with 'FakeBar' }, undef, 'applied role' ); + + my $foo = Foo->new; + ::isa_ok( $foo, 'Bar' ); +} + +done_testing; diff --git a/t/basics/wrapped_method_cxt_propagation.t b/t/basics/wrapped_method_cxt_propagation.t new file mode 100644 index 0000000..ce1e243 --- /dev/null +++ b/t/basics/wrapped_method_cxt_propagation.t @@ -0,0 +1,56 @@ +use strict; +use warnings; + +use Test::More; + + +{ + package TouchyBase; + use Moose; + + 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 Moose; + + 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" ); + } +} + +done_testing; |