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