From: gfx Date: Mon, 21 Sep 2009 09:07:40 +0000 (+0900) Subject: More compatibility X-Git-Tag: 0.32~22 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=ff6870694bb440c13826e0f0fa25e760247fd24e More compatibility --- diff --git a/Makefile.PL b/Makefile.PL index aa7620c..80baa6e 100755 --- a/Makefile.PL +++ b/Makefile.PL @@ -35,33 +35,36 @@ sub create_moose_compatibility_test { require File::Spec; require File::Basename; + print "Creating xt/compatibility/* ...\n"; + # some test does not pass... currently skip it. my %SKIP_TEST = ( '016-trigger.t' => "trigger's argument is incompatble :(", '020-load-class.t' => "&Moose::is_class_loaded doesn't exists", '019-handles.t' => 'incompatible', - '025-more-isa.t' => 'Class::MOP::is_class_loaded is not compatible with Mouse::is_class_loaded', '029-new.t' => 'Class->new(undef) incompatible', '010-isa-or.t' => 'Mouse has a [BUG]', '044-attribute-metaclass.t' => 'Moose::Meta::Attribute does not have a "create"', '047-attribute-metaclass-role.t' => 'Moose::Meta::Attribute does not have a "create"', '201-squirrel.t' => 'skip Squirrel', '202-squirrel-role.t' => 'Squirrel is ...', - '400-define-role.t' => 'incompatibility', '600-tiny-tiny.t' => "Moose doesn't support ::Tiny", '601-tiny-mouse.t' => "Moose doesn't support ::Tiny", '602-mouse-tiny.t' => "Moose doesn't support ::Tiny", - '031_roles_applied_in_create.t' => 'wtf?', + '031_roles_applied_in_create.t' => 't/lib/* classes are not Moose classes/roles', ); File::Find::find( { wanted => sub { return unless -f $_; + + return if /failing/; # skip tests in failing/ directories + my $basename = File::Basename::basename($_); return if $basename =~ /^\./; return if $SKIP_TEST{$basename}; - + my $dirname = File::Basename::dirname($_); my $tmpdir = File::Spec->catfile('xt', 'compatibility', $dirname); diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index a9c76f4..3113b83 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -285,6 +285,7 @@ sub does_role { next unless $meta && $meta->can('roles'); for my $role (@{ $meta->roles }) { + return 1 if $role->does_role($role_name); } } @@ -307,6 +308,10 @@ sub create { || $class->throw_error("You must pass a HASH ref of methods") if exists $options{methods}; + (ref $options{roles} eq 'ARRAY') + || $class->throw_error("You must pass an ARRAY ref of roles") + if exists $options{roles}; + { ( defined $package_name && $package_name ) || $class->throw_error("You must pass a package name"); @@ -322,6 +327,7 @@ sub create { superclasses attributes methods + roles version authority )}; @@ -349,6 +355,9 @@ sub create { $meta->add_method($method_name, $options{methods}->{$method_name}); } } + if (exists $options{roles}){ + Mouse::Util::apply_all_roles($package_name, @{$options{roles}}); + } return $meta; } diff --git a/lib/Mouse/Role.pm b/lib/Mouse/Role.pm index 56cde3a..7104736 100644 --- a/lib/Mouse/Role.pm +++ b/lib/Mouse/Role.pm @@ -7,7 +7,7 @@ use Carp 'confess', 'croak'; use Scalar::Util 'blessed'; use Mouse::Meta::Role; -use Mouse::Util; +use Mouse::Util qw(load_class); our @EXPORT = qw(before after around super override inner augment has extends with requires excludes confess blessed); our %is_removable = map{ $_ => undef } @EXPORT; @@ -86,16 +86,11 @@ sub has { $meta->add_attribute($name => \%opts); } -sub extends { confess "Roles do not currently support 'extends'" } +sub extends { confess "Roles do not support 'extends'" } sub with { my $meta = Mouse::Meta::Role->initialize(scalar caller); - my $role = shift; - my $args = shift || {}; - confess "Mouse::Role only supports 'with' on individual roles at a time" if @_ || !ref $args; - - Mouse::load_class($role); - $role->meta->apply($meta, %$args); + Mouse::Util::apply_all_roles($meta->name, @_); } sub requires { diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm index 9f3ecf9..bcb865e 100644 --- a/lib/Mouse/Util.pm +++ b/lib/Mouse/Util.pm @@ -180,27 +180,28 @@ sub is_class_loaded { return 0 if ref($class) || !defined($class) || !length($class); - return 1 if exists $is_class_loaded_cache{$class}; + return 1 if $is_class_loaded_cache{$class}; # walk the symbol table tree to avoid autovififying # \*{${main::}{"Foo::"}} == \*main::Foo:: - my $pack = \*::; + my $pack = \%::; foreach my $part (split('::', $class)) { - return 0 unless exists ${$$pack}{"${part}::"}; - $pack = \*{${$$pack}{"${part}::"}}; + my $entry = \$pack->{$part . '::'}; + return 0 if ref($entry) ne 'GLOB'; + $pack = *{$entry}{HASH} or return 0; } # check for $VERSION or @ISA - return ++$is_class_loaded_cache{$class} if exists ${$$pack}{VERSION} - && defined *{${$$pack}{VERSION}}{SCALAR}; - return ++$is_class_loaded_cache{$class} if exists ${$$pack}{ISA} - && defined *{${$$pack}{ISA}}{ARRAY}; + return ++$is_class_loaded_cache{$class} if exists $pack->{VERSION} + && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} }; + return ++$is_class_loaded_cache{$class} if exists $pack->{ISA} + && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0; # check for any method - foreach ( keys %{$$pack} ) { - next if substr($_, -2, 2) eq '::'; - return ++$is_class_loaded_cache{$class} if defined *{${$$pack}{$_}}{CODE}; + foreach my $name( keys %{$pack} ) { + my $entry = \$pack->{$name}; + return ++$is_class_loaded_cache{$class} if ref($entry) ne 'GLOB' || defined *{$entry}{CODE}; } # fail @@ -221,18 +222,12 @@ sub apply_all_roles { } else { push @roles, [ $_[$i] => {} ]; } + my $role_name = $roles[-1][0]; + load_class($role_name); + ( $role_name->can('meta') && $role_name->meta->isa('Mouse::Meta::Role') ) + || $meta->throw_error("You can only consume roles, $role_name(".$role_name->meta.") is not a Mouse role"); } - foreach my $role_spec (@roles) { - Mouse::load_class( $role_spec->[0] ); - } - - ( $_->[0]->can('meta') && $_->[0]->meta->isa('Mouse::Meta::Role') ) - || confess("You can only consume roles, " - . $_->[0] - . " is not a Moose role") - foreach @roles; - if ( scalar @roles == 1 ) { my ( $role, $params ) = @{ $roles[0] }; $role->meta->apply( $meta, ( defined $params ? %$params : () ) ); diff --git a/t/025-more-isa.t b/t/025-more-isa.t index 022c89c..3e18e96 100755 --- a/t/025-more-isa.t +++ b/t/025-more-isa.t @@ -105,7 +105,7 @@ do { ); }; -for ('B'..'E', 'G::H') { +for ('B', 'D'..'E', 'G::H') { lives_ok { ClassNameTests->new(class => $_); }; @@ -116,17 +116,23 @@ for ('B'..'E', 'G::H') { }; } -TODO: { - local $TODO = "Moose throws errors here. Mouse does not"; - throws_ok { - ClassNameTests->new(class => 'A'); - } qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value A/; +throws_ok { + ClassNameTests->new(class => 'A'); +} qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value A/; - throws_ok { - my $obj = ClassNameTests->new; - $obj->class('A'); - } qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value A/; -} +throws_ok { + my $obj = ClassNameTests->new; + $obj->class('A'); +} qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value A/; + +throws_ok { + ClassNameTests->new(class => 'C'); +} qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value C/; + +throws_ok { + my $obj = ClassNameTests->new; + $obj->class('C'); +} qr/Attribute \(class\) does not pass the type constraint because: Validation failed for 'ClassName' failed with value C/; for ('F', 'G', 'I', 'Z') { throws_ok { diff --git a/t/400-define-role.t b/t/400-define-role.t index 1441463..47ac4ee 100644 --- a/t/400-define-role.t +++ b/t/400-define-role.t @@ -18,7 +18,7 @@ throws_ok { extends 'Role::Parent'; no Mouse::Role; -} qr/Roles do not currently support 'extends'/; +} qr/Roles do not support 'extends'/; lives_ok { package Role; @@ -93,11 +93,10 @@ lives_ok { ::is(blessed($obj), "Impromptu::Class"); }; -our $TODO = 'skip'; -throws_ok { +lives_ok{ package Class; use Mouse; with 'Role', 'Other::Role'; -} qr/Mouse::Role only supports 'with' on individual roles at a time/; +};