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