7 use Scalar::Util 'blessed';
11 our $VERSION = '0.55_02';
12 $VERSION = eval $VERSION;
13 our $AUTHORITY = 'cpan:STEVAN';
21 get_all_attribute_values
22 resolve_metatrait_alias
23 resolve_metaclass_alias
27 Sub::Exporter::setup_exporter({
29 groups => { all => \@exports }
32 ## some utils for the utils ...
36 return Class::MOP::get_metaclass_by_name(blessed($_[0]) || $_[0]);
42 my ($class_or_obj, $role) = @_;
44 my $meta = find_meta($class_or_obj);
46 return unless defined $meta;
47 return unless $meta->can('does_role');
48 return 1 if $meta->does_role($role);
52 sub search_class_by_role {
53 my ($class_or_obj, $role_name) = @_;
55 my $meta = find_meta($class_or_obj);
57 return unless defined $meta;
59 foreach my $class ($meta->class_precedence_list) {
61 my $_meta = find_meta($class);
63 next unless defined $_meta;
65 foreach my $role (@{ $_meta->roles || [] }) {
66 return $class if $role->name eq $role_name;
74 my $applicant = shift;
76 apply_all_roles_with_method( $applicant, 'apply', [@_] );
79 sub apply_all_roles_with_method {
80 my ( $applicant, $apply_method, $role_list ) = @_;
82 confess "Must specify at least one role to apply to $applicant"
85 my $roles = Data::OptList::mkopt($role_list);
87 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
89 foreach my $role_spec (@$roles) {
90 Class::MOP::load_class( $role_spec->[0] );
93 ( $_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role') )
94 || confess "You can only consume roles, "
96 . " is not a Moose role"
99 if ( scalar @$roles == 1 ) {
100 my ( $role, $params ) = @{ $roles->[0] };
101 $role->meta->$apply_method( $meta,
102 ( defined $params ? %$params : () ) );
105 Moose::Meta::Role->combine( @$roles )->$apply_method($meta);
109 # instance deconstruction ...
111 sub get_all_attribute_values {
112 my ($class, $instance) = @_;
114 map { $_->name => $_->get_value($instance) }
115 grep { $_->has_value($instance) }
116 $class->compute_all_applicable_attributes
120 sub get_all_init_args {
121 my ($class, $instance) = @_;
123 map { $_->init_arg => $_->get_value($instance) }
124 grep { $_->has_value($instance) }
125 grep { defined($_->init_arg) }
126 $class->compute_all_applicable_attributes
130 sub resolve_metatrait_alias {
131 resolve_metaclass_alias( @_, trait => 1 );
134 sub resolve_metaclass_alias {
135 my ( $type, $metaclass_name, %options ) = @_;
137 if ( my $resolved = eval {
138 my $possible_full_name = 'Moose::Meta::' . $type . '::Custom::' . ( $options{trait} ? "Trait::" : "" ) . $metaclass_name;
140 Class::MOP::load_class($possible_full_name);
142 $possible_full_name->can('register_implementation')
143 ? $possible_full_name->register_implementation
144 : $possible_full_name;
148 Class::MOP::load_class($metaclass_name);
149 return $metaclass_name;
153 sub add_method_modifier {
154 my ( $class_or_obj, $modifier_name, $args ) = @_;
155 my $meta = find_meta($class_or_obj);
156 my $code = pop @{$args};
157 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
158 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
159 if ( $method_modifier_type eq 'Regexp' ) {
160 my @all_methods = $meta->get_all_methods;
162 = grep { $_->name =~ @{$args}[0] } @all_methods;
163 $meta->$add_modifier_method( $_->name, $code )
164 for @matched_methods;
168 $meta->$add_modifier_method( $_, $code ) for @{$args};
180 Moose::Util - Utilities for working with Moose classes
184 use Moose::Util qw/find_meta does_role search_class_by_role/;
186 my $meta = find_meta($object) || die "No metaclass found";
188 if (does_role($object, $role)) {
189 print "The object can do $role!\n";
192 my $class = search_class_by_role($object, 'FooRole');
193 print "Nearest class with 'FooRole' is $class\n";
197 This is a set of utility functions to help working with Moose classes, and
198 is used internally by Moose itself. The goal is to provide useful functions
199 that for both Moose users and Moose extenders (MooseX:: authors).
201 This is a relatively new addition to the Moose toolchest, so ideas,
202 suggestions and contributions to this collection are most welcome.
203 See the L<TODO> section below for a list of ideas for possible functions
206 =head1 EXPORTED FUNCTIONS
210 =item B<find_meta ($class_or_obj)>
212 This will attempt to locate a metaclass for the given C<$class_or_obj>
215 =item B<does_role ($class_or_obj, $role_name)>
217 Returns true if C<$class_or_obj> can do the role C<$role_name>.
219 =item B<search_class_by_role ($class_or_obj, $role_name)>
221 Returns first class in precedence list that consumed C<$role_name>.
223 =item B<apply_all_roles ($applicant, @roles)>
225 Given an C<$applicant> (which can somehow be turned into either a
226 metaclass or a metarole) and a list of C<@roles> this will do the
227 right thing to apply the C<@roles> to the C<$applicant>. This is
228 actually used internally by both L<Moose> and L<Moose::Role>, and the
229 C<@roles> will be pre-processed through L<Data::OptList::mkopt>
230 to allow for the additional arguments to be passed.
232 =item B<apply_all_roles_with_method ($applicant, $method, @roles)>
234 This function works just like C<apply_all_roles()>, except it allows
235 you to specify what method will be called on the role metaclass when
236 applying it to the C<$applicant>. This exists primarily so one can use
237 the C<< Moose::Meta::Role->apply_to_metaclass_instance() >> method.
239 =item B<get_all_attribute_values($meta, $instance)>
241 Returns the values of the C<$instance>'s fields keyed by the attribute names.
243 =item B<get_all_init_args($meta, $instance)>
245 Returns a hash reference where the keys are all the attributes' C<init_arg>s
246 and the values are the instance's fields. Attributes without an C<init_arg>
249 =item B<resolve_metaclass_alias($category, $name, %options)>
251 =item B<resolve_metatrait_alias($category, $name, %options)>
253 Resolve a short name like in e.g.
259 to a full class name.
261 =item B<add_method_modifier ($class_or_obj, $modifier_name, $args)>
267 Here is a list of possible functions to write
271 =item discovering original method from modified method
273 =item search for origin class of a method or attribute
279 All complex software has bugs lurking in it, and this module is no
280 exception. If you find a bug please either email me, or add the bug
285 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
287 B<with contributions from:>
289 Robert (phaylon) Sedlacek
293 =head1 COPYRIGHT AND LICENSE
295 Copyright 2007-2008 by Infinity Interactive, Inc.
297 L<http://www.iinteractive.com>
299 This library is free software; you can redistribute it and/or modify
300 it under the same terms as Perl itself.