7 use Scalar::Util 'blessed';
10 our $VERSION = '0.60';
11 $VERSION = eval $VERSION;
12 our $AUTHORITY = 'cpan:STEVAN';
20 get_all_attribute_values
21 resolve_metatrait_alias
22 resolve_metaclass_alias
26 Sub::Exporter::setup_exporter({
28 groups => { all => \@exports }
31 ## some utils for the utils ...
35 return Class::MOP::get_metaclass_by_name(blessed($_[0]) || $_[0]);
41 my ($class_or_obj, $role) = @_;
43 my $meta = find_meta($class_or_obj);
45 return unless defined $meta;
46 return unless $meta->can('does_role');
47 return 1 if $meta->does_role($role);
51 sub search_class_by_role {
52 my ($class_or_obj, $role_name) = @_;
54 my $meta = find_meta($class_or_obj);
56 return unless defined $meta;
58 foreach my $class ($meta->class_precedence_list) {
60 my $_meta = find_meta($class);
62 next unless defined $_meta;
64 foreach my $role (@{ $_meta->roles || [] }) {
65 return $class if $role->name eq $role_name;
73 my $applicant = shift;
75 Moose->throw_error("Must specify at least one role to apply to $applicant") unless @_;
77 my $roles = Data::OptList::mkopt( [@_] );
79 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
81 foreach my $role_spec (@$roles) {
82 Class::MOP::load_class( $role_spec->[0] );
85 ( $_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role') )
86 || Moose->throw_error("You can only consume roles, "
88 . " is not a Moose role")
91 if ( scalar @$roles == 1 ) {
92 my ( $role, $params ) = @{ $roles->[0] };
93 $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
96 Moose::Meta::Role->combine( @$roles )->apply($meta);
100 # instance deconstruction ...
102 sub get_all_attribute_values {
103 my ($class, $instance) = @_;
105 map { $_->name => $_->get_value($instance) }
106 grep { $_->has_value($instance) }
107 $class->compute_all_applicable_attributes
111 sub get_all_init_args {
112 my ($class, $instance) = @_;
114 map { $_->init_arg => $_->get_value($instance) }
115 grep { $_->has_value($instance) }
116 grep { defined($_->init_arg) }
117 $class->compute_all_applicable_attributes
121 sub resolve_metatrait_alias {
122 my ( $type, $metaclass_name ) = @_;
124 return resolve_metaclass_alias( @_, trait => 1 );
130 sub resolve_metaclass_alias {
131 my ( $type, $metaclass_name, %options ) = @_;
133 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
134 return $cache{$cache_key}{$metaclass_name}
135 if $cache{$cache_key}{$metaclass_name};
137 my $possible_full_name
141 . ( $options{trait} ? "Trait::" : "" )
144 my $loaded_class = Class::MOP::load_first_existing_class(
149 return $cache{$cache_key}{$metaclass_name}
150 = $loaded_class->can('register_implementation')
151 ? $loaded_class->register_implementation
156 sub add_method_modifier {
157 my ( $class_or_obj, $modifier_name, $args ) = @_;
158 my $meta = find_meta($class_or_obj);
159 my $code = pop @{$args};
160 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
161 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
162 if ( $method_modifier_type eq 'Regexp' ) {
163 my @all_methods = $meta->get_all_methods;
165 = grep { $_->name =~ @{$args}[0] } @all_methods;
166 $meta->$add_modifier_method( $_->name, $code )
167 for @matched_methods;
171 $meta->$add_modifier_method( $_, $code ) for @{$args};
183 Moose::Util - Utilities for working with Moose classes
187 use Moose::Util qw/find_meta does_role search_class_by_role/;
189 my $meta = find_meta($object) || die "No metaclass found";
191 if (does_role($object, $role)) {
192 print "The object can do $role!\n";
195 my $class = search_class_by_role($object, 'FooRole');
196 print "Nearest class with 'FooRole' is $class\n";
200 This is a set of utility functions to help working with Moose classes, and
201 is used internally by Moose itself. The goal is to provide useful functions
202 that for both Moose users and Moose extenders (MooseX:: authors).
204 This is a relatively new addition to the Moose toolchest, so ideas,
205 suggestions and contributions to this collection are most welcome.
206 See the L<TODO> section below for a list of ideas for possible functions
209 =head1 EXPORTED FUNCTIONS
213 =item B<find_meta ($class_or_obj)>
215 This will attempt to locate a metaclass for the given C<$class_or_obj>
218 =item B<does_role ($class_or_obj, $role_name)>
220 Returns true if C<$class_or_obj> can do the role C<$role_name>.
222 =item B<search_class_by_role ($class_or_obj, $role_name)>
224 Returns first class in precedence list that consumed C<$role_name>.
226 =item B<apply_all_roles ($applicant, @roles)>
228 Given an C<$applicant> (which can somehow be turned into either a
229 metaclass or a metarole) and a list of C<@roles> this will do the
230 right thing to apply the C<@roles> to the C<$applicant>. This is
231 actually used internally by both L<Moose> and L<Moose::Role>, and the
232 C<@roles> will be pre-processed through L<Data::OptList::mkopt>
233 to allow for the additional arguments to be passed.
235 =item B<get_all_attribute_values($meta, $instance)>
237 Returns the values of the C<$instance>'s fields keyed by the attribute names.
239 =item B<get_all_init_args($meta, $instance)>
241 Returns a hash reference where the keys are all the attributes' C<init_arg>s
242 and the values are the instance's fields. Attributes without an C<init_arg>
245 =item B<resolve_metaclass_alias($category, $name, %options)>
247 =item B<resolve_metatrait_alias($category, $name, %options)>
249 Resolve a short name like in e.g.
255 to a full class name.
257 =item B<add_method_modifier ($class_or_obj, $modifier_name, $args)>
263 Here is a list of possible functions to write
267 =item discovering original method from modified method
269 =item search for origin class of a method or attribute
275 All complex software has bugs lurking in it, and this module is no
276 exception. If you find a bug please either email me, or add the bug
281 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
283 B<with contributions from:>
285 Robert (phaylon) Sedlacek
289 =head1 COPYRIGHT AND LICENSE
291 Copyright 2007-2008 by Infinity Interactive, Inc.
293 L<http://www.iinteractive.com>
295 This library is free software; you can redistribute it and/or modify
296 it under the same terms as Perl itself.