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.87';
  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 sub _caller_info {
 211     my $level = @_ ? ($_[0] + 1) : 2;
 212     my %info;
 213     @info{qw(package file line)} = caller($level);
 214     return \%info;
 215 }
 216
 217 1;
 218
 219 __END__
 220
 221 =pod
 222
 223 =head1 NAME
 224
 225 Moose::Util - Utilities for working with Moose classes
 226
 227 =head1 SYNOPSIS
 228
 229   use Moose::Util qw/find_meta does_role search_class_by_role/;
 230
 231   my $meta = find_meta($object) || die "No metaclass found";
 232
 233   if (does_role($object, $role)) {
 234     print "The object can do $role!\n";
 235   }
 236
 237   my $class = search_class_by_role($object, 'FooRole');
 238   print "Nearest class with 'FooRole' is $class\n";
 239
 240 =head1 DESCRIPTION
 241
 242 This module provides a set of utility functions. Many of these
 243 functions are intended for use in Moose itself or MooseX modules, but
 244 some of them may be useful for use in your own code.
 245
 246 =head1 EXPORTED FUNCTIONS
 247
 248 =over 4
 249
 250 =item B<find_meta($class_or_obj)>
 251
 252 This method takes a class name or object and attempts to find a
 253 metaclass for the class, if one exists. It will B<not> create one if it
 254 does not yet exist.
 255
 256 =item B<does_role($class_or_obj, $role_name)>
 257
 258 Returns true if C<$class_or_obj> does the given C<$role_name>.
 259
 260 The class must already have a metaclass for this to work.
 261
 262 =item B<search_class_by_role($class_or_obj, $role_name)>
 263
 264 Returns the first class in the class's precedence list that does
 265 C<$role_name>, if any.
 266
 267 The class must already have a metaclass for this to work.
 268
 269 =item B<apply_all_roles($applicant, @roles)>
 270
 271 This function applies one or more roles to the given C<$applicant> The
 272 applicant can be a role name, class name, or object.
 273
 274 The C<$applicant> must already have a metaclass object.
 275
 276 The list of C<@roles> should be a list of names, each of which can be
 277 followed by an optional hash reference of options (C<exclude> and
 278 C<alias>).
 279
 280 =item B<ensure_all_roles($applicant, @roles)>
 281
 282 This function is similar to L</apply_all_roles>, but only applies roles that
 283 C<$applicant> does not already consume.
 284
 285 =item B<get_all_attribute_values($meta, $instance)>
 286
 287 Returns a hash reference containing all of the C<$instance>'s
 288 attributes. The keys are attribute names.
 289
 290 =item B<get_all_init_args($meta, $instance)>
 291
 292 Returns a hash reference containing all of the C<init_arg> values for
 293 the instance's attributes. The values are the associated attribute
 294 values. If an attribute does not have a defined C<init_arg>, it is
 295 skipped.
 296
 297 This could be useful in cloning an object.
 298
 299 =item B<resolve_metaclass_alias($category, $name, %options)>
 300
 301 =item B<resolve_metatrait_alias($category, $name, %options)>
 302
 303 Resolves a short name to a full class name. Short names are often used
 304 when specifying the C<metaclass> or C<traits> option for an attribute:
 305
 306     has foo => (
 307         metaclass => "Bar",
 308     );
 309
 310 The name resolution mechanism is covered in L<Moose/Trait Name
 311 Resolution>.
 312
 313 =item B<english_list(@items)>
 314
 315 Given a list of scalars, turns them into a proper list in English
 316 ("one and two", "one, two, three, and four"). This is used to help us
 317 make nicer error messages.
 318
 319 =back
 320
 321 =head1 TODO
 322
 323 Here is a list of possible functions to write
 324
 325 =over 4
 326
 327 =item discovering original method from modified method
 328
 329 =item search for origin class of a method or attribute
 330
 331 =back
 332
 333 =head1 BUGS
 334
 335 All complex software has bugs lurking in it, and this module is no
 336 exception. If you find a bug please either email me, or add the bug
 337 to cpan-RT.
 338
 339 =head1 AUTHOR
 340
 341 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
 342
 343 B<with contributions from:>
 344
 345 Robert (phaylon) Sedlacek
 346
 347 Stevan Little
 348
 349 =head1 COPYRIGHT AND LICENSE
 350
 351 Copyright 2007-2009 by Infinity Interactive, Inc.
 352
 353 L<http://www.iinteractive.com>
 354
 355 This library is free software; you can redistribute it and/or modify
 356 it under the same terms as Perl itself.
 357
 358 =cut
 359