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