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 ...
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 foreach my $role (@$roles) {
84 my $meta = Class::MOP::load_class( $role->[0] );
86 unless ($meta->isa('Moose::Meta::Role') ) {
88 Moose->throw_error( "You can only consume roles, "
90 . " is not a Moose role" );
94 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
96 if ( scalar @$roles == 1 ) {
97 my ( $role, $params ) = @{ $roles->[0] };
98 my $role_meta = Class::MOP::class_of($role);
99 $role_meta->apply( $meta, ( defined $params ? %$params : () ) );
102 Moose::Meta::Role->combine( @$roles )->apply($meta);
106 # instance deconstruction ...
108 sub get_all_attribute_values {
109 my ($class, $instance) = @_;
111 map { $_->name => $_->get_value($instance) }
112 grep { $_->has_value($instance) }
113 $class->compute_all_applicable_attributes
117 sub get_all_init_args {
118 my ($class, $instance) = @_;
120 map { $_->init_arg => $_->get_value($instance) }
121 grep { $_->has_value($instance) }
122 grep { defined($_->init_arg) }
123 $class->compute_all_applicable_attributes
127 sub resolve_metatrait_alias {
128 return resolve_metaclass_alias( @_, trait => 1 );
134 sub resolve_metaclass_alias {
135 my ( $type, $metaclass_name, %options ) = @_;
137 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
138 return $cache{$cache_key}{$metaclass_name}
139 if $cache{$cache_key}{$metaclass_name};
141 my $possible_full_name
145 . ( $options{trait} ? "Trait::" : "" )
148 my $loaded_class = Class::MOP::load_first_existing_class(
153 return $cache{$cache_key}{$metaclass_name}
154 = $loaded_class->can('register_implementation')
155 ? $loaded_class->register_implementation
160 sub add_method_modifier {
161 my ( $class_or_obj, $modifier_name, $args ) = @_;
162 my $meta = find_meta($class_or_obj);
163 my $code = pop @{$args};
164 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
165 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
166 if ( $method_modifier_type eq 'Regexp' ) {
167 my @all_methods = $meta->get_all_methods;
169 = grep { $_->name =~ @{$args}[0] } @all_methods;
170 $meta->$add_modifier_method( $_->name, $code )
171 for @matched_methods;
175 $meta->$add_modifier_method( $_, $code ) for @{$args};
182 return $items[0] if @items == 1;
183 return "$items[0] and $items[1]" if @items == 2;
185 my $tail = pop @items;
186 my $list = join ', ', @items;
187 $list .= ', and ' . $tail;
200 Moose::Util - Utilities for working with Moose classes
204 use Moose::Util qw/find_meta does_role search_class_by_role/;
206 my $meta = find_meta($object) || die "No metaclass found";
208 if (does_role($object, $role)) {
209 print "The object can do $role!\n";
212 my $class = search_class_by_role($object, 'FooRole');
213 print "Nearest class with 'FooRole' is $class\n";
217 This module provides a set of utility functions. Many of these
218 functions are intended for use in Moose itself or MooseX modules, but
219 some of them may be useful for use in your own code.
221 =head1 EXPORTED FUNCTIONS
225 =item B<find_meta($class_or_obj)>
227 This method takes a class name or object and attempts to find a
228 metaclass for the class, if one exists. It will not create one if it
231 =item B<does_role($class_or_obj, $role_name)>
233 Returns true if C<$class_or_obj> does the given C<$role_name>.
235 The class must already have a metaclass for this to work.
237 =item B<search_class_by_role($class_or_obj, $role_name)>
239 Returns the first class in the class's precedence list that does
240 C<$role_name>, if any.
242 The class must already have a metaclass for this to work.
244 =item B<apply_all_roles($applicant, @roles)>
246 This function applies one or more roles to the given C<$applicant> The
247 applicant can be a role name, class name, or object.
249 The C<$applicant> must already have a metaclass object.
251 The list of C<@roles> should be a list of names, each of which can be
252 followed by an optional hash reference of options (C<exclude> and
255 =item B<get_all_attribute_values($meta, $instance)>
257 Returns a hash reference containing all of the C<$instance>'s
258 attributes. The keys are attribute names.
260 =item B<get_all_init_args($meta, $instance)>
262 Returns a hash reference containing all of the C<init_arg> values for
263 the instance's attributes. The values are the associated attribute
264 values. If an attribute does not have a defined C<init_arg>, it is
267 This could be useful in cloning an object.
269 =item B<resolve_metaclass_alias($category, $name, %options)>
271 =item B<resolve_metatrait_alias($category, $name, %options)>
273 Resolves a short name to a full class name. Short names are often used
274 when specifying the C<metaclass> or C<traits> option for an attribute:
280 The name resolution mechanism is covered in L<Moose/Trait Name
283 =item B<english_list(@items)>
285 Given a list of scalars, turns them into a proper list in English
286 ("one and two", "one, two, three, and four"). This is used to help us
287 make nicer error messages.
293 Here is a list of possible functions to write
297 =item discovering original method from modified method
299 =item search for origin class of a method or attribute
305 All complex software has bugs lurking in it, and this module is no
306 exception. If you find a bug please either email me, or add the bug
311 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
313 B<with contributions from:>
315 Robert (phaylon) Sedlacek
319 =head1 COPYRIGHT AND LICENSE
321 Copyright 2007-2009 by Infinity Interactive, Inc.
323 L<http://www.iinteractive.com>
325 This library is free software; you can redistribute it and/or modify
326 it under the same terms as Perl itself.