0.30
+ * Work around anonymous classes as mortal classes
+
+ * Implement with $role => -exlucdes => [...] (gfx)
+
+ * Implement get_method() in M::Meta::Class and M::Meta::Role (gfx)
+
* Make get_method_list() compatible with Moose's (gfx)
* Make unimport() not to remove non-Mouse functions (blessed and confess) (gfx)
* Support is => 'bare', and you must pass and 'is' option to has() (gfx)
- * Make generator methods private (gfx)
-
0.29 Thu Sep 17 11:49:49 2009
* role class has ->meta in method_list, because it does in Moose since 0.9
|| $class->throw_error("You must pass a HASH ref of methods")
if exists $options{methods};
- do {
+ {
( defined $package_name && $package_name )
|| $class->throw_error("You must pass a package name");
- my $code = "package $package_name;";
- $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';"
- if exists $options{version};
- $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';"
- if exists $options{authority};
-
- eval $code;
- $class->throw_error("creation of $package_name failed : $@") if $@;
- };
+ no strict 'refs';
+ ${ $package_name . '::VERSION' } = $options{version} if exists $options{version};
+ ${ $package_name . '::AUTHORITY' } = $options{authority} if exists $options{authority};
+ }
my %initialize_options = %options;
delete @initialize_options{qw(
{
my $ANON_CLASS_SERIAL = 0;
my $ANON_CLASS_PREFIX = 'Mouse::Meta::Class::__ANON__::SERIAL::';
+
+ my %IMMORTAL_ANON_CLASSES;
sub create_anon_class {
my ( $class, %options ) = @_;
+
+ my $cache = $options{cache};
+ my $cache_key;
+
+ if($cache){ # anonymous but not mortal
+ # something like Super::Class|Super::Class::2=Role|Role::1\r
+ $cache_key = join '=' => (\r
+ join('|', @{$options{superclasses} || []}),\r
+ join('|', sort @{$options{roles} || []}),\r
+ );
+ return $IMMORTAL_ANON_CLASSES{$cache_key} if exists $IMMORTAL_ANON_CLASSES{$cache_key};
+ }
my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
- return $class->create( $package_name, %options );
+ my $meta = $class->create( $package_name, anon_class_id => $ANON_CLASS_SERIAL, %options );
+
+ if($cache){
+ $IMMORTAL_ANON_CLASSES{$cache_key} = $meta;
+ }
+ else{
+ Mouse::Meta::Module::weaken_metaclass($package_name);
+ }
+ return $meta;
}
+
+ sub is_anon_class{
+ return exists $_[0]->{anon_class_id};
+ }
+
+
+ sub DESTROY{
+ my($self) = @_;
+
+ my $serial_id = $self->{anon_class_id};
+
+ return if !$serial_id;
+
+ my $stash = $self->namespace;
+
+ @{$self->{sperclasses}} = ();
+ %{$stash} = ();
+ Mouse::Meta::Module::remove_metaclass_by_name($self->name);
+
+ no strict 'refs';
+ delete ${$ANON_CLASS_PREFIX}{ $serial_id . '::' };
+
+ return;
+ }
+
}
1;
use warnings;
use Mouse::Util qw/get_code_info not_supported load_class/;
-use Scalar::Util qw/blessed/;
+use Scalar::Util qw/blessed weaken/;
{
ok($obj->child, "local attribute set in constructor");
ok($obj->class, "inherited attribute set in constructor");
-is_deeply([Child->meta->get_all_attributes], [
+is_deeply([sort(Child->meta->get_all_attributes)], [sort(
Child->meta->get_attribute('child'),
Class->meta->get_attribute('class'),
-], "correct get_all_attributes");
+)], "correct get_all_attributes");
do {
package Foo;
use strict;
use warnings;
-use Test::More tests => 86;
+use Test::More;
+BEGIN{
+ if(eval{ require Class::Method::Modifiers::Fast } || eval{ require Class::Method::Modifier }){
+ plan tests => 86;
+ }
+ else{
+ plan skip_all => 'This test requires Class::Method::Modifiers(::Fast)?';
+ }
+}
use Test::Exception;
{
use strict;
use warnings;
+use Test::More;
+BEGIN{
+ if(eval{ require Class::Method::Modifiers::Fast } || eval{ require Class::Method::Modifier }){
+ plan tests => 74;
+ }
+ else{
+ plan skip_all => 'This test requires Class::Method::Modifiers(::Fast)?';
+ }
+}
-use Test::More tests => 74;
use Test::Exception;
BEGIN {
eval "use Test::Output;";
plan skip_all => "Test::Output is required for this test" if $@;
+
+ unless(eval { require Class::Method::Modifiers::Fast } or eval{ require Class::Method::Modifiers }){
+ plan skip_all => "Class::Method::Modifiers(::Fast)? is required for this test" if $@;
+ }
+
plan tests => 8;
}
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 25;
-use Test::Exception;
-
-use Mouse::Meta::Role;
-
-{
- package FooRole;
-
- our $VERSION = '0.01';
-
- sub foo { 'FooRole::foo' }
-}
-
-my $foo_role = Mouse::Meta::Role->initialize('FooRole');
-isa_ok($foo_role, 'Mouse::Meta::Role');
-#isa_ok($foo_role, 'Class::MOP::Module'); ## Mouse: doesn't use Class::MOP
-
-is($foo_role->name, 'FooRole', '... got the right name of FooRole');
-#is($foo_role->version, '0.01', '... got the right version of FooRole'); ## Mouse: ->version is cfrom Class::MOP
-
-# methods ...
-
-ok($foo_role->has_method('foo'), '... FooRole has the foo method');
-is($foo_role->get_method('foo')->body, \&FooRole::foo, '... FooRole got the foo method');
-
-isa_ok($foo_role->get_method('foo'), 'Mouse::Meta::Role::Method');
-
-is_deeply(
- [ $foo_role->get_method_list() ],
- [ 'foo' ],
- '... got the right method list');
-
-# attributes ...
-
-is_deeply(
- [ $foo_role->get_attribute_list() ],
- [],
- '... got the right attribute list');
-
-ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute');
-
-lives_ok {
- $foo_role->add_attribute('bar' => (is => 'rw', isa => 'Foo'));
-} '... added the bar attribute okay';
-
-is_deeply(
- [ $foo_role->get_attribute_list() ],
- [ 'bar' ],
- '... got the right attribute list');
-
-ok($foo_role->has_attribute('bar'), '... FooRole does have the bar attribute');
-
-is_deeply(
- $foo_role->get_attribute('bar'),
- { is => 'rw', isa => 'Foo' },
- '... got the correct description of the bar attribute');
-
-lives_ok {
- $foo_role->add_attribute('baz' => (is => 'ro'));
-} '... added the baz attribute okay';
-
-is_deeply(
- [ sort $foo_role->get_attribute_list() ],
- [ 'bar', 'baz' ],
- '... got the right attribute list');
-
-ok($foo_role->has_attribute('baz'), '... FooRole does have the baz attribute');
-
-is_deeply(
- $foo_role->get_attribute('baz'),
- { is => 'ro' },
- '... got the correct description of the baz attribute');
-
-lives_ok {
- $foo_role->remove_attribute('bar');
-} '... removed the bar attribute okay';
-
-is_deeply(
- [ $foo_role->get_attribute_list() ],
- [ 'baz' ],
- '... got the right attribute list');
-
-ok(!$foo_role->has_attribute('bar'), '... FooRole does not have the bar attribute');
-ok($foo_role->has_attribute('baz'), '... FooRole does still have the baz attribute');
-
-# method modifiers
-
-ok(!$foo_role->has_before_method_modifiers('boo'), '... no boo:before modifier');
-
-my $method = sub { "FooRole::boo:before" };
-lives_ok {
- $foo_role->add_before_method_modifier('boo' => $method);
-} '... added a method modifier okay';
-
-ok($foo_role->has_before_method_modifiers('boo'), '... now we have a boo:before modifier');
-is(($foo_role->get_before_method_modifiers('boo'))[0], $method, '... got the right method back');
-
-is_deeply(
- [ $foo_role->get_method_modifier_list('before') ],
- [ 'boo' ],
- '... got the right list of before method modifiers');
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 74;
-use Test::Exception;
-
-
-
-{
- # NOTE:
- # this tests that repeated role
- # composition will not cause
- # a conflict between two methods
- # which are actually the same anyway
-
- {
- package RootA;
- use Mouse::Role;
-
- sub foo { "RootA::foo" }
-
- package SubAA;
- use Mouse::Role;
-
- with "RootA";
-
- sub bar { "SubAA::bar" }
-
- package SubAB;
- use Mouse;
-
- ::lives_ok {
- with "SubAA", "RootA";
- } '... role was composed as expected';
- }
-
- ok( SubAB->does("SubAA"), "does SubAA");
- ok( SubAB->does("RootA"), "does RootA");
-
- isa_ok( my $i = SubAB->new, "SubAB" );
-
- can_ok( $i, "bar" );
- is( $i->bar, "SubAA::bar", "... got thr right bar rv" );
-
- can_ok( $i, "foo" );
- my $foo_rv;
- lives_ok {
- $foo_rv = $i->foo;
- } '... called foo successfully';
- is($foo_rv, "RootA::foo", "... got the right foo rv");
-}
-
-{
- # NOTE:
- # this edge cases shows the application of
- # an after modifier over a method which
- # was added during role composotion.
- # The way this will work is as follows:
- # role SubBA will consume RootB and
- # get a local copy of RootB::foo, it
- # will also store a deferred after modifier
- # to be applied to whatever class SubBA is
- # composed into.
- # When class SubBB comsumed role SubBA, the
- # RootB::foo method is added to SubBB, then
- # the deferred after modifier from SubBA is
- # applied to it.
- # It is important to note that the application
- # of the after modifier does not happen until
- # role SubBA is composed into SubAA.
-
- {
- package RootB;
- use Mouse::Role;
-
- sub foo { "RootB::foo" }
-
- package SubBA;
- use Mouse::Role;
-
- with "RootB";
-
- has counter => (
- isa => "Num",
- is => "rw",
- default => 0,
- );
-
- after foo => sub {
- $_[0]->counter( $_[0]->counter + 1 );
- };
-
- package SubBB;
- use Mouse;
-
- ::lives_ok {
- with "SubBA";
- } '... composed the role successfully';
- }
-
- ok( SubBB->does("SubBA"), "BB does SubBA" );
- ok( SubBB->does("RootB"), "BB does RootB" );
-
- isa_ok( my $i = SubBB->new, "SubBB" );
-
- can_ok( $i, "foo" );
-
- my $foo_rv;
- lives_ok {
- $foo_rv = $i->foo
- } '... called foo successfully';
- is( $foo_rv, "RootB::foo", "foo rv" );
- is( $i->counter, 1, "after hook called" );
-
- lives_ok { $i->foo } '... called foo successfully (again)';
- is( $i->counter, 2, "after hook called (again)" );
-
- ok(SubBA->meta->has_method('foo'), '... this has the foo method');
- #my $subba_foo_rv;
- #lives_ok {
- # $subba_foo_rv = SubBA::foo();
- #} '... called the sub as a function correctly';
- #is($subba_foo_rv, 'RootB::foo', '... the SubBA->foo is still the RootB version');
-}
-
-{
- # NOTE:
- # this checks that an override method
- # does not try to trample over a locally
- # composed in method. In this case the
- # RootC::foo, which is composed into
- # SubCA cannot be trampled with an
- # override of 'foo'
- {
- package RootC;
- use Mouse::Role;
-
- sub foo { "RootC::foo" }
-
- package SubCA;
- use Mouse::Role;
-
- with "RootC";
-
- ::dies_ok {
- override foo => sub { "overridden" };
- } '... cannot compose an override over a local method';
- }
-}
-
-# NOTE:
-# need to talk to Yuval about the motivation behind
-# this test, I am not sure we are testing anything
-# useful here (although more tests cant hurt)
-
-{
- use List::Util qw/shuffle/;
-
- {
- package Abstract;
- use Mouse::Role;
-
- requires "method";
- requires "other";
-
- sub another { "abstract" }
-
- package ConcreteA;
- use Mouse::Role;
- with "Abstract";
-
- sub other { "concrete a" }
-
- package ConcreteB;
- use Mouse::Role;
- with "Abstract";
-
- sub method { "concrete b" }
-
- package ConcreteC;
- use Mouse::Role;
- with "ConcreteA";
-
- # NOTE:
- # this was originally override, but
- # that wont work (see above set of tests)
- # so I switched it to around.
- # However, this may not be testing the
- # same thing that was originally intended
- around other => sub {
- return ( (shift)->() . " + c" );
- };
-
- package SimpleClassWithSome;
- use Mouse;
-
- eval { with ::shuffle qw/ConcreteA ConcreteB/ };
- ::ok( !$@, "simple composition without abstract" ) || ::diag $@;
-
- package SimpleClassWithAll;
- use Mouse;
-
- eval { with ::shuffle qw/ConcreteA ConcreteB Abstract/ };
- ::ok( !$@, "simple composition with abstract" ) || ::diag $@;
- }
-
- foreach my $class (qw/SimpleClassWithSome SimpleClassWithAll/) {
- foreach my $role (qw/Abstract ConcreteA ConcreteB/) {
- ok( $class->does($role), "$class does $role");
- }
-
- foreach my $method (qw/method other another/) {
- can_ok( $class, $method );
- }
-
- is( eval { $class->another }, "abstract", "provided by abstract" );
- is( eval { $class->other }, "concrete a", "provided by concrete a" );
- is( eval { $class->method }, "concrete b", "provided by concrete b" );
- }
-
- {
- package ClassWithSome;
- use Mouse;
-
- eval { with ::shuffle qw/ConcreteC ConcreteB/ };
- ::ok( !$@, "composition without abstract" ) || ::diag $@;
-
- package ClassWithAll;
- use Mouse;
-
- eval { with ::shuffle qw/ConcreteC Abstract ConcreteB/ };
- ::ok( !$@, "composition with abstract" ) || ::diag $@;
-
- package ClassWithEverything;
- use Mouse;
-
- eval { with ::shuffle qw/ConcreteC Abstract ConcreteA ConcreteB/ }; # this should clash
- ::ok( !$@, "can compose ConcreteA and ConcreteC together" );
- }
-
- foreach my $class (qw/ClassWithSome ClassWithAll ClassWithEverything/) {
- foreach my $role (qw/Abstract ConcreteA ConcreteB ConcreteC/) {
- ok( $class->does($role), "$class does $role");
- }
-
- foreach my $method (qw/method other another/) {
- can_ok( $class, $method );
- }
-
- is( eval { $class->another }, "abstract", "provided by abstract" );
- is( eval { $class->other }, "concrete a + c", "provided by concrete c + a" );
- is( eval { $class->method }, "concrete b", "provided by concrete b" );
- }
-}
use strict;
use warnings;
use Mouse ();
-use Test::More tests => 14;
+use Test::More tests => 20;
use Test::Exception;
# error handling
is Baz->new()->foo, "yay";
is Baz->new()->dooo, "iiiit";
+my($anon_pkg1, $anon_pkg2);
{
my $meta = Mouse::Meta::Class->create_anon_class(
superclasses => [ "Mouse::Object" ],
dooo => sub { "iiiit" },
}
);
- isa_ok($meta, "Mouse::Meta::Class");
- like($meta->name, qr/Class::__ANON__::/);
+ $anon_pkg1 = $meta->name;
+
+ isa_ok($meta, "Mouse::Meta::Class", 'create_anon_class');
+ ok($meta->is_anon_class, 'is_anon_class');
is $meta->name->new->dooo(), "iiiit";
- my $anon2 = Mouse::Meta::Class->create_anon_class();
- like($anon2->name, qr/Class::__ANON__::/);
+ my $anon2 = Mouse::Meta::Class->create_anon_class(cache => 1);
+ $anon_pkg2 = $anon2->name;
+
+ ok($anon2->is_anon_class);
+
+ isnt $meta, $anon2;
+ isnt $meta->name, $anon2->name;
}
+
+# all the stuff are removed?
+ok !$anon_pkg1->isa('Mouse::Object');
+ok !$anon_pkg1->can('dooo');
+ok !$anon_pkg1->can('meta');
+
+ok $anon_pkg2->can('meta'), 'cache => 1 makes it immortal';
+
projects / gitmo/Mouse.git / commitdiff