lib/Moose/Util.pm

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