X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil.pm;h=f7875783753b15fd31241ab995691f991f82f435;hb=aead17e74252e3884f9f8e39912ca98fdf4b4dd5;hp=ef9646db7133da8046447ed0390768673911b881;hpb=1631b53f3cecc6033043b6e4bf858113e0054b7a;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm index ef9646d..f787578 100644 --- a/lib/Moose/Util.pm +++ b/lib/Moose/Util.pm @@ -1,35 +1,173 @@ package Moose::Util; -use Exporter qw/import/; -use Scalar::Util qw/blessed/; - use strict; use warnings; -our $VERSION = '0.01'; - -our $AUTHORITY = 'cpan:BERLE'; +use Sub::Exporter; +use Scalar::Util 'blessed'; +use Class::MOP 0.60; + +our $VERSION = '0.62'; +$VERSION = eval $VERSION; +our $AUTHORITY = 'cpan:STEVAN'; + +my @exports = qw[ + find_meta + does_role + search_class_by_role + apply_all_roles + get_all_init_args + get_all_attribute_values + resolve_metatrait_alias + resolve_metaclass_alias + add_method_modifier +]; + +Sub::Exporter::setup_exporter({ + exports => \@exports, + groups => { all => \@exports } +}); + +## some utils for the utils ... + +sub find_meta { + return unless $_[0]; + return Class::MOP::get_metaclass_by_name(blessed($_[0]) || $_[0]); +} -our @EXPORT_OK = qw/can_role search_class_by_role/; +## the functions ... -sub can_role { - my ($class,$does) = @_; +sub does_role { + my ($class_or_obj, $role) = @_; - return ((!ref $class && eval { $class->isa ('UNIVERSAL') }) || Scalar::Util::blessed ($class)) - && $class->can ('does') - && $class->does ($does); + 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 ($obj, $role_name) = @_; + my ($class_or_obj, $role_name) = @_; + + my $meta = find_meta($class_or_obj); + + return unless defined $meta; - for my $class ($obj->meta->class_precedence_list) { - for my $role (@{ $class->meta->roles || [] }) { + foreach my $class ($meta->class_precedence_list) { + + my $_meta = find_meta($class); + + next unless defined $_meta; + + foreach my $role (@{ $_meta->roles || [] }) { return $class if $role->name eq $role_name; } } - return undef; + return; +} + +sub apply_all_roles { + my $applicant = shift; + + Moose->throw_error("Must specify at least one role to apply to $applicant") unless @_; + + my $roles = Data::OptList::mkopt( [@_] ); + + my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) ); + + foreach my $role_spec (@$roles) { + Class::MOP::load_class( $role_spec->[0] ); + } + + ( $_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role') ) + || Moose->throw_error("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 : () ) ); + } + 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->compute_all_applicable_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->compute_all_applicable_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}; + } } 1; @@ -40,34 +178,93 @@ __END__ =head1 NAME -Moose::Util - Moose utilities +Moose::Util - Utilities for working with Moose classes =head1 SYNOPSIS - use Moose::Util qw/can_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 (can_role ($object,'rolename')) { - print "The object can do rolename!\n"; + if (does_role($object, $role)) { + print "The object can do $role!\n"; } my $class = search_class_by_role($object, 'FooRole'); print "Nearest class with 'FooRole' is $class\n"; -=head1 FUNCTIONS +=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. + +=head1 EXPORTED FUNCTIONS =over 4 -=item can_role +=item B + +This will attempt to locate a metaclass for the given C<$class_or_obj> +and return it. + +=item B + +Returns true if C<$class_or_obj> can do the role C<$role_name>. + +=item B + +Returns first class in precedence list that consumed C<$role_name>. + +=item B + +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. - can_role ($object,$rolename); +=item B -Returns true if $object can do the role $rolename. +Returns the values of the C<$instance>'s fields keyed by the attribute names. -=item search_class_by_role +=item B - my $class = search_class_by_role($object, $rolename); +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 first class in precedence list that consumed C<$rolename>. +=item B + +=item B + +Resolve a short name like in e.g. + + has foo => ( + metaclass => "Bar", + ); + +to a full class name. + +=item B + +=back + +=head1 TODO + +Here is a list of possible functions to write + +=over 4 + +=item discovering original method from modified method + +=item search for origin class of a method or attribute =back @@ -81,9 +278,15 @@ to cpan-RT. Anders Nor Berle Edebolaz@gmail.comE +B + +Robert (phaylon) Sedlacek + +Stevan Little + =head1 COPYRIGHT AND LICENSE -Copyright 2007 by Infinity Interactive, Inc. +Copyright 2007-2008 by Infinity Interactive, Inc. L