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