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 Class::MOP   0.60;
   9
  10 our $VERSION   = '0.74';
  11 $VERSION = eval $VERSION;
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 my @exports = qw[
  15     find_meta
  16     does_role
  17     search_class_by_role
  18     ensure_all_roles
  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     english_list
  26 ];
  27
  28 Sub::Exporter::setup_exporter({
  29     exports => \@exports,
  30     groups  => { all => \@exports }
  31 });
  32
  33 ## some utils for the utils ...
  34
  35 sub find_meta { Class::MOP::class_of(@_) }
  36
  37 ## the functions ...
  38
  39 sub does_role {
  40     my ($class_or_obj, $role) = @_;
  41
  42     my $meta = find_meta($class_or_obj);
  43
  44     return unless defined $meta;
  45     return unless $meta->can('does_role');
  46     return 1 if $meta->does_role($role);
  47     return;
  48 }
  49
  50 sub search_class_by_role {
  51     my ($class_or_obj, $role_name) = @_;
  52
  53     my $meta = find_meta($class_or_obj);
  54
  55     return unless defined $meta;
  56
  57     foreach my $class ($meta->class_precedence_list) {
  58
  59         my $_meta = find_meta($class);
  60
  61         next unless defined $_meta;
  62
  63         foreach my $role (@{ $_meta->roles || [] }) {
  64             return $class if $role->name eq $role_name;
  65         }
  66     }
  67
  68     return;
  69 }
  70
  71 # this can possibly behave in unexpected ways because the roles being composed
  72 # before being applied could differ from call to call; I'm not sure if or how
  73 # to document this possible quirk.
  74 sub ensure_all_roles {
  75     my $applicant = shift;
  76     _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
  77 }
  78
  79 sub apply_all_roles {
  80     my $applicant = shift;
  81     _apply_all_roles($applicant, sub { 1 }, @_);
  82 }
  83
  84 sub _apply_all_roles {
  85     my $applicant = shift;
  86     my $role_filter = shift;
  87
  88     unless (@_) {
  89         require Moose;
  90         Moose->throw_error("Must specify at least one role to apply to $applicant");
  91     }
  92
  93     my $roles = Data::OptList::mkopt( [@_] );
  94
  95     foreach my $role (@$roles) {
  96         my $meta = Class::MOP::load_class( $role->[0] );
  97
  98         unless ($meta->isa('Moose::Meta::Role') ) {
  99             require Moose;
 100             Moose->throw_error( "You can only consume roles, "
 101                     . $role->[0]
 102                     . " is not a Moose role" );
 103         }
 104     }
 105
 106     @$roles = grep { local $_ = $_->[0]; $role_filter->() } @$roles;
 107
 108     return unless @$roles;
 109
 110     my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
 111
 112     if ( scalar @$roles == 1 ) {
 113         my ( $role, $params ) = @{ $roles->[0] };
 114         my $role_meta = Class::MOP::class_of($role);
 115         $role_meta->apply( $meta, ( defined $params ? %$params : () ) );
 116     }
 117     else {
 118         Moose::Meta::Role->combine( @$roles )->apply($meta);
 119     }
 120 }
 121
 122 # instance deconstruction ...
 123
 124 sub get_all_attribute_values {
 125     my ($class, $instance) = @_;
 126     return +{
 127         map { $_->name => $_->get_value($instance) }
 128             grep { $_->has_value($instance) }
 129                 $class->get_all_attributes
 130     };
 131 }
 132
 133 sub get_all_init_args {
 134     my ($class, $instance) = @_;
 135     return +{
 136         map { $_->init_arg => $_->get_value($instance) }
 137             grep { $_->has_value($instance) }
 138                 grep { defined($_->init_arg) }
 139                     $class->get_all_attributes
 140     };
 141 }
 142
 143 sub resolve_metatrait_alias {
 144     return resolve_metaclass_alias( @_, trait => 1 );
 145 }
 146
 147 {
 148     my %cache;
 149
 150     sub resolve_metaclass_alias {
 151         my ( $type, $metaclass_name, %options ) = @_;
 152
 153         my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
 154         return $cache{$cache_key}{$metaclass_name}
 155             if $cache{$cache_key}{$metaclass_name};
 156
 157         my $possible_full_name
 158             = 'Moose::Meta::'
 159             . $type
 160             . '::Custom::'
 161             . ( $options{trait} ? "Trait::" : "" )
 162             . $metaclass_name;
 163
 164         my $loaded_class = Class::MOP::load_first_existing_class(
 165             $possible_full_name,
 166             $metaclass_name
 167         );
 168
 169         return $cache{$cache_key}{$metaclass_name}
 170             = $loaded_class->can('register_implementation')
 171             ? $loaded_class->register_implementation
 172             : $loaded_class;
 173     }
 174 }
 175
 176 sub add_method_modifier {
 177     my ( $class_or_obj, $modifier_name, $args ) = @_;
 178     my $meta                = find_meta($class_or_obj);
 179     my $code                = pop @{$args};
 180     my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
 181     if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
 182         if ( $method_modifier_type eq 'Regexp' ) {
 183             my @all_methods = $meta->get_all_methods;
 184             my @matched_methods
 185                 = grep { $_->name =~ @{$args}[0] } @all_methods;
 186             $meta->$add_modifier_method( $_->name, $code )
 187                 for @matched_methods;
 188         }
 189     }
 190     else {
 191         $meta->$add_modifier_method( $_, $code ) for @{$args};
 192     }
 193 }
 194
 195 sub english_list {
 196     my @items = sort @_;
 197
 198     return $items[0] if @items == 1;
 199     return "$items[0] and $items[1]" if @items == 2;
 200
 201     my $tail = pop @items;
 202     my $list = join ', ', @items;
 203     $list .= ', and ' . $tail;
 204
 205     return $list;
 206 }
 207
 208 1;
 209
 210 __END__
 211
 212 =pod
 213
 214 =head1 NAME
 215
 216 Moose::Util - Utilities for working with Moose classes
 217
 218 =head1 SYNOPSIS
 219
 220   use Moose::Util qw/find_meta does_role search_class_by_role/;
 221
 222   my $meta = find_meta($object) || die "No metaclass found";
 223
 224   if (does_role($object, $role)) {
 225     print "The object can do $role!\n";
 226   }
 227
 228   my $class = search_class_by_role($object, 'FooRole');
 229   print "Nearest class with 'FooRole' is $class\n";
 230
 231 =head1 DESCRIPTION
 232
 233 This module provides a set of utility functions. Many of these
 234 functions are intended for use in Moose itself or MooseX modules, but
 235 some of them may be useful for use in your own code.
 236
 237 =head1 EXPORTED FUNCTIONS
 238
 239 =over 4
 240
 241 =item B<find_meta($class_or_obj)>
 242
 243 This method takes a class name or object and attempts to find a
 244 metaclass for the class, if one exists. It will not create one if it
 245 does not yet exist.
 246
 247 =item B<does_role($class_or_obj, $role_name)>
 248
 249 Returns true if C<$class_or_obj> does the given C<$role_name>.
 250
 251 The class must already have a metaclass for this to work.
 252
 253 =item B<search_class_by_role($class_or_obj, $role_name)>
 254
 255 Returns the first class in the class's precedence list that does
 256 C<$role_name>, if any.
 257
 258 The class must already have a metaclass for this to work.
 259
 260 =item B<apply_all_roles($applicant, @roles)>
 261
 262 This function applies one or more roles to the given C<$applicant> The
 263 applicant can be a role name, class name, or object.
 264
 265 The C<$applicant> must already have a metaclass object.
 266
 267 The list of C<@roles> should be a list of names, each of which can be
 268 followed by an optional hash reference of options (C<exclude> and
 269 C<alias>).
 270
 271 =item B<ensure_all_roles($applicant, @roles)>
 272
 273 This function is similar to L</apply_all_roles>, but only applies roles that
 274 C<$applicant> does not already consume.
 275
 276 =item B<get_all_attribute_values($meta, $instance)>
 277
 278 Returns a hash reference containing all of the C<$instance>'s
 279 attributes. The keys are attribute names.
 280
 281 =item B<get_all_init_args($meta, $instance)>
 282
 283 Returns a hash reference containing all of the C<init_arg> values for
 284 the instance's attributes. The values are the associated attribute
 285 values. If an attribute does not have a defined C<init_arg>, it is
 286 skipped.
 287
 288 This could be useful in cloning an object.
 289
 290 =item B<resolve_metaclass_alias($category, $name, %options)>
 291
 292 =item B<resolve_metatrait_alias($category, $name, %options)>
 293
 294 Resolves a short name to a full class name. Short names are often used
 295 when specifying the C<metaclass> or C<traits> option for an attribute:
 296
 297     has foo => (
 298         metaclass => "Bar",
 299     );
 300
 301 The name resolution mechanism is covered in L<Moose/Trait Name
 302 Resolution>.
 303
 304 =item B<english_list(@items)>
 305
 306 Given a list of scalars, turns them into a proper list in English
 307 ("one and two", "one, two, three, and four"). This is used to help us
 308 make nicer error messages.
 309
 310 =back
 311
 312 =head1 TODO
 313
 314 Here is a list of possible functions to write
 315
 316 =over 4
 317
 318 =item discovering original method from modified method
 319
 320 =item search for origin class of a method or attribute
 321
 322 =back
 323
 324 =head1 BUGS
 325
 326 All complex software has bugs lurking in it, and this module is no
 327 exception. If you find a bug please either email me, or add the bug
 328 to cpan-RT.
 329
 330 =head1 AUTHOR
 331
 332 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
 333
 334 B<with contributions from:>
 335
 336 Robert (phaylon) Sedlacek
 337
 338 Stevan Little
 339
 340 =head1 COPYRIGHT AND LICENSE
 341
 342 Copyright 2007-2009 by Infinity Interactive, Inc.
 343
 344 L<http://www.iinteractive.com>
 345
 346 This library is free software; you can redistribute it and/or modify
 347 it under the same terms as Perl itself.
 348
 349 =cut
 350