From: Tokuhiro Matsuno Date: Sun, 7 Dec 2008 12:52:48 +0000 (+0000) Subject: improvement the compatibility with Moose. X-Git-Tag: 0.19~136^2~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8632b6fe69bd4417ad67fbcbbca617ad4fd54ccb;p=gitmo%2FMouse.git improvement the compatibility with Moose. --- diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index 642f738..3a0a529 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -64,6 +64,7 @@ sub add_method { my $pkg = $self->name; no strict 'refs'; + $self->{'methods'}->{$name}++; # Moose stores meta object here. *{ $pkg . '::' . $name } = $code; } @@ -74,10 +75,11 @@ sub get_method_list { no strict 'refs'; # Get all the CODE symbol table entries - my @functions = grep !/^meta$/, - grep { /\A[^\W\d]\w*\z/o } + my @functions = + grep !/(?:has|with|around|before|after|blessed|extends|confess)/, grep { defined &{"${name}::$_"} } keys %{"${name}::"}; + push @functions, keys %{$self->{'methods'}->{$name}}; wantarray ? @functions : \@functions; } @@ -143,11 +145,13 @@ sub clone_instance { sub make_immutable { my $self = shift; + my %args = @_; my $name = $self->name; $self->{is_immutable}++; - no strict 'refs'; - *{"$name\::new"} = Mouse::Meta::Method::Constructor->generate_constructor_method_inline( $self ); - *{"$name\::DESTROY"} = Mouse::Meta::Method::Destructor->generate_destructor_method_inline( $self ); + $self->add_method('new' => Mouse::Meta::Method::Constructor->generate_constructor_method_inline( $self )); + if ($args{inline_destructor}) { + $self->add_method('DESTROY' => Mouse::Meta::Method::Destructor->generate_destructor_method_inline( $self )); + } } sub make_mutable { Carp::croak "Mouse::Meta::Class->make_mutable does not supported by Mouse"; diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm index 2ce294c..5f8f567 100644 --- a/lib/Mouse/Meta/Role.pm +++ b/lib/Mouse/Meta/Role.pm @@ -61,8 +61,8 @@ sub get_method_list { no strict 'refs'; # Get all the CODE symbol table entries - my @functions = grep !/^meta$/, - grep { /\A[^\W\d]\w*\z/o } + my @functions = + grep !/(?:has|with|around|before|after|blessed|extends|confess|excludes|meta|requires)/, grep { defined &{"${name}::$_"} } keys %{"${name}::"}; wantarray ? @functions : \@functions; @@ -86,7 +86,7 @@ sub apply { { no strict 'refs'; for my $name ($self->get_method_list) { - next if $name eq 'has' || $name eq 'requires' || $name eq 'meta' || $name eq 'with' || $name eq 'around' || $name eq 'before' || $name eq 'after' || $name eq 'blessed' || $name eq 'extends' || $name eq 'confess' || $name eq 'excludes'; + next if $name eq 'meta'; if ($classname->can($name)) { # XXX what's Moose's behavior? @@ -163,7 +163,7 @@ sub combine_apply { my $selfname = $self->name; my %args = %{ $role_spec->[1] }; for my $name ($self->get_method_list) { - next if $name eq 'has' || $name eq 'requires' || $name eq 'meta' || $name eq 'with' || $name eq 'around' || $name eq 'before' || $name eq 'after' || $name eq 'blessed' || $name eq 'extends' || $name eq 'confess' || $name eq 'excludes'; + next if $name eq 'meta'; if ($classname->can($name)) { # XXX what's Moose's behavior? diff --git a/t/000-recipes/001_point.t b/t/000-recipes/001_point.t index 23f15d5..23d5e8f 100644 --- a/t/000-recipes/001_point.t +++ b/t/000-recipes/001_point.t @@ -33,6 +33,7 @@ BEGIN { $self->y(0); } + __PACKAGE__->meta->make_immutable(); }{ package Point3D; use Mouse; @@ -46,6 +47,7 @@ BEGIN { $self->{z} = 0; }; + __PACKAGE__->meta->make_immutable(); } my $point = Point->new(x => 1, y => 2); @@ -139,13 +141,13 @@ is_deeply( my @Point_methods = qw(meta new x y clear); my @Point_attrs = ('x', 'y'); -SKIP: { - skip "Mouse has no method introspection", 2 + @Point_methods; +is_deeply( + [ sort @Point_methods ], + [ sort Point->meta->get_method_list() ], + '... we match the method list for Point'); - is_deeply( - [ sort @Point_methods ], - [ sort Point->meta->get_method_list() ], - '... we match the method list for Point'); +SKIP: { + skip "Mouse has no method introspection", 1 + @Point_methods; is_deeply( [ sort @Point_attrs ], diff --git a/t/034-apply_all_roles.t b/t/034-apply_all_roles.t index b36ea2d..c2979ef 100644 --- a/t/034-apply_all_roles.t +++ b/t/034-apply_all_roles.t @@ -30,5 +30,5 @@ Mouse::Util::apply_all_roles('Baz', 'FooRole'); my $baz = Baz->new; is $baz->foo, 'ok1'; is $baz->bar, 'ok2'; -is join(",", sort $baz->meta->get_method_list), 'bar,foo'; +is join(",", sort $baz->meta->get_method_list), 'bar,foo,meta'; diff --git a/t/800_shikabased/013-compatibility-get_method_list.t b/t/800_shikabased/013-compatibility-get_method_list.t new file mode 100644 index 0000000..8e85b84 --- /dev/null +++ b/t/800_shikabased/013-compatibility-get_method_list.t @@ -0,0 +1,37 @@ +use strict; +use warnings; +use Test::More; +plan skip_all => "This test requires Moose" unless eval "require Moose; 1;"; +plan tests => 6; + +test($_) for qw/Moose Mouse/; +exit; + +sub test { + my $class = shift; + eval <<"..."; +{ + package ${class}Class; + use ${class}; + sub foo { } + no ${class}; +} +{ + package ${class}ClassImm; + use ${class}; + sub foo { } + no ${class}; + __PACKAGE__->meta->make_immutable(); +} +{ + package ${class}Role; + use ${class}::Role; + sub bar { } +} +... + die $@ if $@; + is join(',', sort "${class}Class"->meta->get_method_list()), 'foo,meta'; + is join(',', sort "${class}ClassImm"->meta->get_method_list()), 'foo,meta,new'; + is join(',', sort "${class}Role"->meta->get_method_list()), 'bar'; +} +