--- /dev/null
+#!/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)" );
+}
--- /dev/null
+#!/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';
+}
+
--- /dev/null
+#!/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';
+
+}
+
--- /dev/null
+#!/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';
+
+}
+
--- /dev/null
+#!/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');
+}
--- /dev/null
+#!/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
--- /dev/null
+#!/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');
+ }
+}
--- /dev/null
+#!/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" );
+ }
+}
+
--- /dev/null
+#!/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' );
--- /dev/null
+#!/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';
+
+
+
--- /dev/null
+#!/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
+
--- /dev/null
+#!/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;
+}
--- /dev/null
+#!/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');
+ }
+}
+
+
--- /dev/null
+#!/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' );
--- /dev/null
+#!/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';
--- /dev/null
+#!/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 = ();
--- /dev/null
+#!/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';
+
+}
+
--- /dev/null
+#!/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';
--- /dev/null
+#!/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' );
--- /dev/null
+#!/usr/bin/perl\r
+\r
+use strict;\r
+use warnings;\r
+\r
+\r
+{\r
+ package Foo;\r
+ use Mouse;\r
+\r
+ sub DEMOLISH {\r
+ my $self = shift;\r
+ my ($igd) = @_;\r
+\r
+ print $igd;\r
+ }\r
+}\r
+\r
+{\r
+ package Bar;\r
+ use Mouse;\r
+\r
+ sub DEMOLISH {\r
+ my $self = shift;\r
+ my ($igd) = @_;\r
+\r
+ print $igd;\r
+ }\r
+\r
+ __PACKAGE__->meta->make_immutable;\r
+}\r
+\r
+our $foo = Foo->new;\r
+our $bar = Bar->new;\r
--- /dev/null
+#!/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`;
+
--- /dev/null
+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;
+}
--- /dev/null
+
+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
--- /dev/null
+
+package Foo;
+use Mouse;
+
+has 'bar' => (is => 'rw');
+
+1;
\ No newline at end of file
projects / gitmo/Mouse.git / commitdiff