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