7 use Scalar::Util 'blessed';
10 our $VERSION = '0.72';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
20 get_all_attribute_values
21 resolve_metatrait_alias
22 resolve_metaclass_alias
27 Sub::Exporter::setup_exporter({
29 groups => { all => \@exports }
32 ## some utils for the utils ...
36 return Class::MOP::get_metaclass_by_name(blessed($_[0]) || $_[0]);
42 my ($class_or_obj, $role) = @_;
44 my $meta = find_meta($class_or_obj);
46 return unless defined $meta;
47 return unless $meta->can('does_role');
48 return 1 if $meta->does_role($role);
52 sub search_class_by_role {
53 my ($class_or_obj, $role_name) = @_;
55 my $meta = find_meta($class_or_obj);
57 return unless defined $meta;
59 foreach my $class ($meta->class_precedence_list) {
61 my $_meta = find_meta($class);
63 next unless defined $_meta;
65 foreach my $role (@{ $_meta->roles || [] }) {
66 return $class if $role->name eq $role_name;
74 my $applicant = shift;
78 Moose->throw_error("Must specify at least one role to apply to $applicant");
81 my $roles = Data::OptList::mkopt( [@_] );
83 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
85 foreach my $role_spec (@$roles) {
86 Class::MOP::load_class( $role_spec->[0] );
89 foreach my $role (@$roles) {
90 unless ( $role->[0]->can('meta')
91 && $role->[0]->meta->isa('Moose::Meta::Role') ) {
94 Moose->throw_error( "You can only consume roles, "
96 . " is not a Moose role" );
100 if ( scalar @$roles == 1 ) {
101 my ( $role, $params ) = @{ $roles->[0] };
102 $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
105 Moose::Meta::Role->combine( @$roles )->apply($meta);
109 # instance deconstruction ...
111 sub get_all_attribute_values {
112 my ($class, $instance) = @_;
114 map { $_->name => $_->get_value($instance) }
115 grep { $_->has_value($instance) }
116 $class->compute_all_applicable_attributes
120 sub get_all_init_args {
121 my ($class, $instance) = @_;
123 map { $_->init_arg => $_->get_value($instance) }
124 grep { $_->has_value($instance) }
125 grep { defined($_->init_arg) }
126 $class->compute_all_applicable_attributes
130 sub resolve_metatrait_alias {
131 return resolve_metaclass_alias( @_, trait => 1 );
137 sub resolve_metaclass_alias {
138 my ( $type, $metaclass_name, %options ) = @_;
140 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
141 return $cache{$cache_key}{$metaclass_name}
142 if $cache{$cache_key}{$metaclass_name};
144 my $possible_full_name
148 . ( $options{trait} ? "Trait::" : "" )
151 my $loaded_class = Class::MOP::load_first_existing_class(
156 return $cache{$cache_key}{$metaclass_name}
157 = $loaded_class->can('register_implementation')
158 ? $loaded_class->register_implementation
163 sub add_method_modifier {
164 my ( $class_or_obj, $modifier_name, $args ) = @_;
165 my $meta = find_meta($class_or_obj);
166 my $code = pop @{$args};
167 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
168 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
169 if ( $method_modifier_type eq 'Regexp' ) {
170 my @all_methods = $meta->get_all_methods;
172 = grep { $_->name =~ @{$args}[0] } @all_methods;
173 $meta->$add_modifier_method( $_->name, $code )
174 for @matched_methods;
178 $meta->$add_modifier_method( $_, $code ) for @{$args};
185 return $items[0] if @items == 1;
186 return "$items[0] and $items[1]" if @items == 2;
188 my $tail = pop @items;
189 my $list = join ', ', @items;
190 $list .= ', and ' . $tail;
203 Moose::Util - Utilities for working with Moose classes
207 use Moose::Util qw/find_meta does_role search_class_by_role/;
209 my $meta = find_meta($object) || die "No metaclass found";
211 if (does_role($object, $role)) {
212 print "The object can do $role!\n";
215 my $class = search_class_by_role($object, 'FooRole');
216 print "Nearest class with 'FooRole' is $class\n";
220 This is a set of utility functions to help working with Moose classes, and
221 is used internally by Moose itself. The goal is to provide useful functions
222 that for both Moose users and Moose extenders (MooseX:: authors).
224 This is a relatively new addition to the Moose tool chest, so ideas,
225 suggestions and contributions to this collection are most welcome.
226 See the L<TODO> section below for a list of ideas for possible functions
229 =head1 EXPORTED FUNCTIONS
233 =item B<find_meta ($class_or_obj)>
235 This will attempt to locate a metaclass for the given C<$class_or_obj>
238 =item B<does_role ($class_or_obj, $role_name)>
240 Returns true if C<$class_or_obj> can do the role C<$role_name>.
242 =item B<search_class_by_role ($class_or_obj, $role_name)>
244 Returns first class in precedence list that consumed C<$role_name>.
246 =item B<apply_all_roles ($applicant, @roles)>
248 Given an C<$applicant> (which can somehow be turned into either a
249 metaclass or a metarole) and a list of C<@roles> this will do the
250 right thing to apply the C<@roles> to the C<$applicant>. This is
251 actually used internally by both L<Moose> and L<Moose::Role>, and the
252 C<@roles> will be preprocessed through L<Data::OptList::mkopt>
253 to allow for the additional arguments to be passed.
255 =item B<get_all_attribute_values($meta, $instance)>
257 Returns the values of the C<$instance>'s fields keyed by the attribute names.
259 =item B<get_all_init_args($meta, $instance)>
261 Returns a hash reference where the keys are all the attributes' C<init_arg>s
262 and the values are the instance's fields. Attributes without an C<init_arg>
265 =item B<resolve_metaclass_alias($category, $name, %options)>
267 =item B<resolve_metatrait_alias($category, $name, %options)>
269 Resolve a short name like in e.g.
275 to a full class name.
277 =item B<add_method_modifier ($class_or_obj, $modifier_name, $args)>
279 =item B<english_list(@items)>
281 Given a list of scalars, turns them into a proper list in English
282 ("one and two", "one, two, three, and four"). This is used to help us
283 make nicer error messages.
289 Here is a list of possible functions to write
293 =item discovering original method from modified method
295 =item search for origin class of a method or attribute
301 All complex software has bugs lurking in it, and this module is no
302 exception. If you find a bug please either email me, or add the bug
307 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
309 B<with contributions from:>
311 Robert (phaylon) Sedlacek
315 =head1 COPYRIGHT AND LICENSE
317 Copyright 2007-2009 by Infinity Interactive, Inc.
319 L<http://www.iinteractive.com>
321 This library is free software; you can redistribute it and/or modify
322 it under the same terms as Perl itself.