X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil.pm;h=b03caa5d17e30ef4f45ff2e8e97ed1d2c5b72e27;hb=a917d5ae83dc260c6a84fed0ffdc0d1b70c50266;hp=c50adf2d192f8a02a15c9ef7e2162398a34b67fd;hpb=5ef36adde3d619733607b9f5f1136524a00848df;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm index c50adf2..b03caa5 100644 --- a/lib/Moose/Util.pm +++ b/lib/Moose/Util.pm @@ -3,14 +3,16 @@ package Moose::Util; use strict; use warnings; +use Class::Load 0.07 qw(load_class load_first_existing_class); use Data::OptList; +use Params::Util qw( _STRING ); use Sub::Exporter; use Scalar::Util 'blessed'; -use Class::MOP 0.60; - -our $VERSION = '0.85'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; +use List::Util qw(first); +use List::MoreUtils qw(any all); +use overload (); +use Try::Tiny; +use Class::MOP; my @exports = qw[ find_meta @@ -18,12 +20,15 @@ my @exports = qw[ 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({ @@ -40,6 +45,10 @@ sub find_meta { Class::MOP::class_of(@_) } sub does_role { my ($class_or_obj, $role) = @_; + if (try { $class_or_obj->isa('Moose::Object') }) { + return $class_or_obj->does($role); + } + my $meta = find_meta($class_or_obj); return unless defined $meta; @@ -49,12 +58,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 +90,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 { @@ -91,11 +102,30 @@ sub _apply_all_roles { Moose->throw_error("Must specify at least one role to apply to $applicant"); } - my $roles = Data::OptList::mkopt( [@_] ); - + # If @_ contains role meta objects, mkopt will think that they're values, + # because they're references. In other words (roleobj1, roleobj2, + # roleobj3) will become [ [ roleobj1, roleobj2 ], [ roleobj3, undef ] ] + # -- this is no good. We'll preprocess @_ first to eliminate the potential + # bug. + # -- rjbs, 2011-04-08 + my $roles = Data::OptList::mkopt( [@_], { + moniker => 'role', + name_test => sub { + ! ref $_[0] or blessed($_[0]) && $_[0]->isa('Moose::Meta::Role') + } + }); + + 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 { + load_class( $role->[0] , $role->[1] ); + $meta = find_meta( $role->[0] ); + } unless ($meta && $meta->isa('Moose::Meta::Role') ) { require Moose; @@ -103,24 +133,41 @@ 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 @role_metas; - return unless @$roles; + load_class($applicant) + unless blessed($applicant) + || Class::MOP::class_of($applicant); - my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) ); + my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($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); } } +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 { @@ -146,6 +193,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,14 +212,11 @@ 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( + my $loaded_class = load_first_existing_class( $possible_full_name, $metaclass_name ); @@ -177,7 +230,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 +244,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}; @@ -211,19 +279,205 @@ sub _caller_info { my $level = @_ ? ($_[0] + 1) : 2; my %info; @info{qw(package file line)} = caller($level); - return \%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); +} + +# XXX - this should be added to Params::Util +sub _STRINGLIKE0 ($) { + return 1 if _STRING( $_[0] ); + if ( blessed $_[0] ) { + return overload::Method( $_[0], q{""} ); + } + + return 1 if defined $_[0] && $_[0] eq q{}; + + return 0; +} + +sub _reconcile_roles_for_metaclass { + my ($class_meta_name, $super_meta_name) = @_; + + my @role_differences = _role_differences( + $class_meta_name, $super_meta_name, + ); + + # handle the case where we need to fix compatibility between a class and + # its parent, but all roles in the class are already also done by the + # parent + # see t/metaclasses/metaclass_compat_no_fixing_bug.t + return $super_meta_name + unless @role_differences; + + return Moose::Meta::Class->create_anon_class( + superclasses => [$super_meta_name], + roles => [map { $_->name } @role_differences], + cache => 1, + )->name; +} + +sub _role_differences { + my ($class_meta_name, $super_meta_name) = @_; + my @super_role_metas + = grep { !$_->isa('Moose::Meta::Role::Composite') } + $super_meta_name->meta->can('calculate_all_roles_with_inheritance') + ? $super_meta_name->meta->calculate_all_roles_with_inheritance + : $super_meta_name->meta->can('calculate_all_roles') + ? $super_meta_name->meta->calculate_all_roles + : (); + my @role_metas + = grep { !$_->isa('Moose::Meta::Role::Composite') } + $class_meta_name->meta->can('calculate_all_roles_with_inheritance') + ? $class_meta_name->meta->calculate_all_roles_with_inheritance + : $class_meta_name->meta->can('calculate_all_roles') + ? $class_meta_name->meta->calculate_all_roles + : (); + my @differences; + for my $role_meta (@role_metas) { + push @differences, $role_meta + unless any { $_->name eq $role_meta->name } @super_role_metas; + } + return @differences; +} + +sub _classes_differ_by_roles_only { + my ( $self_meta_name, $super_meta_name ) = @_; + + my $common_base_name + = _find_common_base( $self_meta_name, $super_meta_name ); + + return unless defined $common_base_name; + + my @super_meta_name_ancestor_names + = _get_ancestors_until( $super_meta_name, $common_base_name ); + my @class_meta_name_ancestor_names + = _get_ancestors_until( $self_meta_name, $common_base_name ); + + return + unless all { _is_role_only_subclass($_) } + @super_meta_name_ancestor_names, + @class_meta_name_ancestor_names; + + return 1; +} + +sub _find_common_base { + my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_; + return unless defined $meta1 && defined $meta2; + + # FIXME? This doesn't account for multiple inheritance (not sure + # if it needs to though). For example, if somewhere in $meta1's + # history it inherits from both ClassA and ClassB, and $meta2 + # inherits from ClassB & ClassA, does it matter? And what crazy + # fool would do that anyway? + + my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa; + + return first { $meta1_parents{$_} } $meta2->linearized_isa; +} + +sub _get_ancestors_until { + my ($start_name, $until_name) = @_; + + my @ancestor_names; + for my $ancestor_name (Class::MOP::class_of($start_name)->linearized_isa) { + last if $ancestor_name eq $until_name; + push @ancestor_names, $ancestor_name; + } + return @ancestor_names; +} + +sub _is_role_only_subclass { + my ($meta_name) = @_; + my $meta = Class::MOP::Class->initialize($meta_name); + my @parent_names = $meta->superclasses; + + # XXX: don't feel like messing with multiple inheritance here... what would + # that even do? + return unless @parent_names == 1; + my ($parent_name) = @parent_names; + my $parent_meta = Class::MOP::Class->initialize($parent_name); + + # only get the roles attached to this particular class, don't look at + # superclasses + my @roles = $meta->can('calculate_all_roles') + ? $meta->calculate_all_roles + : (); + + # it's obviously not a role-only subclass if it doesn't do any roles + return unless @roles; + + # loop over all methods that are a part of the current class + # (not inherited) + for my $method ( $meta->_get_local_methods ) { + # always ignore meta + next if $method->isa('Class::MOP::Method::Meta'); + # we'll deal with attributes below + next if $method->can('associated_attribute'); + # if the method comes from a role we consumed, ignore it + next if $meta->can('does_role') + && $meta->does_role($method->original_package_name); + # FIXME - this really isn't right. Just because a modifier is + # defined in a role doesn't mean it isn't _also_ defined in the + # subclass. + next if $method->isa('Class::MOP::Method::Wrapped') + && ( + (!scalar($method->around_modifiers) + || any { $_->has_around_method_modifiers($method->name) } @roles) + && (!scalar($method->before_modifiers) + || any { $_->has_before_method_modifiers($method->name) } @roles) + && (!scalar($method->after_modifiers) + || any { $_->has_after_method_modifiers($method->name) } @roles) + ); + + return 0; + } + + # loop over all attributes that are a part of the current class + # (not inherited) + # FIXME - this really isn't right. Just because an attribute is + # defined in a role doesn't mean it isn't _also_ defined in the + # subclass. + for my $attr (map { $meta->get_attribute($_) } $meta->get_attribute_list) { + next if any { $_->has_attribute($attr->name) } @roles; + + return 0; + } + + return 1; } 1; +# ABSTRACT: Utilities for working with Moose classes + __END__ =pod -=head1 NAME - -Moose::Util - Utilities for working with Moose classes - =head1 SYNOPSIS use Moose::Util qw/find_meta does_role search_class_by_role/; @@ -253,16 +507,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,15 +530,20 @@ 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 -This function is similar to L, but only applies roles that +This function is similar to C, 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 a hash reference containing all of the C<$instance>'s @@ -307,8 +569,16 @@ 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 + +=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 @@ -332,28 +602,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. - -=head1 AUTHOR - -Anders Nor Berle Edebolaz@gmail.comE - -B - -Robert (phaylon) Sedlacek - -Stevan Little - -=head1 COPYRIGHT AND LICENSE - -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. +See L for details on reporting bugs. =cut