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