7 use Scalar::Util 'blessed';
10 our $VERSION = '0.73';
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 ...
34 sub find_meta { Class::MOP::class_of(@_) }
39 my ($class_or_obj, $role) = @_;
41 my $meta = find_meta($class_or_obj);
43 return unless defined $meta;
44 return unless $meta->can('does_role');
45 return 1 if $meta->does_role($role);
49 sub search_class_by_role {
50 my ($class_or_obj, $role_name) = @_;
52 my $meta = find_meta($class_or_obj);
54 return unless defined $meta;
56 foreach my $class ($meta->class_precedence_list) {
58 my $_meta = find_meta($class);
60 next unless defined $_meta;
62 foreach my $role (@{ $_meta->roles || [] }) {
63 return $class if $role->name eq $role_name;
71 my $applicant = shift;
75 Moose->throw_error("Must specify at least one role to apply to $applicant");
78 my $roles = Data::OptList::mkopt( [@_] );
80 foreach my $role (@$roles) {
81 my $meta = Class::MOP::load_class( $role->[0] );
83 unless ($meta->isa('Moose::Meta::Role') ) {
85 Moose->throw_error( "You can only consume roles, "
87 . " is not a Moose role" );
91 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
93 if ( scalar @$roles == 1 ) {
94 my ( $role, $params ) = @{ $roles->[0] };
95 my $role_meta = Class::MOP::class_of($role);
96 $role_meta->apply( $meta, ( defined $params ? %$params : () ) );
99 Moose::Meta::Role->combine( @$roles )->apply($meta);
103 # instance deconstruction ...
105 sub get_all_attribute_values {
106 my ($class, $instance) = @_;
108 map { $_->name => $_->get_value($instance) }
109 grep { $_->has_value($instance) }
110 $class->compute_all_applicable_attributes
114 sub get_all_init_args {
115 my ($class, $instance) = @_;
117 map { $_->init_arg => $_->get_value($instance) }
118 grep { $_->has_value($instance) }
119 grep { defined($_->init_arg) }
120 $class->compute_all_applicable_attributes
124 sub resolve_metatrait_alias {
125 return resolve_metaclass_alias( @_, trait => 1 );
131 sub resolve_metaclass_alias {
132 my ( $type, $metaclass_name, %options ) = @_;
134 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
135 return $cache{$cache_key}{$metaclass_name}
136 if $cache{$cache_key}{$metaclass_name};
138 my $possible_full_name
142 . ( $options{trait} ? "Trait::" : "" )
145 my $loaded_class = Class::MOP::load_first_existing_class(
150 return $cache{$cache_key}{$metaclass_name}
151 = $loaded_class->can('register_implementation')
152 ? $loaded_class->register_implementation
157 sub add_method_modifier {
158 my ( $class_or_obj, $modifier_name, $args ) = @_;
159 my $meta = find_meta($class_or_obj);
160 my $code = pop @{$args};
161 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
162 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
163 if ( $method_modifier_type eq 'Regexp' ) {
164 my @all_methods = $meta->get_all_methods;
166 = grep { $_->name =~ @{$args}[0] } @all_methods;
167 $meta->$add_modifier_method( $_->name, $code )
168 for @matched_methods;
172 $meta->$add_modifier_method( $_, $code ) for @{$args};
179 return $items[0] if @items == 1;
180 return "$items[0] and $items[1]" if @items == 2;
182 my $tail = pop @items;
183 my $list = join ', ', @items;
184 $list .= ', and ' . $tail;
197 Moose::Util - Utilities for working with Moose classes
201 use Moose::Util qw/find_meta does_role search_class_by_role/;
203 my $meta = find_meta($object) || die "No metaclass found";
205 if (does_role($object, $role)) {
206 print "The object can do $role!\n";
209 my $class = search_class_by_role($object, 'FooRole');
210 print "Nearest class with 'FooRole' is $class\n";
214 This module provides a set of utility functions. Many of these
215 functions are intended for use in Moose itself or MooseX modules, but
216 some of them may be useful for use in your own code.
218 =head1 EXPORTED FUNCTIONS
222 =item B<find_meta($class_or_obj)>
224 This method takes a class name or object and attempts to find a
225 metaclass for the class, if one exists. It will not create one if it
228 =item B<does_role($class_or_obj, $role_name)>
230 Returns true if C<$class_or_obj> does the given C<$role_name>.
232 The class must already have a metaclass for this to work.
234 =item B<search_class_by_role($class_or_obj, $role_name)>
236 Returns the first class in the class's precedence list that does
237 C<$role_name>, if any.
239 The class must already have a metaclass for this to work.
241 =item B<apply_all_roles($applicant, @roles)>
243 This function applies one or more roles to the given C<$applicant> The
244 applicant can be a role name, class name, or object.
246 The C<$applicant> must already have a metaclass object.
248 The list of C<@roles> should be a list of names, each of which can be
249 followed by an optional hash reference of options (C<exclude> and
252 =item B<get_all_attribute_values($meta, $instance)>
254 Returns a hash reference containing all of the C<$instance>'s
255 attributes. The keys are attribute names.
257 =item B<get_all_init_args($meta, $instance)>
259 Returns a hash reference containing all of the C<init_arg> values for
260 the instance's attributes. The values are the associated attribute
261 values. If an attribute does not have a defined C<init_arg>, it is
264 This could be useful in cloning an object.
266 =item B<resolve_metaclass_alias($category, $name, %options)>
268 =item B<resolve_metatrait_alias($category, $name, %options)>
270 Resolves a short name to a full class name. Short names are often used
271 when specifying the C<metaclass> or C<traits> option for an attribute:
277 The name resolution mechanism is covered in L<Moose/Trait Name
280 =item B<english_list(@items)>
282 Given a list of scalars, turns them into a proper list in English
283 ("one and two", "one, two, three, and four"). This is used to help us
284 make nicer error messages.
290 Here is a list of possible functions to write
294 =item discovering original method from modified method
296 =item search for origin class of a method or attribute
302 All complex software has bugs lurking in it, and this module is no
303 exception. If you find a bug please either email me, or add the bug
308 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
310 B<with contributions from:>
312 Robert (phaylon) Sedlacek
316 =head1 COPYRIGHT AND LICENSE
318 Copyright 2007-2009 by Infinity Interactive, Inc.
320 L<http://www.iinteractive.com>
322 This library is free software; you can redistribute it and/or modify
323 it under the same terms as Perl itself.