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