improve the warning for unknown attribute parameters (mjd)
[gitmo/Moose.git] / lib / Moose / Util.pm
index a269dd7..b03caa5 100644 (file)
@@ -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.95';
-$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,6 +20,7 @@ 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
@@ -42,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;
@@ -95,7 +102,18 @@ 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) {
@@ -105,8 +123,8 @@ sub _apply_all_roles {
             $meta = $role->[0];
         }
         else {
-            Class::MOP::load_class( $role->[0] );
-            $meta = Class::MOP::class_of( $role->[0] );
+            load_class( $role->[0] , $role->[1] );
+            $meta = find_meta( $role->[0] );
         }
 
         unless ($meta && $meta->isa('Moose::Meta::Role') ) {
@@ -125,7 +143,11 @@ sub _apply_all_roles {
 
     return unless @role_metas;
 
-    my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
+    load_class($applicant)
+        unless blessed($applicant)
+            || Class::MOP::class_of($applicant);
+
+    my $meta = ( blessed $applicant ? $applicant : Moose::Meta::Class->initialize($applicant) );
 
     if ( scalar @role_metas == 1 ) {
         my ( $role, $params ) = @{ $role_metas[0] };
@@ -136,6 +158,16 @@ sub _apply_all_roles {
     }
 }
 
+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 {
@@ -184,7 +216,7 @@ sub _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
         );
@@ -247,7 +279,7 @@ sub _caller_info {
     my $level = @_ ? ($_[0] + 1) : 2;
     my %info;
     @info{qw(package file line)} = caller($level);
-    return \%info;
+    return %info;
 }
 
 sub _create_alias {
@@ -274,16 +306,178 @@ sub meta_class_alias {
     _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/;
@@ -342,9 +536,14 @@ each of which can be followed by an optional hash reference of options
 
 =item B<ensure_all_roles($applicant, @roles)>
 
-This function is similar to L</apply_all_roles>, but only applies roles that
+This function is similar to C<apply_all_roles>, but only applies roles that
 C<$applicant> does not already consume.
 
+=item B<with_traits($class_name, @role_names)>
+
+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<get_all_attribute_values($meta, $instance)>
 
 Returns a hash reference containing all of the C<$instance>'s
@@ -373,12 +572,6 @@ when specifying the C<metaclass> or C<traits> option for an attribute:
 The name resolution mechanism is covered in
 L<Moose/Metaclass and Trait Name Resolution>.
 
-=item B<english_list(@items)>
-
-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.
-
 =item B<meta_class_alias($to[, $from])>
 
 =item B<meta_attribute_alias($to[, $from])>
@@ -387,6 +580,12 @@ Create an alias from the class C<$from> (or the current package, if
 C<$from> is unspecified), so that
 L<Moose/Metaclass and Trait Name Resolution> works properly.
 
+=item B<english_list(@items)>
+
+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
 
 =head1 TODO
@@ -405,24 +604,5 @@ Here is a list of possible functions to write
 
 See L<Moose/BUGS> for details on reporting bugs.
 
-=head1 AUTHOR
-
-Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
-
-B<with contributions from:>
-
-Robert (phaylon) Sedlacek
-
-Stevan Little
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2007-2009 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
 =cut