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