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