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