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