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
 122 1;
 123
 124 __END__
 125
 126 =pod
 127
 128 =head1 NAME
 129
 130 Moose::Util - Utilities for working with Moose classes
 131
 132 =head1 SYNOPSIS
 133
 134   use Moose::Util qw/find_meta does_role search_class_by_role/;
 135
 136   my $meta = find_meta($object) || die "No metaclass found";
 137
 138   if (does_role($object, $role)) {
 139     print "The object can do $role!\n";
 140   }
 141
 142   my $class = search_class_by_role($object, 'FooRole');
 143   print "Nearest class with 'FooRole' is $class\n";
 144
 145 =head1 DESCRIPTION
 146
 147 This is a set of utility functions to help working with Moose classes, and
 148 is used internally by Moose itself. The goal is to provide useful functions
 149 that for both Moose users and Moose extenders (MooseX:: authors).
 150
 151 This is a relatively new addition to the Moose toolchest, so ideas,
 152 suggestions and contributions to this collection are most welcome.
 153 See the L<TODO> section below for a list of ideas for possible functions
 154 to write.
 155
 156 =head1 EXPORTED FUNCTIONS
 157
 158 =over 4
 159
 160 =item B<find_meta ($class_or_obj)>
 161
 162 This will attempt to locate a metaclass for the given C<$class_or_obj>
 163 and return it.
 164
 165 =item B<does_role ($class_or_obj, $role_name)>
 166
 167 Returns true if C<$class_or_obj> can do the role C<$role_name>.
 168
 169 =item B<search_class_by_role ($class_or_obj, $role_name)>
 170
 171 Returns first class in precedence list that consumed C<$role_name>.
 172
 173 =item B<apply_all_roles ($applicant, @roles)>
 174
 175 Given an C<$applicant> (which can somehow be turned into either a
 176 metaclass or a metarole) and a list of C<@roles> this will do the
 177 right thing to apply the C<@roles> to the C<$applicant>. This is
 178 actually used internally by both L<Moose> and L<Moose::Role>, and the
 179 C<@roles> will be pre-processed through L<Data::OptList::mkopt>
 180 to allow for the additional arguments to be passed.
 181
 182 =item B<get_all_attribute_values($meta, $instance)>
 183
 184 Returns the values of the C<$instance>'s fields keyed by the attribute names.
 185
 186 =item B<get_all_init_args($meta, $instance)>
 187
 188 Returns a hash reference where the keys are all the attributes' C<init_arg>s
 189 and the values are the instance's fields. Attributes without an C<init_arg>
 190 will be skipped.
 191
 192 =back
 193
 194 =head1 TODO
 195
 196 Here is a list of possible functions to write
 197
 198 =over 4
 199
 200 =item discovering original method from modified method
 201
 202 =item search for origin class of a method or attribute
 203
 204 =back
 205
 206 =head1 BUGS
 207
 208 All complex software has bugs lurking in it, and this module is no
 209 exception. If you find a bug please either email me, or add the bug
 210 to cpan-RT.
 211
 212 =head1 AUTHOR
 213
 214 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
 215
 216 B<with contributions from:>
 217
 218 Robert (phaylon) Sedlacek
 219
 220 Stevan Little
 221
 222 =head1 COPYRIGHT AND LICENSE
 223
 224 Copyright 2007-2008 by Infinity Interactive, Inc.
 225
 226 L<http://www.iinteractive.com>
 227
 228 This library is free software; you can redistribute it and/or modify
 229 it under the same terms as Perl itself.
 230
 231 =cut
 232