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