Remove references to
[gitmo/Moose.git] / lib / Moose / Util.pm
CommitLineData
9a641848 1package Moose::Util;
2
9a641848 3use strict;
4use warnings;
5
7125b244 6use Sub::Exporter;
d7d8a8c7 7use Scalar::Util 'blessed';
8use Carp 'confess';
1b2aea39 9use Class::MOP 0.56;
9a641848 10
a7e9b05b 11our $VERSION = '0.55_04';
75b95414 12$VERSION = eval $VERSION;
7125b244 13our $AUTHORITY = 'cpan:STEVAN';
9a641848 14
7125b244 15my @exports = qw[
6532ca5a 16 find_meta
17 does_role
7125b244 18 search_class_by_role
d7d8a8c7 19 apply_all_roles
ab76842e 20 get_all_init_args
21 get_all_attribute_values
a5e883ae 22 resolve_metatrait_alias
23 resolve_metaclass_alias
5f71050b 24 add_method_modifier
7125b244 25];
9a641848 26
7125b244 27Sub::Exporter::setup_exporter({
28 exports => \@exports,
11065d1f 29 groups => { all => \@exports }
7125b244 30});
31
32## some utils for the utils ...
33
6532ca5a 34sub find_meta {
7125b244 35 return unless $_[0];
d7d8a8c7 36 return Class::MOP::get_metaclass_by_name(blessed($_[0]) || $_[0]);
7125b244 37}
9a641848 38
7125b244 39## the functions ...
adf82331 40
7125b244 41sub does_role {
42 my ($class_or_obj, $role) = @_;
adf82331 43
6532ca5a 44 my $meta = find_meta($class_or_obj);
7125b244 45
46 return unless defined $meta;
10a745f5 47 return unless $meta->can('does_role');
7125b244 48 return 1 if $meta->does_role($role);
49 return;
9a641848 50}
51
1631b53f 52sub search_class_by_role {
7125b244 53 my ($class_or_obj, $role_name) = @_;
54
6532ca5a 55 my $meta = find_meta($class_or_obj);
7125b244 56
57 return unless defined $meta;
58
59 foreach my $class ($meta->class_precedence_list) {
60
6532ca5a 61 my $_meta = find_meta($class);
1631b53f 62
7125b244 63 next unless defined $_meta;
64
65 foreach my $role (@{ $_meta->roles || [] }) {
1631b53f 66 return $class if $role->name eq $role_name;
67 }
68 }
69
7125b244 70 return;
1631b53f 71}
72
d7d8a8c7 73sub apply_all_roles {
74 my $applicant = shift;
5b5187e0 75
72d15b83 76 confess "Must specify at least one role to apply to $applicant" unless @_;
5b5187e0 77
72d15b83 78 my $roles = Data::OptList::mkopt( [@_] );
5b5187e0 79
80 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
81
9c10b5ad 82 foreach my $role_spec (@$roles) {
5b5187e0 83 Class::MOP::load_class( $role_spec->[0] );
9c10b5ad 84 }
d7d8a8c7 85
5b5187e0 86 ( $_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role') )
87 || confess "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] };
72d15b83 94 $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
d7d8a8c7 95 }
96 else {
72d15b83 97 Moose::Meta::Role->combine( @$roles )->apply($meta);
5b5187e0 98 }
d7d8a8c7 99}
100
ab76842e 101# instance deconstruction ...
102
103sub 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
112sub 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
a3738e5b 122sub resolve_metatrait_alias {
123 resolve_metaclass_alias( @_, trait => 1 );
124}
125
126sub resolve_metaclass_alias {
127 my ( $type, $metaclass_name, %options ) = @_;
128
129 if ( my $resolved = eval {
130 my $possible_full_name = 'Moose::Meta::' . $type . '::Custom::' . ( $options{trait} ? "Trait::" : "" ) . $metaclass_name;
131
132 Class::MOP::load_class($possible_full_name);
133
134 $possible_full_name->can('register_implementation')
135 ? $possible_full_name->register_implementation
136 : $possible_full_name;
137 } ) {
138 return $resolved;
139 } else {
140 Class::MOP::load_class($metaclass_name);
141 return $metaclass_name;
142 }
143}
144
5f71050b 145sub add_method_modifier {
146 my ( $class_or_obj, $modifier_name, $args ) = @_;
147 my $meta = find_meta($class_or_obj);
148 my $code = pop @{$args};
149 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
150 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
151 if ( $method_modifier_type eq 'Regexp' ) {
3b82ee4f 152 my @all_methods = $meta->get_all_methods;
5f71050b 153 my @matched_methods
3b82ee4f 154 = grep { $_->name =~ @{$args}[0] } @all_methods;
155 $meta->$add_modifier_method( $_->name, $code )
5f71050b 156 for @matched_methods;
157 }
158 }
159 else {
160 $meta->$add_modifier_method( $_, $code ) for @{$args};
161 }
162}
d9bb6c63 163
9a641848 1641;
165
166__END__
167
168=pod
169
170=head1 NAME
171
7125b244 172Moose::Util - Utilities for working with Moose classes
9a641848 173
174=head1 SYNOPSIS
175
6532ca5a 176 use Moose::Util qw/find_meta does_role search_class_by_role/;
177
178 my $meta = find_meta($object) || die "No metaclass found";
9a641848 179
adf82331 180 if (does_role($object, $role)) {
181 print "The object can do $role!\n";
9a641848 182 }
183
1631b53f 184 my $class = search_class_by_role($object, 'FooRole');
185 print "Nearest class with 'FooRole' is $class\n";
186
7125b244 187=head1 DESCRIPTION
188
004222dc 189This is a set of utility functions to help working with Moose classes, and
190is used internally by Moose itself. The goal is to provide useful functions
191that for both Moose users and Moose extenders (MooseX:: authors).
192
193This is a relatively new addition to the Moose toolchest, so ideas,
194suggestions and contributions to this collection are most welcome.
195See the L<TODO> section below for a list of ideas for possible functions
196to write.
7125b244 197
198=head1 EXPORTED FUNCTIONS
9a641848 199
200=over 4
201
6532ca5a 202=item B<find_meta ($class_or_obj)>
203
204This will attempt to locate a metaclass for the given C<$class_or_obj>
205and return it.
206
7125b244 207=item B<does_role ($class_or_obj, $role_name)>
208
209Returns true if C<$class_or_obj> can do the role C<$role_name>.
210
211=item B<search_class_by_role ($class_or_obj, $role_name)>
212
213Returns first class in precedence list that consumed C<$role_name>.
214
d7d8a8c7 215=item B<apply_all_roles ($applicant, @roles)>
216
217Given an C<$applicant> (which can somehow be turned into either a
218metaclass or a metarole) and a list of C<@roles> this will do the
219right thing to apply the C<@roles> to the C<$applicant>. This is
3bb22459 220actually used internally by both L<Moose> and L<Moose::Role>, and the
221C<@roles> will be pre-processed through L<Data::OptList::mkopt>
222to allow for the additional arguments to be passed.
d7d8a8c7 223
ab76842e 224=item B<get_all_attribute_values($meta, $instance)>
225
226Returns the values of the C<$instance>'s fields keyed by the attribute names.
227
228=item B<get_all_init_args($meta, $instance)>
229
230Returns a hash reference where the keys are all the attributes' C<init_arg>s
231and the values are the instance's fields. Attributes without an C<init_arg>
232will be skipped.
233
a3738e5b 234=item B<resolve_metaclass_alias($category, $name, %options)>
235
236=item B<resolve_metatrait_alias($category, $name, %options)>
237
238Resolve a short name like in e.g.
239
240 has foo => (
241 metaclass => "Bar",
242 );
243
244to a full class name.
245
5f71050b 246=item B<add_method_modifier ($class_or_obj, $modifier_name, $args)>
247
7125b244 248=back
9a641848 249
7125b244 250=head1 TODO
9a641848 251
7125b244 252Here is a list of possible functions to write
9a641848 253
7125b244 254=over 4
1631b53f 255
7125b244 256=item discovering original method from modified method
1631b53f 257
7125b244 258=item search for origin class of a method or attribute
1631b53f 259
9a641848 260=back
261
262=head1 BUGS
263
264All complex software has bugs lurking in it, and this module is no
265exception. If you find a bug please either email me, or add the bug
266to cpan-RT.
267
268=head1 AUTHOR
269
270Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
271
7125b244 272B<with contributions from:>
273
274Robert (phaylon) Sedlacek
275
276Stevan Little
277
9a641848 278=head1 COPYRIGHT AND LICENSE
279
778db3ac 280Copyright 2007-2008 by Infinity Interactive, Inc.
9a641848 281
282L<http://www.iinteractive.com>
283
284This library is free software; you can redistribute it and/or modify
285it under the same terms as Perl itself.
286
287=cut
288