8 use Scalar::Util 'blessed';
11 our $VERSION = '1.14';
12 $VERSION = eval $VERSION;
13 our $AUTHORITY = 'cpan:STEVAN';
23 get_all_attribute_values
24 resolve_metatrait_alias
25 resolve_metaclass_alias
32 Sub::Exporter::setup_exporter({
34 groups => { all => \@exports }
37 ## some utils for the utils ...
39 sub find_meta { Class::MOP::class_of(@_) }
44 my ($class_or_obj, $role) = @_;
46 my $meta = find_meta($class_or_obj);
48 return unless defined $meta;
49 return unless $meta->can('does_role');
50 return 1 if $meta->does_role($role);
54 sub search_class_by_role {
55 my ($class_or_obj, $role) = @_;
57 my $meta = find_meta($class_or_obj);
59 return unless defined $meta;
61 my $role_name = blessed $role ? $role->name : $role;
63 foreach my $class ($meta->class_precedence_list) {
65 my $_meta = find_meta($class);
67 next unless defined $_meta;
69 foreach my $role (@{ $_meta->roles || [] }) {
70 return $class if $role->name eq $role_name;
77 # this can possibly behave in unexpected ways because the roles being composed
78 # before being applied could differ from call to call; I'm not sure if or how
79 # to document this possible quirk.
80 sub ensure_all_roles {
81 my $applicant = shift;
82 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
86 my $applicant = shift;
87 _apply_all_roles($applicant, undef, @_);
90 sub _apply_all_roles {
91 my $applicant = shift;
92 my $role_filter = shift;
96 Moose->throw_error("Must specify at least one role to apply to $applicant");
99 my $roles = Data::OptList::mkopt( [@_] );
102 foreach my $role (@$roles) {
105 if ( blessed $role->[0] ) {
109 Class::MOP::load_class( $role->[0] , $role->[1] );
110 $meta = Class::MOP::class_of( $role->[0] );
113 unless ($meta && $meta->isa('Moose::Meta::Role') ) {
115 Moose->throw_error( "You can only consume roles, "
117 . " is not a Moose role" );
120 push @role_metas, [ $meta, $role->[1] ];
123 if ( defined $role_filter ) {
124 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
127 return unless @role_metas;
129 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
131 if ( scalar @role_metas == 1 ) {
132 my ( $role, $params ) = @{ $role_metas[0] };
133 $role->apply( $meta, ( defined $params ? %$params : () ) );
136 Moose::Meta::Role->combine(@role_metas)->apply($meta);
141 my ($class, @roles) = @_;
142 return $class unless @roles;
143 return Moose::Meta::Class->create_anon_class(
144 superclasses => [$class],
150 # instance deconstruction ...
152 sub get_all_attribute_values {
153 my ($class, $instance) = @_;
155 map { $_->name => $_->get_value($instance) }
156 grep { $_->has_value($instance) }
157 $class->get_all_attributes
161 sub get_all_init_args {
162 my ($class, $instance) = @_;
164 map { $_->init_arg => $_->get_value($instance) }
165 grep { $_->has_value($instance) }
166 grep { defined($_->init_arg) }
167 $class->get_all_attributes
171 sub resolve_metatrait_alias {
172 return resolve_metaclass_alias( @_, trait => 1 );
175 sub _build_alias_package_name {
176 my ($type, $name, $trait) = @_;
177 return 'Moose::Meta::'
180 . ( $trait ? 'Trait::' : '' )
187 sub resolve_metaclass_alias {
188 my ( $type, $metaclass_name, %options ) = @_;
190 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
191 return $cache{$cache_key}{$metaclass_name}
192 if $cache{$cache_key}{$metaclass_name};
194 my $possible_full_name = _build_alias_package_name(
195 $type, $metaclass_name, $options{trait}
198 my $loaded_class = Class::MOP::load_first_existing_class(
203 return $cache{$cache_key}{$metaclass_name}
204 = $loaded_class->can('register_implementation')
205 ? $loaded_class->register_implementation
210 sub add_method_modifier {
211 my ( $class_or_obj, $modifier_name, $args ) = @_;
213 = $class_or_obj->can('add_before_method_modifier')
215 : find_meta($class_or_obj);
216 my $code = pop @{$args};
217 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
218 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
219 if ( $method_modifier_type eq 'Regexp' ) {
220 my @all_methods = $meta->get_all_methods;
222 = grep { $_->name =~ @{$args}[0] } @all_methods;
223 $meta->$add_modifier_method( $_->name, $code )
224 for @matched_methods;
226 elsif ($method_modifier_type eq 'ARRAY') {
227 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
232 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
234 $method_modifier_type,
240 $meta->$add_modifier_method( $_, $code ) for @{$args};
247 return $items[0] if @items == 1;
248 return "$items[0] and $items[1]" if @items == 2;
250 my $tail = pop @items;
251 my $list = join ', ', @items;
252 $list .= ', and ' . $tail;
258 my $level = @_ ? ($_[0] + 1) : 2;
260 @info{qw(package file line)} = caller($level);
265 my ($type, $name, $trait, $for) = @_;
266 my $package = _build_alias_package_name($type, $name, $trait);
267 Class::MOP::Class->initialize($package)->add_method(
268 register_implementation => sub { $for }
272 sub meta_attribute_alias {
273 my ($to, $from) = @_;
275 my $meta = Class::MOP::class_of($from);
276 my $trait = $meta->isa('Moose::Meta::Role');
277 _create_alias('Attribute', $to, $trait, $from);
280 sub meta_class_alias {
281 my ($to, $from) = @_;
283 my $meta = Class::MOP::class_of($from);
284 my $trait = $meta->isa('Moose::Meta::Role');
285 _create_alias('Class', $to, $trait, $from);
296 Moose::Util - Utilities for working with Moose classes
300 use Moose::Util qw/find_meta does_role search_class_by_role/;
302 my $meta = find_meta($object) || die "No metaclass found";
304 if (does_role($object, $role)) {
305 print "The object can do $role!\n";
308 my $class = search_class_by_role($object, 'FooRole');
309 print "Nearest class with 'FooRole' is $class\n";
313 This module provides a set of utility functions. Many of these
314 functions are intended for use in Moose itself or MooseX modules, but
315 some of them may be useful for use in your own code.
317 =head1 EXPORTED FUNCTIONS
321 =item B<find_meta($class_or_obj)>
323 This method takes a class name or object and attempts to find a
324 metaclass for the class, if one exists. It will B<not> create one if it
327 =item B<does_role($class_or_obj, $role_or_obj)>
329 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
330 be provided as a name or a L<Moose::Meta::Role> object.
332 The class must already have a metaclass for this to work. If it doesn't, this
333 function simply returns false.
335 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
337 Returns the first class in the class's precedence list that does
338 C<$role_or_obj>, if any. The role can be either a name or a
339 L<Moose::Meta::Role> object.
341 The class must already have a metaclass for this to work.
343 =item B<apply_all_roles($applicant, @roles)>
345 This function applies one or more roles to the given C<$applicant> The
346 applicant can be a role name, class name, or object.
348 The C<$applicant> must already have a metaclass object.
350 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
351 each of which can be followed by an optional hash reference of options
352 (C<-excludes> and C<-alias>).
354 =item B<ensure_all_roles($applicant, @roles)>
356 This function is similar to L</apply_all_roles>, but only applies roles that
357 C<$applicant> does not already consume.
359 =item B<with_traits($class_name, @role_names)>
361 This function creates a new class from C<$class_name> with each of
362 C<@role_names> applied. It returns the name of the new class.
364 =item B<get_all_attribute_values($meta, $instance)>
366 Returns a hash reference containing all of the C<$instance>'s
367 attributes. The keys are attribute names.
369 =item B<get_all_init_args($meta, $instance)>
371 Returns a hash reference containing all of the C<init_arg> values for
372 the instance's attributes. The values are the associated attribute
373 values. If an attribute does not have a defined C<init_arg>, it is
376 This could be useful in cloning an object.
378 =item B<resolve_metaclass_alias($category, $name, %options)>
380 =item B<resolve_metatrait_alias($category, $name, %options)>
382 Resolves a short name to a full class name. Short names are often used
383 when specifying the C<metaclass> or C<traits> option for an attribute:
389 The name resolution mechanism is covered in
390 L<Moose/Metaclass and Trait Name Resolution>.
392 =item B<meta_class_alias($to[, $from])>
394 =item B<meta_attribute_alias($to[, $from])>
396 Create an alias from the class C<$from> (or the current package, if
397 C<$from> is unspecified), so that
398 L<Moose/Metaclass and Trait Name Resolution> works properly.
400 =item B<english_list(@items)>
402 Given a list of scalars, turns them into a proper list in English
403 ("one and two", "one, two, three, and four"). This is used to help us
404 make nicer error messages.
410 Here is a list of possible functions to write
414 =item discovering original method from modified method
416 =item search for origin class of a method or attribute
422 See L<Moose/BUGS> for details on reporting bugs.
426 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
428 B<with contributions from:>
430 Robert (phaylon) Sedlacek
434 =head1 COPYRIGHT AND LICENSE
436 Copyright 2007-2009 by Infinity Interactive, Inc.
438 L<http://www.iinteractive.com>
440 This library is free software; you can redistribute it and/or modify
441 it under the same terms as Perl itself.