7 use Scalar::Util 'blessed';
10 our $VERSION = '0.72_01';
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 module provides a set of utility functions. Many of these
221 functions are intended for use in Moose itself or MooseX modules, but
222 some of them may be useful for use in your own code.
224 =head1 EXPORTED FUNCTIONS
228 =item B<find_meta($class_or_obj)>
230 This method takes a class name or object and attempts to find a
231 metaclass for the class, if one exists. It will not create one if it
234 =item B<does_role($class_or_obj, $role_name)>
236 Returns true if C<$class_or_obj> does the given C<$role_name>.
238 The class must already have a metaclass for this to work.
240 =item B<search_class_by_role($class_or_obj, $role_name)>
242 Returns the first class in the class's precedence list that does
243 C<$role_name>, if any.
245 The class must already have a metaclass for this to work.
247 =item B<apply_all_roles($applicant, @roles)>
249 This function applies one or more roles to the given C<$applicant> The
250 applicant can be a role name, class name, or object.
252 The C<$applicant> must already have a metaclass object.
254 The list of C<@roles> should be a list of names, each of which can be
255 followed by an optional hash reference of options (C<exclude> and
258 =item B<get_all_attribute_values($meta, $instance)>
260 Returns a hash reference containing all of the C<$instance>'s
261 attributes. The keys are attribute names.
263 =item B<get_all_init_args($meta, $instance)>
265 Returns a hash reference containing all of the C<init_arg> values for
266 the instance's attributes. The values are the associated attribute
267 values. If an attribute does not have a defined C<init_arg>, it is
270 This could be useful in cloning an object.
272 =item B<resolve_metaclass_alias($category, $name, %options)>
274 =item B<resolve_metatrait_alias($category, $name, %options)>
276 Resolves a short name to a full class name. Short names are often used
277 when specifying the C<metaclass> or C<traits> option for an attribute:
283 The name resolution mechanism is covered in L<Moose/Trait Name
286 =item B<english_list(@items)>
288 Given a list of scalars, turns them into a proper list in English
289 ("one and two", "one, two, three, and four"). This is used to help us
290 make nicer error messages.
296 Here is a list of possible functions to write
300 =item discovering original method from modified method
302 =item search for origin class of a method or attribute
308 All complex software has bugs lurking in it, and this module is no
309 exception. If you find a bug please either email me, or add the bug
314 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
316 B<with contributions from:>
318 Robert (phaylon) Sedlacek
322 =head1 COPYRIGHT AND LICENSE
324 Copyright 2007-2009 by Infinity Interactive, Inc.
326 L<http://www.iinteractive.com>
328 This library is free software; you can redistribute it and/or modify
329 it under the same terms as Perl itself.