X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil.pm;h=115aa8f5c3e5814b9c78b7442ad022df81ca343a;hb=49c4d7468795378b66df85894e8e2bf8e27ca02c;hp=83a14fe8677930aa0b5521fa4982ddc269175415;hpb=30350cb4d7b4345131ed638b2b30e7d1b7b1ef4c;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm index 83a14fe..115aa8f 100644 --- a/lib/Moose/Util.pm +++ b/lib/Moose/Util.pm @@ -3,25 +3,30 @@ package Moose::Util; use strict; use warnings; +use Data::OptList; use Sub::Exporter; use Scalar::Util 'blessed'; use Class::MOP 0.60; -our $VERSION = '0.65'; +our $VERSION = '1.08'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; my @exports = qw[ - find_meta + find_meta does_role - search_class_by_role + search_class_by_role + ensure_all_roles apply_all_roles + with_traits get_all_init_args get_all_attribute_values resolve_metatrait_alias resolve_metaclass_alias add_method_modifier english_list + meta_attribute_alias + meta_class_alias ]; Sub::Exporter::setup_exporter({ @@ -31,10 +36,7 @@ Sub::Exporter::setup_exporter({ ## some utils for the utils ... -sub find_meta { - return unless $_[0]; - return Class::MOP::get_metaclass_by_name(blessed($_[0]) || $_[0]); -} +sub find_meta { Class::MOP::class_of(@_) } ## the functions ... @@ -42,7 +44,7 @@ sub does_role { my ($class_or_obj, $role) = @_; my $meta = find_meta($class_or_obj); - + return unless defined $meta; return unless $meta->can('does_role'); return 1 if $meta->does_role($role); @@ -50,15 +52,17 @@ 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); + + my $_meta = find_meta($class); next unless defined $_meta; @@ -70,34 +74,79 @@ 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, undef, @_); +} + +sub _apply_all_roles { + my $applicant = shift; + my $role_filter = shift; - Moose->throw_error("Must specify at least one role to apply to $applicant") unless @_; + unless (@_) { + require Moose; + Moose->throw_error("Must specify at least one role to apply to $applicant"); + } my $roles = Data::OptList::mkopt( [@_] ); - my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) ); + my @role_metas; + foreach my $role (@$roles) { + my $meta; + + if ( blessed $role->[0] ) { + $meta = $role->[0]; + } + else { + Class::MOP::load_class( $role->[0] , $role->[1] ); + $meta = Class::MOP::class_of( $role->[0] ); + } - foreach my $role_spec (@$roles) { - Class::MOP::load_class( $role_spec->[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" ); + } + + push @role_metas, [ $meta, $role->[1] ]; } - ( $_->[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 ( defined $role_filter ) { + @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas; + } - if ( scalar @$roles == 1 ) { - my ( $role, $params ) = @{ $roles->[0] }; - $role->meta->apply( $meta, ( defined $params ? %$params : () ) ); + return unless @role_metas; + + my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) ); + + 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); } } +sub with_traits { + my ($class, @roles) = @_; + return $class unless @roles; + return Moose::Meta::Class->create_anon_class( + superclasses => [$class], + roles => \@roles, + cache => 1, + )->name; +} + # instance deconstruction ... sub get_all_attribute_values { @@ -105,7 +154,7 @@ sub get_all_attribute_values { return +{ map { $_->name => $_->get_value($instance) } grep { $_->has_value($instance) } - $class->compute_all_applicable_attributes + $class->get_all_attributes }; } @@ -114,8 +163,8 @@ sub get_all_init_args { return +{ map { $_->init_arg => $_->get_value($instance) } grep { $_->has_value($instance) } - grep { defined($_->init_arg) } - $class->compute_all_applicable_attributes + grep { defined($_->init_arg) } + $class->get_all_attributes }; } @@ -123,6 +172,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; @@ -133,12 +191,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, @@ -154,7 +209,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] ) ) { @@ -165,6 +223,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}; @@ -184,6 +254,37 @@ sub english_list { return $list; } +sub _caller_info { + my $level = @_ ? ($_[0] + 1) : 2; + my %info; + @info{qw(package file line)} = caller($level); + 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__ @@ -209,64 +310,92 @@ 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 B create one if it +does not yet exist. + +=item B + +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. If it doesn't, this +function simply returns false. + +=item B -This will attempt to locate a metaclass for the given C<$class_or_obj> -and return it. +Returns the first class in the class's precedence list that does +C<$role_or_obj>, if any. The role can be either a name or a +L object. -=item B +The class must already have a metaclass for this to work. -Returns true if C<$class_or_obj> can do the role 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. -Returns first class in precedence list that consumed C<$role_name>. +The C<$applicant> must already have a metaclass object. -=item B +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>). -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. +=item B + +This function is similar to L, but only applies roles that +C<$applicant> does not already consume. + +=item B + +This function creates a new class from C<$class_name> with each of +C<@role_names> applied. It returns the name of the new class. =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 -=item B +Create an alias from the class C<$from> (or the current package, if +C<$from> is unspecified), so that +L works properly. =item B @@ -290,9 +419,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 @@ -306,12 +433,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