lib/Moose/Util.pm

   1 package Moose::Util;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Sub::Exporter;
   7 use Scalar::Util 'blessed';
   8 use Carp         'confess';
   9 use Class::MOP   0.56;
  10
  11 our $VERSION   = '0.56';
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 my @exports = qw[
  15     find_meta
  16     does_role
  17     search_class_by_role
  18     apply_all_roles
  19     get_all_init_args
  20     get_all_attribute_values
  21     resolve_metatrait_alias
  22     resolve_metaclass_alias
  23     add_method_modifier
  24 ];
  25
  26 Sub::Exporter::setup_exporter({
  27     exports => \@exports,
  28     groups  => { all => \@exports }
  29 });
  30
  31 ## some utils for the utils ...
  32
  33 sub find_meta {
  34     return unless $_[0];
  35     return Class::MOP::get_metaclass_by_name(blessed($_[0]) || $_[0]);
  36 }
  37
  38 ## the functions ...
  39
  40 sub does_role {
  41     my ($class_or_obj, $role) = @_;
  42
  43     my $meta = find_meta($class_or_obj);
  44
  45     return unless defined $meta;
  46     return unless $meta->can('does_role');
  47     return 1 if $meta->does_role($role);
  48     return;
  49 }
  50
  51 sub search_class_by_role {
  52     my ($class_or_obj, $role_name) = @_;
  53
  54     my $meta = find_meta($class_or_obj);
  55
  56     return unless defined $meta;
  57
  58     foreach my $class ($meta->class_precedence_list) {
  59
  60         my $_meta = find_meta($class);
  61
  62         next unless defined $_meta;
  63
  64         foreach my $role (@{ $_meta->roles || [] }) {
  65             return $class if $role->name eq $role_name;
  66         }
  67     }
  68
  69     return;
  70 }
  71
  72 sub apply_all_roles {
  73     my $applicant = shift;
  74
  75     apply_all_roles_with_method( $applicant, 'apply', [@_] );
  76 }
  77
  78 sub apply_all_roles_with_method {
  79     my ( $applicant, $apply_method, $role_list ) = @_;
  80
  81     confess "Must specify at least one role to apply to $applicant"
  82         unless @$role_list;
  83
  84     my $roles = Data::OptList::mkopt($role_list);
  85
  86     my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
  87
  88     foreach my $role_spec (@$roles) {
  89         Class::MOP::load_class( $role_spec->[0] );
  90     }
  91
  92     ( $_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role') )
  93         || confess "You can only consume roles, "
  94         . $_->[0]
  95         . " is not a Moose role"
  96         foreach @$roles;
  97
  98     if ( scalar @$roles == 1 ) {
  99         my ( $role, $params ) = @{ $roles->[0] };
 100         $role->meta->$apply_method( $meta,
 101             ( defined $params ? %$params : () ) );
 102     }
 103     else {
 104         Moose::Meta::Role->combine( @$roles )->$apply_method($meta);
 105     }
 106 }
 107
 108 # instance deconstruction ...
 109
 110 sub get_all_attribute_values {
 111     my ($class, $instance) = @_;
 112     return +{
 113         map { $_->name => $_->get_value($instance) }
 114             grep { $_->has_value($instance) }
 115                 $class->compute_all_applicable_attributes
 116     };
 117 }
 118
 119 sub get_all_init_args {
 120     my ($class, $instance) = @_;
 121     return +{
 122         map { $_->init_arg => $_->get_value($instance) }
 123             grep { $_->has_value($instance) }
 124                 grep { defined($_->init_arg) }
 125                     $class->compute_all_applicable_attributes
 126     };
 127 }
 128
 129 sub resolve_metatrait_alias {
 130     resolve_metaclass_alias( @_, trait => 1 );
 131 }
 132
 133 sub resolve_metaclass_alias {
 134     my ( $type, $metaclass_name, %options ) = @_;
 135
 136     if ( my $resolved = eval {
 137         my $possible_full_name = 'Moose::Meta::' . $type . '::Custom::' . ( $options{trait} ? "Trait::" : "" ) . $metaclass_name;
 138
 139         Class::MOP::load_class($possible_full_name);
 140
 141         $possible_full_name->can('register_implementation')
 142             ? $possible_full_name->register_implementation
 143             : $possible_full_name;
 144     } ) {
 145         return $resolved;
 146     } else {
 147         Class::MOP::load_class($metaclass_name);
 148         return $metaclass_name;
 149     }
 150 }
 151
 152 sub add_method_modifier {
 153     my ( $class_or_obj, $modifier_name, $args ) = @_;
 154     my $meta                = find_meta($class_or_obj);
 155     my $code                = pop @{$args};
 156     my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
 157     if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
 158         if ( $method_modifier_type eq 'Regexp' ) {
 159             my @all_methods = $meta->get_all_methods;
 160             my @matched_methods
 161                 = grep { $_->name =~ @{$args}[0] } @all_methods;
 162             $meta->$add_modifier_method( $_->name, $code )
 163                 for @matched_methods;
 164         }
 165     }
 166     else {
 167         $meta->$add_modifier_method( $_, $code ) for @{$args};
 168     }
 169 }
 170
 171 1;
 172
 173 __END__
 174
 175 =pod
 176
 177 =head1 NAME
 178
 179 Moose::Util - Utilities for working with Moose classes
 180
 181 =head1 SYNOPSIS
 182
 183   use Moose::Util qw/find_meta does_role search_class_by_role/;
 184
 185   my $meta = find_meta($object) || die "No metaclass found";
 186
 187   if (does_role($object, $role)) {
 188     print "The object can do $role!\n";
 189   }
 190
 191   my $class = search_class_by_role($object, 'FooRole');
 192   print "Nearest class with 'FooRole' is $class\n";
 193
 194 =head1 DESCRIPTION
 195
 196 This is a set of utility functions to help working with Moose classes, and
 197 is used internally by Moose itself. The goal is to provide useful functions
 198 that for both Moose users and Moose extenders (MooseX:: authors).
 199
 200 This is a relatively new addition to the Moose toolchest, so ideas,
 201 suggestions and contributions to this collection are most welcome.
 202 See the L<TODO> section below for a list of ideas for possible functions
 203 to write.
 204
 205 =head1 EXPORTED FUNCTIONS
 206
 207 =over 4
 208
 209 =item B<find_meta ($class_or_obj)>
 210
 211 This will attempt to locate a metaclass for the given C<$class_or_obj>
 212 and return it.
 213
 214 =item B<does_role ($class_or_obj, $role_name)>
 215
 216 Returns true if C<$class_or_obj> can do the role C<$role_name>.
 217
 218 =item B<search_class_by_role ($class_or_obj, $role_name)>
 219
 220 Returns first class in precedence list that consumed C<$role_name>.
 221
 222 =item B<apply_all_roles ($applicant, @roles)>
 223
 224 Given an C<$applicant> (which can somehow be turned into either a
 225 metaclass or a metarole) and a list of C<@roles> this will do the
 226 right thing to apply the C<@roles> to the C<$applicant>. This is
 227 actually used internally by both L<Moose> and L<Moose::Role>, and the
 228 C<@roles> will be pre-processed through L<Data::OptList::mkopt>
 229 to allow for the additional arguments to be passed.
 230
 231 =item B<apply_all_roles_with_method ($applicant, $method, @roles)>
 232
 233 This function works just like C<apply_all_roles()>, except it allows
 234 you to specify what method will be called on the role metaclass when
 235 applying it to the C<$applicant>. This exists primarily so one can use
 236 the C<< Moose::Meta::Role->apply_to_metaclass_instance() >> method.
 237
 238 =item B<get_all_attribute_values($meta, $instance)>
 239
 240 Returns the values of the C<$instance>'s fields keyed by the attribute names.
 241
 242 =item B<get_all_init_args($meta, $instance)>
 243
 244 Returns a hash reference where the keys are all the attributes' C<init_arg>s
 245 and the values are the instance's fields. Attributes without an C<init_arg>
 246 will be skipped.
 247
 248 =item B<resolve_metaclass_alias($category, $name, %options)>
 249
 250 =item B<resolve_metatrait_alias($category, $name, %options)>
 251
 252 Resolve a short name like in e.g.
 253
 254     has foo => (
 255         metaclass => "Bar",
 256     );
 257
 258 to a full class name.
 259
 260 =item B<add_method_modifier ($class_or_obj, $modifier_name, $args)>
 261
 262 =back
 263
 264 =head1 TODO
 265
 266 Here is a list of possible functions to write
 267
 268 =over 4
 269
 270 =item discovering original method from modified method
 271
 272 =item search for origin class of a method or attribute
 273
 274 =back
 275
 276 =head1 BUGS
 277
 278 All complex software has bugs lurking in it, and this module is no
 279 exception. If you find a bug please either email me, or add the bug
 280 to cpan-RT.
 281
 282 =head1 AUTHOR
 283
 284 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
 285
 286 B<with contributions from:>
 287
 288 Robert (phaylon) Sedlacek
 289
 290 Stevan Little
 291
 292 =head1 COPYRIGHT AND LICENSE
 293
 294 Copyright 2007-2008 by Infinity Interactive, Inc.
 295
 296 L<http://www.iinteractive.com>
 297
 298 This library is free software; you can redistribute it and/or modify
 299 it under the same terms as Perl itself.
 300
 301 =cut
 302