X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil.pm;h=67b33ad207db9e732a75b8977e44d2bde4c224cb;hb=c2685d2054e3f63cf38fca4fad1074b4a2e5be83;hp=a5523523be9ad5a641ceeb97dda64124df1d52f3;hpb=19fabdd362b0d39023e2359b59701c4fc42247de;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm index a552352..67b33ad 100644 --- a/lib/Moose/Util.pm +++ b/lib/Moose/Util.pm @@ -5,10 +5,10 @@ use warnings; use Sub::Exporter; use Scalar::Util 'blessed'; -use Carp 'confess'; -use Class::MOP 0.56; +use Class::MOP 0.60; -our $VERSION = '0.52'; +our $VERSION = '0.73'; +$VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; my @exports = qw[ @@ -21,6 +21,7 @@ my @exports = qw[ resolve_metatrait_alias resolve_metaclass_alias add_method_modifier + english_list ]; Sub::Exporter::setup_exporter({ @@ -71,33 +72,35 @@ sub search_class_by_role { sub apply_all_roles { my $applicant = shift; - - confess "Must specify at least one role to apply to $applicant" unless @_; - - my $roles = Data::OptList::mkopt([ @_ ]); - - #use Data::Dumper; - #warn Dumper $roles; - - my $meta = (blessed $applicant ? $applicant : find_meta($applicant)); - - foreach my $role_spec (@$roles) { - Class::MOP::load_class($role_spec->[0]); + + unless (@_) { + require Moose; + Moose->throw_error("Must specify at least one role to apply to $applicant"); } - - ($_->[0]->can('meta') && $_->[0]->meta->isa('Moose::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 : ())); + my $roles = Data::OptList::mkopt( [@_] ); + + foreach my $role (@$roles) { + my $meta = Class::MOP::load_class( $role->[0] ); + + unless ($meta->isa('Moose::Meta::Role') ) { + require Moose; + Moose->throw_error( "You can only consume roles, " + . $role->[0] + . " is not a Moose role" ); + } + } + + 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 : () ) ); } else { - Moose::Meta::Role->combine( - @$roles - )->apply($meta); - } + Moose::Meta::Role->combine( @$roles )->apply($meta); + } } # instance deconstruction ... @@ -122,25 +125,35 @@ sub get_all_init_args { } sub resolve_metatrait_alias { - resolve_metaclass_alias( @_, trait => 1 ); + return resolve_metaclass_alias( @_, trait => 1 ); } -sub resolve_metaclass_alias { - my ( $type, $metaclass_name, %options ) = @_; +{ + my %cache; - if ( my $resolved = eval { - my $possible_full_name = 'Moose::Meta::' . $type . '::Custom::' . ( $options{trait} ? "Trait::" : "" ) . $metaclass_name; + sub resolve_metaclass_alias { + my ( $type, $metaclass_name, %options ) = @_; - Class::MOP::load_class($possible_full_name); + my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' ); + return $cache{$cache_key}{$metaclass_name} + if $cache{$cache_key}{$metaclass_name}; - $possible_full_name->can('register_implementation') - ? $possible_full_name->register_implementation - : $possible_full_name; - } ) { - return $resolved; - } else { - Class::MOP::load_class($metaclass_name); - return $metaclass_name; + my $possible_full_name + = 'Moose::Meta::' + . $type + . '::Custom::' + . ( $options{trait} ? "Trait::" : "" ) + . $metaclass_name; + + my $loaded_class = Class::MOP::load_first_existing_class( + $possible_full_name, + $metaclass_name + ); + + return $cache{$cache_key}{$metaclass_name} + = $loaded_class->can('register_implementation') + ? $loaded_class->register_implementation + : $loaded_class; } } @@ -151,10 +164,10 @@ sub add_method_modifier { my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier'; if ( my $method_modifier_type = ref( @{$args}[0] ) ) { if ( $method_modifier_type eq 'Regexp' ) { - my @all_methods = $meta->compute_all_applicable_methods; + my @all_methods = $meta->get_all_methods; my @matched_methods - = grep { $_->{name} =~ @{$args}[0] } @all_methods; - $meta->$add_modifier_method( $_->{name}, $code ) + = grep { $_->name =~ @{$args}[0] } @all_methods; + $meta->$add_modifier_method( $_->name, $code ) for @matched_methods; } } @@ -163,6 +176,19 @@ sub add_method_modifier { } } +sub english_list { + my @items = sort @_; + + return $items[0] if @items == 1; + return "$items[0] and $items[1]" if @items == 2; + + my $tail = pop @items; + my $list = join ', ', @items; + $list .= ', and ' . $tail; + + return $list; +} + 1; __END__ @@ -188,64 +214,77 @@ Moose::Util - Utilities for working with Moose classes =head1 DESCRIPTION -This is a set of utility functions to help working with Moose classes, and -is used internally by Moose itself. The goal is to provide useful functions -that for both Moose users and Moose extenders (MooseX:: authors). - -This is a relatively new addition to the Moose toolchest, so ideas, -suggestions and contributions to this collection are most welcome. -See the L section below for a list of ideas for possible functions -to write. +This module provides a set of utility functions. Many of these +functions are intended for use in Moose itself or MooseX modules, but +some of them may be useful for use in your own code. =head1 EXPORTED FUNCTIONS =over 4 -=item B +=item B + +This method takes a class name or object and attempts to find a +metaclass for the class, if one exists. It will not create one if it +does not yet exist. + +=item B + +Returns true if C<$class_or_obj> does the given C<$role_name>. -This will attempt to locate a metaclass for the given C<$class_or_obj> -and return it. +The class must already have a metaclass for this to work. -=item B +=item B -Returns true if C<$class_or_obj> can do the role C<$role_name>. +Returns the first class in the class's precedence list that does +C<$role_name>, if any. -=item B +The class must already have a metaclass for this to work. -Returns first class in precedence list that consumed C<$role_name>. +=item B -=item B +This function applies one or more roles to the given C<$applicant> The +applicant can be a role name, class name, or object. -Given an C<$applicant> (which can somehow be turned into either a -metaclass or a metarole) and a list of C<@roles> this will do the -right thing to apply the C<@roles> to the C<$applicant>. This is -actually used internally by both L and L, and the -C<@roles> will be pre-processed through L -to allow for the additional arguments to be passed. +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). =item B -Returns the values of the C<$instance>'s fields keyed by the attribute names. +Returns a hash reference containing all of the C<$instance>'s +attributes. The keys are attribute names. =item B -Returns a hash reference where the keys are all the attributes' Cs -and the values are the instance's fields. Attributes without an C -will be skipped. +Returns a hash reference containing all of the C values for +the instance's attributes. The values are the associated attribute +values. If an attribute does not have a defined C, it is +skipped. + +This could be useful in cloning an object. =item B =item B -Resolve a short name like in e.g. +Resolves a short name to a full class name. Short names are often used +when specifying the C or C option for an attribute: has foo => ( metaclass => "Bar", ); -to a full class name. +The name resolution mechanism is covered in L. + +=item B -=item B +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. =back @@ -279,12 +318,12 @@ Stevan Little =head1 COPYRIGHT AND LICENSE -Copyright 2007-2008 by Infinity Interactive, Inc. +Copyright 2007-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut