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