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