7 use Scalar::Util 'blessed';
11 our $VERSION = '0.56';
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 apply_all_roles_with_method( $applicant, 'apply', [@_] );
78 sub apply_all_roles_with_method {
79 my ( $applicant, $apply_method, $role_list ) = @_;
81 confess "Must specify at least one role to apply to $applicant"
84 my $roles = Data::OptList::mkopt($role_list);
86 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
88 foreach my $role_spec (@$roles) {
89 Class::MOP::load_class( $role_spec->[0] );
92 ( $_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role') )
93 || confess "You can only consume roles, "
95 . " is not a Moose role"
98 if ( scalar @$roles == 1 ) {
99 my ( $role, $params ) = @{ $roles->[0] };
100 $role->meta->$apply_method( $meta,
101 ( defined $params ? %$params : () ) );
104 Moose::Meta::Role->combine( @$roles )->$apply_method($meta);
108 # instance deconstruction ...
110 sub get_all_attribute_values {
111 my ($class, $instance) = @_;
113 map { $_->name => $_->get_value($instance) }
114 grep { $_->has_value($instance) }
115 $class->compute_all_applicable_attributes
119 sub get_all_init_args {
120 my ($class, $instance) = @_;
122 map { $_->init_arg => $_->get_value($instance) }
123 grep { $_->has_value($instance) }
124 grep { defined($_->init_arg) }
125 $class->compute_all_applicable_attributes
129 sub resolve_metatrait_alias {
130 resolve_metaclass_alias( @_, trait => 1 );
133 sub resolve_metaclass_alias {
134 my ( $type, $metaclass_name, %options ) = @_;
136 if ( my $resolved = eval {
137 my $possible_full_name = 'Moose::Meta::' . $type . '::Custom::' . ( $options{trait} ? "Trait::" : "" ) . $metaclass_name;
139 Class::MOP::load_class($possible_full_name);
141 $possible_full_name->can('register_implementation')
142 ? $possible_full_name->register_implementation
143 : $possible_full_name;
147 Class::MOP::load_class($metaclass_name);
148 return $metaclass_name;
152 sub add_method_modifier {
153 my ( $class_or_obj, $modifier_name, $args ) = @_;
154 my $meta = find_meta($class_or_obj);
155 my $code = pop @{$args};
156 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
157 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
158 if ( $method_modifier_type eq 'Regexp' ) {
159 my @all_methods = $meta->get_all_methods;
161 = grep { $_->name =~ @{$args}[0] } @all_methods;
162 $meta->$add_modifier_method( $_->name, $code )
163 for @matched_methods;
167 $meta->$add_modifier_method( $_, $code ) for @{$args};
179 Moose::Util - Utilities for working with Moose classes
183 use Moose::Util qw/find_meta does_role search_class_by_role/;
185 my $meta = find_meta($object) || die "No metaclass found";
187 if (does_role($object, $role)) {
188 print "The object can do $role!\n";
191 my $class = search_class_by_role($object, 'FooRole');
192 print "Nearest class with 'FooRole' is $class\n";
196 This is a set of utility functions to help working with Moose classes, and
197 is used internally by Moose itself. The goal is to provide useful functions
198 that for both Moose users and Moose extenders (MooseX:: authors).
200 This is a relatively new addition to the Moose toolchest, so ideas,
201 suggestions and contributions to this collection are most welcome.
202 See the L<TODO> section below for a list of ideas for possible functions
205 =head1 EXPORTED FUNCTIONS
209 =item B<find_meta ($class_or_obj)>
211 This will attempt to locate a metaclass for the given C<$class_or_obj>
214 =item B<does_role ($class_or_obj, $role_name)>
216 Returns true if C<$class_or_obj> can do the role C<$role_name>.
218 =item B<search_class_by_role ($class_or_obj, $role_name)>
220 Returns first class in precedence list that consumed C<$role_name>.
222 =item B<apply_all_roles ($applicant, @roles)>
224 Given an C<$applicant> (which can somehow be turned into either a
225 metaclass or a metarole) and a list of C<@roles> this will do the
226 right thing to apply the C<@roles> to the C<$applicant>. This is
227 actually used internally by both L<Moose> and L<Moose::Role>, and the
228 C<@roles> will be pre-processed through L<Data::OptList::mkopt>
229 to allow for the additional arguments to be passed.
231 =item B<apply_all_roles_with_method ($applicant, $method, @roles)>
233 This function works just like C<apply_all_roles()>, except it allows
234 you to specify what method will be called on the role metaclass when
235 applying it to the C<$applicant>. This exists primarily so one can use
236 the C<< Moose::Meta::Role->apply_to_metaclass_instance() >> method.
238 =item B<get_all_attribute_values($meta, $instance)>
240 Returns the values of the C<$instance>'s fields keyed by the attribute names.
242 =item B<get_all_init_args($meta, $instance)>
244 Returns a hash reference where the keys are all the attributes' C<init_arg>s
245 and the values are the instance's fields. Attributes without an C<init_arg>
248 =item B<resolve_metaclass_alias($category, $name, %options)>
250 =item B<resolve_metatrait_alias($category, $name, %options)>
252 Resolve a short name like in e.g.
258 to a full class name.
260 =item B<add_method_modifier ($class_or_obj, $modifier_name, $args)>
266 Here is a list of possible functions to write
270 =item discovering original method from modified method
272 =item search for origin class of a method or attribute
278 All complex software has bugs lurking in it, and this module is no
279 exception. If you find a bug please either email me, or add the bug
284 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
286 B<with contributions from:>
288 Robert (phaylon) Sedlacek
292 =head1 COPYRIGHT AND LICENSE
294 Copyright 2007-2008 by Infinity Interactive, Inc.
296 L<http://www.iinteractive.com>
298 This library is free software; you can redistribute it and/or modify
299 it under the same terms as Perl itself.