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