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