7 use Scalar::Util 'blessed';
10 our $VERSION = '0.75_01';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
21 get_all_attribute_values
22 resolve_metatrait_alias
23 resolve_metaclass_alias
28 Sub::Exporter::setup_exporter({
30 groups => { all => \@exports }
33 ## some utils for the utils ...
35 sub find_meta { Class::MOP::class_of(@_) }
40 my ($class_or_obj, $role) = @_;
42 my $meta = find_meta($class_or_obj);
44 return unless defined $meta;
45 return unless $meta->can('does_role');
46 return 1 if $meta->does_role($role);
50 sub search_class_by_role {
51 my ($class_or_obj, $role_name) = @_;
53 my $meta = find_meta($class_or_obj);
55 return unless defined $meta;
57 foreach my $class ($meta->class_precedence_list) {
59 my $_meta = find_meta($class);
61 next unless defined $_meta;
63 foreach my $role (@{ $_meta->roles || [] }) {
64 return $class if $role->name eq $role_name;
71 # this can possibly behave in unexpected ways because the roles being composed
72 # before being applied could differ from call to call; I'm not sure if or how
73 # to document this possible quirk.
74 sub ensure_all_roles {
75 my $applicant = shift;
76 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
80 my $applicant = shift;
81 _apply_all_roles($applicant, sub { 1 }, @_);
84 sub _apply_all_roles {
85 my $applicant = shift;
86 my $role_filter = shift;
90 Moose->throw_error("Must specify at least one role to apply to $applicant");
93 my $roles = Data::OptList::mkopt( [@_] );
95 foreach my $role (@$roles) {
96 my $meta = Class::MOP::load_class( $role->[0] );
98 unless ($meta->isa('Moose::Meta::Role') ) {
100 Moose->throw_error( "You can only consume roles, "
102 . " is not a Moose role" );
106 @$roles = grep { local $_ = $_->[0]; $role_filter->() } @$roles;
108 return unless @$roles;
110 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
112 if ( scalar @$roles == 1 ) {
113 my ( $role, $params ) = @{ $roles->[0] };
114 my $role_meta = Class::MOP::class_of($role);
115 $role_meta->apply( $meta, ( defined $params ? %$params : () ) );
118 Moose::Meta::Role->combine( @$roles )->apply($meta);
122 # instance deconstruction ...
124 sub get_all_attribute_values {
125 my ($class, $instance) = @_;
127 map { $_->name => $_->get_value($instance) }
128 grep { $_->has_value($instance) }
129 $class->get_all_attributes
133 sub get_all_init_args {
134 my ($class, $instance) = @_;
136 map { $_->init_arg => $_->get_value($instance) }
137 grep { $_->has_value($instance) }
138 grep { defined($_->init_arg) }
139 $class->get_all_attributes
143 sub resolve_metatrait_alias {
144 return resolve_metaclass_alias( @_, trait => 1 );
150 sub resolve_metaclass_alias {
151 my ( $type, $metaclass_name, %options ) = @_;
153 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
154 return $cache{$cache_key}{$metaclass_name}
155 if $cache{$cache_key}{$metaclass_name};
157 my $possible_full_name
161 . ( $options{trait} ? "Trait::" : "" )
164 my $loaded_class = Class::MOP::load_first_existing_class(
169 return $cache{$cache_key}{$metaclass_name}
170 = $loaded_class->can('register_implementation')
171 ? $loaded_class->register_implementation
176 sub add_method_modifier {
177 my ( $class_or_obj, $modifier_name, $args ) = @_;
178 my $meta = find_meta($class_or_obj);
179 my $code = pop @{$args};
180 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
181 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
182 if ( $method_modifier_type eq 'Regexp' ) {
183 my @all_methods = $meta->get_all_methods;
185 = grep { $_->name =~ @{$args}[0] } @all_methods;
186 $meta->$add_modifier_method( $_->name, $code )
187 for @matched_methods;
191 $meta->$add_modifier_method( $_, $code ) for @{$args};
198 return $items[0] if @items == 1;
199 return "$items[0] and $items[1]" if @items == 2;
201 my $tail = pop @items;
202 my $list = join ', ', @items;
203 $list .= ', and ' . $tail;
216 Moose::Util - Utilities for working with Moose classes
220 use Moose::Util qw/find_meta does_role search_class_by_role/;
222 my $meta = find_meta($object) || die "No metaclass found";
224 if (does_role($object, $role)) {
225 print "The object can do $role!\n";
228 my $class = search_class_by_role($object, 'FooRole');
229 print "Nearest class with 'FooRole' is $class\n";
233 This module provides a set of utility functions. Many of these
234 functions are intended for use in Moose itself or MooseX modules, but
235 some of them may be useful for use in your own code.
237 =head1 EXPORTED FUNCTIONS
241 =item B<find_meta($class_or_obj)>
243 This method takes a class name or object and attempts to find a
244 metaclass for the class, if one exists. It will B<not> create one if it
247 =item B<does_role($class_or_obj, $role_name)>
249 Returns true if C<$class_or_obj> does the given C<$role_name>.
251 The class must already have a metaclass for this to work.
253 =item B<search_class_by_role($class_or_obj, $role_name)>
255 Returns the first class in the class's precedence list that does
256 C<$role_name>, if any.
258 The class must already have a metaclass for this to work.
260 =item B<apply_all_roles($applicant, @roles)>
262 This function applies one or more roles to the given C<$applicant> The
263 applicant can be a role name, class name, or object.
265 The C<$applicant> must already have a metaclass object.
267 The list of C<@roles> should be a list of names, each of which can be
268 followed by an optional hash reference of options (C<exclude> and
271 =item B<ensure_all_roles($applicant, @roles)>
273 This function is similar to L</apply_all_roles>, but only applies roles that
274 C<$applicant> does not already consume.
276 =item B<get_all_attribute_values($meta, $instance)>
278 Returns a hash reference containing all of the C<$instance>'s
279 attributes. The keys are attribute names.
281 =item B<get_all_init_args($meta, $instance)>
283 Returns a hash reference containing all of the C<init_arg> values for
284 the instance's attributes. The values are the associated attribute
285 values. If an attribute does not have a defined C<init_arg>, it is
288 This could be useful in cloning an object.
290 =item B<resolve_metaclass_alias($category, $name, %options)>
292 =item B<resolve_metatrait_alias($category, $name, %options)>
294 Resolves a short name to a full class name. Short names are often used
295 when specifying the C<metaclass> or C<traits> option for an attribute:
301 The name resolution mechanism is covered in L<Moose/Trait Name
304 =item B<english_list(@items)>
306 Given a list of scalars, turns them into a proper list in English
307 ("one and two", "one, two, three, and four"). This is used to help us
308 make nicer error messages.
314 Here is a list of possible functions to write
318 =item discovering original method from modified method
320 =item search for origin class of a method or attribute
326 All complex software has bugs lurking in it, and this module is no
327 exception. If you find a bug please either email me, or add the bug
332 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
334 B<with contributions from:>
336 Robert (phaylon) Sedlacek
340 =head1 COPYRIGHT AND LICENSE
342 Copyright 2007-2009 by Infinity Interactive, Inc.
344 L<http://www.iinteractive.com>
346 This library is free software; you can redistribute it and/or modify
347 it under the same terms as Perl itself.