7 use Params::Util qw( _STRING );
9 use Scalar::Util 'blessed';
10 use List::MoreUtils qw(any);
13 our $VERSION = '1.14';
14 $VERSION = eval $VERSION;
15 our $AUTHORITY = 'cpan:STEVAN';
25 get_all_attribute_values
26 resolve_metatrait_alias
27 resolve_metaclass_alias
34 Sub::Exporter::setup_exporter({
36 groups => { all => \@exports }
39 ## some utils for the utils ...
41 sub find_meta { Class::MOP::class_of(@_) }
46 my ($class_or_obj, $role) = @_;
48 my $meta = find_meta($class_or_obj);
50 return unless defined $meta;
51 return unless $meta->can('does_role');
52 return 1 if $meta->does_role($role);
56 sub search_class_by_role {
57 my ($class_or_obj, $role) = @_;
59 my $meta = find_meta($class_or_obj);
61 return unless defined $meta;
63 my $role_name = blessed $role ? $role->name : $role;
65 foreach my $class ($meta->class_precedence_list) {
67 my $_meta = find_meta($class);
69 next unless defined $_meta;
71 foreach my $role (@{ $_meta->roles || [] }) {
72 return $class if $role->name eq $role_name;
79 # this can possibly behave in unexpected ways because the roles being composed
80 # before being applied could differ from call to call; I'm not sure if or how
81 # to document this possible quirk.
82 sub ensure_all_roles {
83 my $applicant = shift;
84 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
88 my $applicant = shift;
89 _apply_all_roles($applicant, undef, @_);
92 sub _apply_all_roles {
93 my $applicant = shift;
94 my $role_filter = shift;
98 Moose->throw_error("Must specify at least one role to apply to $applicant");
101 my $roles = Data::OptList::mkopt( [@_] );
104 foreach my $role (@$roles) {
107 if ( blessed $role->[0] ) {
111 Class::MOP::load_class( $role->[0] , $role->[1] );
112 $meta = Class::MOP::class_of( $role->[0] );
115 unless ($meta && $meta->isa('Moose::Meta::Role') ) {
117 Moose->throw_error( "You can only consume roles, "
119 . " is not a Moose role" );
122 push @role_metas, [ $meta, $role->[1] ];
125 if ( defined $role_filter ) {
126 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
129 return unless @role_metas;
131 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
133 if ( scalar @role_metas == 1 ) {
134 my ( $role, $params ) = @{ $role_metas[0] };
135 $role->apply( $meta, ( defined $params ? %$params : () ) );
138 Moose::Meta::Role->combine(@role_metas)->apply($meta);
143 my ($class, @roles) = @_;
144 return $class unless @roles;
145 return Moose::Meta::Class->create_anon_class(
146 superclasses => [$class],
152 # instance deconstruction ...
154 sub get_all_attribute_values {
155 my ($class, $instance) = @_;
157 map { $_->name => $_->get_value($instance) }
158 grep { $_->has_value($instance) }
159 $class->get_all_attributes
163 sub get_all_init_args {
164 my ($class, $instance) = @_;
166 map { $_->init_arg => $_->get_value($instance) }
167 grep { $_->has_value($instance) }
168 grep { defined($_->init_arg) }
169 $class->get_all_attributes
173 sub resolve_metatrait_alias {
174 return resolve_metaclass_alias( @_, trait => 1 );
177 sub _build_alias_package_name {
178 my ($type, $name, $trait) = @_;
179 return 'Moose::Meta::'
182 . ( $trait ? 'Trait::' : '' )
189 sub resolve_metaclass_alias {
190 my ( $type, $metaclass_name, %options ) = @_;
192 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
193 return $cache{$cache_key}{$metaclass_name}
194 if $cache{$cache_key}{$metaclass_name};
196 my $possible_full_name = _build_alias_package_name(
197 $type, $metaclass_name, $options{trait}
200 my $loaded_class = Class::MOP::load_first_existing_class(
205 return $cache{$cache_key}{$metaclass_name}
206 = $loaded_class->can('register_implementation')
207 ? $loaded_class->register_implementation
212 sub add_method_modifier {
213 my ( $class_or_obj, $modifier_name, $args ) = @_;
215 = $class_or_obj->can('add_before_method_modifier')
217 : find_meta($class_or_obj);
218 my $code = pop @{$args};
219 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
220 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
221 if ( $method_modifier_type eq 'Regexp' ) {
222 my @all_methods = $meta->get_all_methods;
224 = grep { $_->name =~ @{$args}[0] } @all_methods;
225 $meta->$add_modifier_method( $_->name, $code )
226 for @matched_methods;
228 elsif ($method_modifier_type eq 'ARRAY') {
229 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
234 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
236 $method_modifier_type,
242 $meta->$add_modifier_method( $_, $code ) for @{$args};
249 return $items[0] if @items == 1;
250 return "$items[0] and $items[1]" if @items == 2;
252 my $tail = pop @items;
253 my $list = join ', ', @items;
254 $list .= ', and ' . $tail;
260 my $level = @_ ? ($_[0] + 1) : 2;
262 @info{qw(package file line)} = caller($level);
267 my ($type, $name, $trait, $for) = @_;
268 my $package = _build_alias_package_name($type, $name, $trait);
269 Class::MOP::Class->initialize($package)->add_method(
270 register_implementation => sub { $for }
274 sub meta_attribute_alias {
275 my ($to, $from) = @_;
277 my $meta = Class::MOP::class_of($from);
278 my $trait = $meta->isa('Moose::Meta::Role');
279 _create_alias('Attribute', $to, $trait, $from);
282 sub meta_class_alias {
283 my ($to, $from) = @_;
285 my $meta = Class::MOP::class_of($from);
286 my $trait = $meta->isa('Moose::Meta::Role');
287 _create_alias('Class', $to, $trait, $from);
290 # XXX - this should be added to Params::Util
291 sub _STRINGLIKE ($) {
292 return _STRING( $_[0] )
294 && overload::Method( $_[0], q{""} )
298 sub _reconcile_roles_for_metaclass {
299 my ($class_meta_name, $super_meta_name) = @_;
301 my @role_differences = _role_differences(
302 $class_meta_name, $super_meta_name,
305 # handle the case where we need to fix compatibility between a class and
306 # its parent, but all roles in the class are already also done by the
309 return $super_meta_name
310 unless @role_differences;
312 return Moose::Meta::Class->create_anon_class(
313 superclasses => [$super_meta_name],
314 roles => [map { $_->name } @role_differences],
319 sub _role_differences {
320 my ($class_meta_name, $super_meta_name) = @_;
321 my @super_role_metas = $super_meta_name->meta->can('calculate_all_roles_with_inheritance')
322 ? $super_meta_name->meta->calculate_all_roles_with_inheritance
324 my @role_metas = $class_meta_name->meta->can('calculate_all_roles_with_inheritance')
325 ? $class_meta_name->meta->calculate_all_roles_with_inheritance
328 for my $role_meta (@role_metas) {
329 push @differences, $role_meta
330 unless any { $_->name eq $role_meta->name } @super_role_metas;
343 Moose::Util - Utilities for working with Moose classes
347 use Moose::Util qw/find_meta does_role search_class_by_role/;
349 my $meta = find_meta($object) || die "No metaclass found";
351 if (does_role($object, $role)) {
352 print "The object can do $role!\n";
355 my $class = search_class_by_role($object, 'FooRole');
356 print "Nearest class with 'FooRole' is $class\n";
360 This module provides a set of utility functions. Many of these
361 functions are intended for use in Moose itself or MooseX modules, but
362 some of them may be useful for use in your own code.
364 =head1 EXPORTED FUNCTIONS
368 =item B<find_meta($class_or_obj)>
370 This method takes a class name or object and attempts to find a
371 metaclass for the class, if one exists. It will B<not> create one if it
374 =item B<does_role($class_or_obj, $role_or_obj)>
376 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
377 be provided as a name or a L<Moose::Meta::Role> object.
379 The class must already have a metaclass for this to work. If it doesn't, this
380 function simply returns false.
382 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
384 Returns the first class in the class's precedence list that does
385 C<$role_or_obj>, if any. The role can be either a name or a
386 L<Moose::Meta::Role> object.
388 The class must already have a metaclass for this to work.
390 =item B<apply_all_roles($applicant, @roles)>
392 This function applies one or more roles to the given C<$applicant> The
393 applicant can be a role name, class name, or object.
395 The C<$applicant> must already have a metaclass object.
397 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
398 each of which can be followed by an optional hash reference of options
399 (C<-excludes> and C<-alias>).
401 =item B<ensure_all_roles($applicant, @roles)>
403 This function is similar to L</apply_all_roles>, but only applies roles that
404 C<$applicant> does not already consume.
406 =item B<with_traits($class_name, @role_names)>
408 This function creates a new class from C<$class_name> with each of
409 C<@role_names> applied. It returns the name of the new class.
411 =item B<get_all_attribute_values($meta, $instance)>
413 Returns a hash reference containing all of the C<$instance>'s
414 attributes. The keys are attribute names.
416 =item B<get_all_init_args($meta, $instance)>
418 Returns a hash reference containing all of the C<init_arg> values for
419 the instance's attributes. The values are the associated attribute
420 values. If an attribute does not have a defined C<init_arg>, it is
423 This could be useful in cloning an object.
425 =item B<resolve_metaclass_alias($category, $name, %options)>
427 =item B<resolve_metatrait_alias($category, $name, %options)>
429 Resolves a short name to a full class name. Short names are often used
430 when specifying the C<metaclass> or C<traits> option for an attribute:
436 The name resolution mechanism is covered in
437 L<Moose/Metaclass and Trait Name Resolution>.
439 =item B<meta_class_alias($to[, $from])>
441 =item B<meta_attribute_alias($to[, $from])>
443 Create an alias from the class C<$from> (or the current package, if
444 C<$from> is unspecified), so that
445 L<Moose/Metaclass and Trait Name Resolution> works properly.
447 =item B<english_list(@items)>
449 Given a list of scalars, turns them into a proper list in English
450 ("one and two", "one, two, three, and four"). This is used to help us
451 make nicer error messages.
457 Here is a list of possible functions to write
461 =item discovering original method from modified method
463 =item search for origin class of a method or attribute
469 See L<Moose/BUGS> for details on reporting bugs.
473 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
475 B<with contributions from:>
477 Robert (phaylon) Sedlacek
481 =head1 COPYRIGHT AND LICENSE
483 Copyright 2007-2009 by Infinity Interactive, Inc.
485 L<http://www.iinteractive.com>
487 This library is free software; you can redistribute it and/or modify
488 it under the same terms as Perl itself.