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