X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil.pm;h=d4c0d93495760bd331f901791c51be87ddbec498;hb=70a69dd18fb75bd1ada6e8067ea1a3e50d1546d0;hp=113f6b1120192a9edf583d4577e53983cbd843e2;hpb=7125b244a930704aad50320f730d27e97f948e9a;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm index 113f6b1..d4c0d93 100644 --- a/lib/Moose/Util.pm +++ b/lib/Moose/Util.pm @@ -3,53 +3,61 @@ package Moose::Util; use strict; use warnings; +use Data::OptList; use Sub::Exporter; -use Scalar::Util (); -use Class::MOP (); +use Scalar::Util 'blessed'; +use Class::MOP 0.60; -our $VERSION = '0.01'; +our $VERSION = '0.83'; +$VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; my @exports = qw[ - does_role - search_class_by_role + find_meta + does_role + search_class_by_role + ensure_all_roles + apply_all_roles + get_all_init_args + get_all_attribute_values + resolve_metatrait_alias + resolve_metaclass_alias + add_method_modifier + english_list ]; Sub::Exporter::setup_exporter({ exports => \@exports, - groups => { default => \@exports } + groups => { all => \@exports } }); ## some utils for the utils ... -sub _get_meta { - return unless $_[0]; - return Class::MOP::get_metaclass_by_name(ref($_[0]) || $_[0]); -} +sub find_meta { Class::MOP::class_of(@_) } ## the functions ... sub does_role { my ($class_or_obj, $role) = @_; - my $meta = _get_meta($class_or_obj); - - return unless defined $meta; + my $meta = find_meta($class_or_obj); + return unless defined $meta; + return unless $meta->can('does_role'); return 1 if $meta->does_role($role); return; } sub search_class_by_role { my ($class_or_obj, $role_name) = @_; - - my $meta = _get_meta($class_or_obj); + + my $meta = find_meta($class_or_obj); return unless defined $meta; foreach my $class ($meta->class_precedence_list) { - - my $_meta = _get_meta($class); + + my $_meta = find_meta($class); next unless defined $_meta; @@ -61,6 +69,144 @@ sub search_class_by_role { return; } +# this can possibly behave in unexpected ways because the roles being composed +# before being applied could differ from call to call; I'm not sure if or how +# to document this possible quirk. +sub ensure_all_roles { + my $applicant = shift; + _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_); +} + +sub apply_all_roles { + my $applicant = shift; + _apply_all_roles($applicant, sub { 1 }, @_); +} + +sub _apply_all_roles { + my $applicant = shift; + my $role_filter = shift; + + unless (@_) { + require Moose; + Moose->throw_error("Must specify at least one role to apply to $applicant"); + } + + my $roles = Data::OptList::mkopt( [@_] ); + + foreach my $role (@$roles) { + Class::MOP::load_class( $role->[0] ); + my $meta = Class::MOP::class_of( $role->[0] ); + + unless ($meta && $meta->isa('Moose::Meta::Role') ) { + require Moose; + Moose->throw_error( "You can only consume roles, " + . $role->[0] + . " is not a Moose role" ); + } + } + + @$roles = grep { local $_ = $_->[0]; $role_filter->() } @$roles; + + return unless @$roles; + + 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); + } +} + +# instance deconstruction ... + +sub get_all_attribute_values { + my ($class, $instance) = @_; + return +{ + map { $_->name => $_->get_value($instance) } + grep { $_->has_value($instance) } + $class->get_all_attributes + }; +} + +sub get_all_init_args { + my ($class, $instance) = @_; + return +{ + map { $_->init_arg => $_->get_value($instance) } + grep { $_->has_value($instance) } + grep { defined($_->init_arg) } + $class->get_all_attributes + }; +} + +sub resolve_metatrait_alias { + return resolve_metaclass_alias( @_, trait => 1 ); +} + +{ + my %cache; + + sub resolve_metaclass_alias { + my ( $type, $metaclass_name, %options ) = @_; + + my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' ); + 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 $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; + } +} + +sub add_method_modifier { + my ( $class_or_obj, $modifier_name, $args ) = @_; + my $meta = 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] ) ) { + if ( $method_modifier_type eq 'Regexp' ) { + my @all_methods = $meta->get_all_methods; + my @matched_methods + = grep { $_->name =~ @{$args}[0] } @all_methods; + $meta->$add_modifier_method( $_->name, $code ) + for @matched_methods; + } + } + else { + $meta->$add_modifier_method( $_, $code ) for @{$args}; + } +} + +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__ @@ -73,7 +219,9 @@ Moose::Util - Utilities for working with Moose classes =head1 SYNOPSIS - use Moose::Util qw/does_role search_class_by_role/; + use Moose::Util qw/find_meta does_role search_class_by_role/; + + my $meta = find_meta($object) || die "No metaclass found"; if (does_role($object, $role)) { print "The object can do $role!\n"; @@ -84,23 +232,82 @@ Moose::Util - Utilities for working with Moose classes =head1 DESCRIPTION -This is a set of utility functions to help working with Moose classes. This -is an experimental module, and it's not 100% clear what purpose it will serve. -That said, 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 B create one if it +does not yet exist. + +=item B + +Returns true if C<$class_or_obj> does the given C<$role_name>. + +The class must already have a metaclass for this to work. + +=item B + +Returns the first class in the class's precedence list that does +C<$role_name>, if any. + +The class must already have a metaclass for this to work. + +=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. + +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 + +This function is similar to L, but only applies roles that +C<$applicant> does not already consume. + +=item B + +Returns a hash reference containing all of the C<$instance>'s +attributes. The keys are attribute names. + +=item B + +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 + +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", + ); -Returns true if C<$class_or_obj> can do the role C<$role_name>. +The name resolution mechanism is covered in L. -=item B +=item B -Returns first class in precedence list that consumed C<$role_name>. +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 @@ -118,7 +325,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 +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. @@ -134,12 +341,12 @@ Stevan Little =head1 COPYRIGHT AND LICENSE -Copyright 2007 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