7 use Params::Util qw( _STRING );
9 use Scalar::Util 'blessed';
12 our $VERSION = '1.14';
13 $VERSION = eval $VERSION;
14 our $AUTHORITY = 'cpan:STEVAN';
24 get_all_attribute_values
25 resolve_metatrait_alias
26 resolve_metaclass_alias
33 Sub::Exporter::setup_exporter({
35 groups => { all => \@exports }
38 ## some utils for the utils ...
40 sub find_meta { Class::MOP::class_of(@_) }
45 my ($class_or_obj, $role) = @_;
47 my $meta = find_meta($class_or_obj);
49 return unless defined $meta;
50 return unless $meta->can('does_role');
51 return 1 if $meta->does_role($role);
55 sub search_class_by_role {
56 my ($class_or_obj, $role) = @_;
58 my $meta = find_meta($class_or_obj);
60 return unless defined $meta;
62 my $role_name = blessed $role ? $role->name : $role;
64 foreach my $class ($meta->class_precedence_list) {
66 my $_meta = find_meta($class);
68 next unless defined $_meta;
70 foreach my $role (@{ $_meta->roles || [] }) {
71 return $class if $role->name eq $role_name;
78 # this can possibly behave in unexpected ways because the roles being composed
79 # before being applied could differ from call to call; I'm not sure if or how
80 # to document this possible quirk.
81 sub ensure_all_roles {
82 my $applicant = shift;
83 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
87 my $applicant = shift;
88 _apply_all_roles($applicant, undef, @_);
91 sub _apply_all_roles {
92 my $applicant = shift;
93 my $role_filter = shift;
97 Moose->throw_error("Must specify at least one role to apply to $applicant");
100 my $roles = Data::OptList::mkopt( [@_] );
103 foreach my $role (@$roles) {
106 if ( blessed $role->[0] ) {
110 Class::MOP::load_class( $role->[0] , $role->[1] );
111 $meta = Class::MOP::class_of( $role->[0] );
114 unless ($meta && $meta->isa('Moose::Meta::Role') ) {
116 Moose->throw_error( "You can only consume roles, "
118 . " is not a Moose role" );
121 push @role_metas, [ $meta, $role->[1] ];
124 if ( defined $role_filter ) {
125 @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
128 return unless @role_metas;
130 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
132 if ( scalar @role_metas == 1 ) {
133 my ( $role, $params ) = @{ $role_metas[0] };
134 $role->apply( $meta, ( defined $params ? %$params : () ) );
137 Moose::Meta::Role->combine(@role_metas)->apply($meta);
142 my ($class, @roles) = @_;
143 return $class unless @roles;
144 return Moose::Meta::Class->create_anon_class(
145 superclasses => [$class],
151 # instance deconstruction ...
153 sub get_all_attribute_values {
154 my ($class, $instance) = @_;
156 map { $_->name => $_->get_value($instance) }
157 grep { $_->has_value($instance) }
158 $class->get_all_attributes
162 sub get_all_init_args {
163 my ($class, $instance) = @_;
165 map { $_->init_arg => $_->get_value($instance) }
166 grep { $_->has_value($instance) }
167 grep { defined($_->init_arg) }
168 $class->get_all_attributes
172 sub resolve_metatrait_alias {
173 return resolve_metaclass_alias( @_, trait => 1 );
176 sub _build_alias_package_name {
177 my ($type, $name, $trait) = @_;
178 return 'Moose::Meta::'
181 . ( $trait ? 'Trait::' : '' )
188 sub resolve_metaclass_alias {
189 my ( $type, $metaclass_name, %options ) = @_;
191 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
192 return $cache{$cache_key}{$metaclass_name}
193 if $cache{$cache_key}{$metaclass_name};
195 my $possible_full_name = _build_alias_package_name(
196 $type, $metaclass_name, $options{trait}
199 my $loaded_class = Class::MOP::load_first_existing_class(
204 return $cache{$cache_key}{$metaclass_name}
205 = $loaded_class->can('register_implementation')
206 ? $loaded_class->register_implementation
211 sub add_method_modifier {
212 my ( $class_or_obj, $modifier_name, $args ) = @_;
214 = $class_or_obj->can('add_before_method_modifier')
216 : find_meta($class_or_obj);
217 my $code = pop @{$args};
218 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
219 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
220 if ( $method_modifier_type eq 'Regexp' ) {
221 my @all_methods = $meta->get_all_methods;
223 = grep { $_->name =~ @{$args}[0] } @all_methods;
224 $meta->$add_modifier_method( $_->name, $code )
225 for @matched_methods;
227 elsif ($method_modifier_type eq 'ARRAY') {
228 $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
233 "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
235 $method_modifier_type,
241 $meta->$add_modifier_method( $_, $code ) for @{$args};
248 return $items[0] if @items == 1;
249 return "$items[0] and $items[1]" if @items == 2;
251 my $tail = pop @items;
252 my $list = join ', ', @items;
253 $list .= ', and ' . $tail;
259 my $level = @_ ? ($_[0] + 1) : 2;
261 @info{qw(package file line)} = caller($level);
266 my ($type, $name, $trait, $for) = @_;
267 my $package = _build_alias_package_name($type, $name, $trait);
268 Class::MOP::Class->initialize($package)->add_method(
269 register_implementation => sub { $for }
273 sub meta_attribute_alias {
274 my ($to, $from) = @_;
276 my $meta = Class::MOP::class_of($from);
277 my $trait = $meta->isa('Moose::Meta::Role');
278 _create_alias('Attribute', $to, $trait, $from);
281 sub meta_class_alias {
282 my ($to, $from) = @_;
284 my $meta = Class::MOP::class_of($from);
285 my $trait = $meta->isa('Moose::Meta::Role');
286 _create_alias('Class', $to, $trait, $from);
289 # XXX - this should be added to Params::Util
290 sub _STRINGLIKE ($) {
291 return _STRING( $_[0] )
293 && overload::Method( $_[0], q{""} )
305 Moose::Util - Utilities for working with Moose classes
309 use Moose::Util qw/find_meta does_role search_class_by_role/;
311 my $meta = find_meta($object) || die "No metaclass found";
313 if (does_role($object, $role)) {
314 print "The object can do $role!\n";
317 my $class = search_class_by_role($object, 'FooRole');
318 print "Nearest class with 'FooRole' is $class\n";
322 This module provides a set of utility functions. Many of these
323 functions are intended for use in Moose itself or MooseX modules, but
324 some of them may be useful for use in your own code.
326 =head1 EXPORTED FUNCTIONS
330 =item B<find_meta($class_or_obj)>
332 This method takes a class name or object and attempts to find a
333 metaclass for the class, if one exists. It will B<not> create one if it
336 =item B<does_role($class_or_obj, $role_or_obj)>
338 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
339 be provided as a name or a L<Moose::Meta::Role> object.
341 The class must already have a metaclass for this to work. If it doesn't, this
342 function simply returns false.
344 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
346 Returns the first class in the class's precedence list that does
347 C<$role_or_obj>, if any. The role can be either a name or a
348 L<Moose::Meta::Role> object.
350 The class must already have a metaclass for this to work.
352 =item B<apply_all_roles($applicant, @roles)>
354 This function applies one or more roles to the given C<$applicant> The
355 applicant can be a role name, class name, or object.
357 The C<$applicant> must already have a metaclass object.
359 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
360 each of which can be followed by an optional hash reference of options
361 (C<-excludes> and C<-alias>).
363 =item B<ensure_all_roles($applicant, @roles)>
365 This function is similar to L</apply_all_roles>, but only applies roles that
366 C<$applicant> does not already consume.
368 =item B<with_traits($class_name, @role_names)>
370 This function creates a new class from C<$class_name> with each of
371 C<@role_names> applied. It returns the name of the new class.
373 =item B<get_all_attribute_values($meta, $instance)>
375 Returns a hash reference containing all of the C<$instance>'s
376 attributes. The keys are attribute names.
378 =item B<get_all_init_args($meta, $instance)>
380 Returns a hash reference containing all of the C<init_arg> values for
381 the instance's attributes. The values are the associated attribute
382 values. If an attribute does not have a defined C<init_arg>, it is
385 This could be useful in cloning an object.
387 =item B<resolve_metaclass_alias($category, $name, %options)>
389 =item B<resolve_metatrait_alias($category, $name, %options)>
391 Resolves a short name to a full class name. Short names are often used
392 when specifying the C<metaclass> or C<traits> option for an attribute:
398 The name resolution mechanism is covered in
399 L<Moose/Metaclass and Trait Name Resolution>.
401 =item B<meta_class_alias($to[, $from])>
403 =item B<meta_attribute_alias($to[, $from])>
405 Create an alias from the class C<$from> (or the current package, if
406 C<$from> is unspecified), so that
407 L<Moose/Metaclass and Trait Name Resolution> works properly.
409 =item B<english_list(@items)>
411 Given a list of scalars, turns them into a proper list in English
412 ("one and two", "one, two, three, and four"). This is used to help us
413 make nicer error messages.
419 Here is a list of possible functions to write
423 =item discovering original method from modified method
425 =item search for origin class of a method or attribute
431 See L<Moose/BUGS> for details on reporting bugs.
435 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
437 B<with contributions from:>
439 Robert (phaylon) Sedlacek
443 =head1 COPYRIGHT AND LICENSE
445 Copyright 2007-2009 by Infinity Interactive, Inc.
447 L<http://www.iinteractive.com>
449 This library is free software; you can redistribute it and/or modify
450 it under the same terms as Perl itself.