X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil.pm;h=0eec91d7b12d372b8dcc89f5161528616ddfb065;hb=3eb89f709f04907580b508f821d6be2316fcb65f;hp=abd6c16cccb549d5c872a07c33dd926688872c1b;hpb=0f8380b0cdbda1e13ed7c456edd3f0d1c0315ec9;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm index abd6c16..0eec91d 100644 --- a/lib/Moose/Util.pm +++ b/lib/Moose/Util.pm @@ -8,7 +8,7 @@ use Sub::Exporter; use Scalar::Util 'blessed'; use Class::MOP 0.60; -our $VERSION = '0.86'; +our $VERSION = '1.01'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -24,6 +24,8 @@ my @exports = qw[ resolve_metaclass_alias add_method_modifier english_list + meta_attribute_alias + meta_class_alias ]; Sub::Exporter::setup_exporter({ @@ -49,12 +51,14 @@ sub does_role { } sub search_class_by_role { - my ($class_or_obj, $role_name) = @_; + my ($class_or_obj, $role) = @_; my $meta = find_meta($class_or_obj); return unless defined $meta; + my $role_name = blessed $role ? $role->name : $role; + foreach my $class ($meta->class_precedence_list) { my $_meta = find_meta($class); @@ -79,7 +83,7 @@ sub ensure_all_roles { sub apply_all_roles { my $applicant = shift; - _apply_all_roles($applicant, sub { 1 }, @_); + _apply_all_roles($applicant, undef, @_); } sub _apply_all_roles { @@ -93,9 +97,17 @@ sub _apply_all_roles { my $roles = Data::OptList::mkopt( [@_] ); + my @role_metas; foreach my $role (@$roles) { - Class::MOP::load_class( $role->[0] ); - my $meta = Class::MOP::class_of( $role->[0] ); + my $meta; + + if ( blessed $role->[0] ) { + $meta = $role->[0]; + } + else { + Class::MOP::load_class( $role->[0] ); + $meta = Class::MOP::class_of( $role->[0] ); + } unless ($meta && $meta->isa('Moose::Meta::Role') ) { require Moose; @@ -103,21 +115,24 @@ sub _apply_all_roles { . $role->[0] . " is not a Moose role" ); } + + push @role_metas, [ $meta, $role->[1] ]; } - @$roles = grep { local $_ = $_->[0]; $role_filter->() } @$roles; + if ( defined $role_filter ) { + @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas; + } - return unless @$roles; + return unless @role_metas; my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) ); - if ( scalar @$roles == 1 ) { - my ( $role, $params ) = @{ $roles->[0] }; - my $role_meta = Class::MOP::class_of($role); - $role_meta->apply( $meta, ( defined $params ? %$params : () ) ); + if ( scalar @role_metas == 1 ) { + my ( $role, $params ) = @{ $role_metas[0] }; + $role->apply( $meta, ( defined $params ? %$params : () ) ); } else { - Moose::Meta::Role->combine( @$roles )->apply($meta); + Moose::Meta::Role->combine(@role_metas)->apply($meta); } } @@ -146,6 +161,15 @@ sub resolve_metatrait_alias { return resolve_metaclass_alias( @_, trait => 1 ); } +sub _build_alias_package_name { + my ($type, $name, $trait) = @_; + return 'Moose::Meta::' + . $type + . '::Custom::' + . ( $trait ? 'Trait::' : '' ) + . $name; +} + { my %cache; @@ -156,12 +180,9 @@ sub resolve_metatrait_alias { return $cache{$cache_key}{$metaclass_name} if $cache{$cache_key}{$metaclass_name}; - my $possible_full_name - = 'Moose::Meta::' - . $type - . '::Custom::' - . ( $options{trait} ? "Trait::" : "" ) - . $metaclass_name; + my $possible_full_name = _build_alias_package_name( + $type, $metaclass_name, $options{trait} + ); my $loaded_class = Class::MOP::load_first_existing_class( $possible_full_name, @@ -177,7 +198,10 @@ sub resolve_metatrait_alias { sub add_method_modifier { my ( $class_or_obj, $modifier_name, $args ) = @_; - my $meta = find_meta($class_or_obj); + my $meta + = $class_or_obj->can('add_before_method_modifier') + ? $class_or_obj + : find_meta($class_or_obj); my $code = pop @{$args}; my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier'; if ( my $method_modifier_type = ref( @{$args}[0] ) ) { @@ -188,6 +212,18 @@ sub add_method_modifier { $meta->$add_modifier_method( $_->name, $code ) for @matched_methods; } + elsif ($method_modifier_type eq 'ARRAY') { + $meta->$add_modifier_method( $_, $code ) for @{$args->[0]}; + } + else { + $meta->throw_error( + sprintf( + "Methods passed to %s must be provided as a list, arrayref or regex, not %s", + $modifier_name, + $method_modifier_type, + ) + ); + } } else { $meta->$add_modifier_method( $_, $code ) for @{$args}; @@ -214,6 +250,30 @@ sub _caller_info { return \%info; } +sub _create_alias { + my ($type, $name, $trait, $for) = @_; + my $package = _build_alias_package_name($type, $name, $trait); + Class::MOP::Class->initialize($package)->add_method( + register_implementation => sub { $for } + ); +} + +sub meta_attribute_alias { + my ($to, $from) = @_; + $from ||= caller; + my $meta = Class::MOP::class_of($from); + my $trait = $meta->isa('Moose::Meta::Role'); + _create_alias('Attribute', $to, $trait, $from); +} + +sub meta_class_alias { + my ($to, $from) = @_; + $from ||= caller; + my $meta = Class::MOP::class_of($from); + my $trait = $meta->isa('Moose::Meta::Role'); + _create_alias('Class', $to, $trait, $from); +} + 1; __END__ @@ -253,16 +313,19 @@ This method takes a class name or object and attempts to find a metaclass for the class, if one exists. It will B create one if it does not yet exist. -=item B +=item B -Returns true if C<$class_or_obj> does the given C<$role_name>. +Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can +be provided as a name or a L object. -The class must already have a metaclass for this to work. +The class must already have a metaclass for this to work. If it doesn't, this +function simply returns false. -=item B +=item B Returns the first class in the class's precedence list that does -C<$role_name>, if any. +C<$role_or_obj>, if any. The role can be either a name or a +L object. The class must already have a metaclass for this to work. @@ -273,9 +336,9 @@ applicant can be a role name, class name, or object. The C<$applicant> must already have a metaclass object. -The list of C<@roles> should be a list of names, each of which can be -followed by an optional hash reference of options (C and -C). +The list of C<@roles> should a list of names or L objects, +each of which can be followed by an optional hash reference of options +(C<-excludes> and C<-alias>). =item B @@ -307,8 +370,8 @@ when specifying the C or C option for an attribute: metaclass => "Bar", ); -The name resolution mechanism is covered in L. +The name resolution mechanism is covered in +L. =item B @@ -316,6 +379,14 @@ Given a list of scalars, turns them into a proper list in English ("one and two", "one, two, three, and four"). This is used to help us make nicer error messages. +=item B + +=item B + +Create an alias from the class C<$from> (or the current package, if +C<$from> is unspecified), so that +L works properly. + =back =head1 TODO @@ -332,9 +403,7 @@ Here is a list of possible functions to write =head1 BUGS -All complex software has bugs lurking in it, and this module is no -exception. If you find a bug please either email me, or add the bug -to cpan-RT. +See L for details on reporting bugs. =head1 AUTHOR