8 use Scalar::Util 'blessed';
11 our $VERSION = '0.89_02';
12 $VERSION = eval $VERSION;
13 our $AUTHORITY = 'cpan:STEVAN';
22 get_all_attribute_values
23 resolve_metatrait_alias
24 resolve_metaclass_alias
31 Sub::Exporter::setup_exporter({
33 groups => { all => \@exports }
36 ## some utils for the utils ...
38 sub find_meta { Class::MOP::class_of(@_) }
43 my ($class_or_obj, $role) = @_;
45 my $meta = find_meta($class_or_obj);
47 return unless defined $meta;
48 return unless $meta->can('does_role');
49 return 1 if $meta->does_role($role);
53 sub search_class_by_role {
54 my ($class_or_obj, $role_name) = @_;
56 my $meta = find_meta($class_or_obj);
58 return unless defined $meta;
60 foreach my $class ($meta->class_precedence_list) {
62 my $_meta = find_meta($class);
64 next unless defined $_meta;
66 foreach my $role (@{ $_meta->roles || [] }) {
67 return $class if $role->name eq $role_name;
74 # this can possibly behave in unexpected ways because the roles being composed
75 # before being applied could differ from call to call; I'm not sure if or how
76 # to document this possible quirk.
77 sub ensure_all_roles {
78 my $applicant = shift;
79 _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
83 my $applicant = shift;
84 _apply_all_roles($applicant, undef, @_);
87 sub _apply_all_roles {
88 my $applicant = shift;
89 my $role_filter = shift;
93 Moose->throw_error("Must specify at least one role to apply to $applicant");
96 my $roles = Data::OptList::mkopt( [@_] );
98 foreach my $role (@$roles) {
99 Class::MOP::load_class( $role->[0] );
100 my $meta = Class::MOP::class_of( $role->[0] );
102 unless ($meta && $meta->isa('Moose::Meta::Role') ) {
104 Moose->throw_error( "You can only consume roles, "
106 . " is not a Moose role" );
110 if ( defined $role_filter ) {
111 @$roles = grep { local $_ = $_->[0]; $role_filter->() } @$roles;
114 return unless @$roles;
116 my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
118 if ( scalar @$roles == 1 ) {
119 my ( $role, $params ) = @{ $roles->[0] };
120 my $role_meta = Class::MOP::class_of($role);
121 $role_meta->apply( $meta, ( defined $params ? %$params : () ) );
124 Moose::Meta::Role->combine( @$roles )->apply($meta);
128 # instance deconstruction ...
130 sub get_all_attribute_values {
131 my ($class, $instance) = @_;
133 map { $_->name => $_->get_value($instance) }
134 grep { $_->has_value($instance) }
135 $class->get_all_attributes
139 sub get_all_init_args {
140 my ($class, $instance) = @_;
142 map { $_->init_arg => $_->get_value($instance) }
143 grep { $_->has_value($instance) }
144 grep { defined($_->init_arg) }
145 $class->get_all_attributes
149 sub resolve_metatrait_alias {
150 return resolve_metaclass_alias( @_, trait => 1 );
153 sub _build_alias_package_name {
154 my ($type, $name, $trait) = @_;
155 return 'Moose::Meta::'
158 . ( $trait ? 'Trait::' : '' )
165 sub resolve_metaclass_alias {
166 my ( $type, $metaclass_name, %options ) = @_;
168 my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
169 return $cache{$cache_key}{$metaclass_name}
170 if $cache{$cache_key}{$metaclass_name};
172 my $possible_full_name = _build_alias_package_name(
173 $type, $metaclass_name, $options{trait}
176 my $loaded_class = Class::MOP::load_first_existing_class(
181 return $cache{$cache_key}{$metaclass_name}
182 = $loaded_class->can('register_implementation')
183 ? $loaded_class->register_implementation
188 sub add_method_modifier {
189 my ( $class_or_obj, $modifier_name, $args ) = @_;
191 = $class_or_obj->can('add_before_method_modifier')
193 : find_meta($class_or_obj);
194 my $code = pop @{$args};
195 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
196 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
197 if ( $method_modifier_type eq 'Regexp' ) {
198 my @all_methods = $meta->get_all_methods;
200 = grep { $_->name =~ @{$args}[0] } @all_methods;
201 $meta->$add_modifier_method( $_->name, $code )
202 for @matched_methods;
206 $meta->$add_modifier_method( $_, $code ) for @{$args};
213 return $items[0] if @items == 1;
214 return "$items[0] and $items[1]" if @items == 2;
216 my $tail = pop @items;
217 my $list = join ', ', @items;
218 $list .= ', and ' . $tail;
224 my $level = @_ ? ($_[0] + 1) : 2;
226 @info{qw(package file line)} = caller($level);
231 my ($type, $name, $trait, $for) = @_;
232 my $package = _build_alias_package_name($type, $name, $trait);
233 Class::MOP::Class->initialize($package)->add_method(
234 register_implementation => sub { $for }
238 sub meta_attribute_alias {
239 my ($to, $from) = @_;
241 my $meta = Class::MOP::class_of($from);
242 my $trait = $meta->isa('Moose::Meta::Role');
243 _create_alias('Attribute', $to, $trait, $from);
246 sub meta_class_alias {
247 my ($to, $from) = @_;
249 my $meta = Class::MOP::class_of($from);
250 my $trait = $meta->isa('Moose::Meta::Role');
251 _create_alias('Class', $to, $trait, $from);
262 Moose::Util - Utilities for working with Moose classes
266 use Moose::Util qw/find_meta does_role search_class_by_role/;
268 my $meta = find_meta($object) || die "No metaclass found";
270 if (does_role($object, $role)) {
271 print "The object can do $role!\n";
274 my $class = search_class_by_role($object, 'FooRole');
275 print "Nearest class with 'FooRole' is $class\n";
279 This module provides a set of utility functions. Many of these
280 functions are intended for use in Moose itself or MooseX modules, but
281 some of them may be useful for use in your own code.
283 =head1 EXPORTED FUNCTIONS
287 =item B<find_meta($class_or_obj)>
289 This method takes a class name or object and attempts to find a
290 metaclass for the class, if one exists. It will B<not> create one if it
293 =item B<does_role($class_or_obj, $role_name)>
295 Returns true if C<$class_or_obj> does the given C<$role_name>.
297 The class must already have a metaclass for this to work.
299 =item B<search_class_by_role($class_or_obj, $role_name)>
301 Returns the first class in the class's precedence list that does
302 C<$role_name>, if any.
304 The class must already have a metaclass for this to work.
306 =item B<apply_all_roles($applicant, @roles)>
308 This function applies one or more roles to the given C<$applicant> The
309 applicant can be a role name, class name, or object.
311 The C<$applicant> must already have a metaclass object.
313 The list of C<@roles> should be a list of names, each of which can be
314 followed by an optional hash reference of options (C<-excludes> and
317 =item B<ensure_all_roles($applicant, @roles)>
319 This function is similar to L</apply_all_roles>, but only applies roles that
320 C<$applicant> does not already consume.
322 =item B<get_all_attribute_values($meta, $instance)>
324 Returns a hash reference containing all of the C<$instance>'s
325 attributes. The keys are attribute names.
327 =item B<get_all_init_args($meta, $instance)>
329 Returns a hash reference containing all of the C<init_arg> values for
330 the instance's attributes. The values are the associated attribute
331 values. If an attribute does not have a defined C<init_arg>, it is
334 This could be useful in cloning an object.
336 =item B<resolve_metaclass_alias($category, $name, %options)>
338 =item B<resolve_metatrait_alias($category, $name, %options)>
340 Resolves a short name to a full class name. Short names are often used
341 when specifying the C<metaclass> or C<traits> option for an attribute:
347 The name resolution mechanism is covered in
348 L<Moose/Metaclass and Trait Name Resolution>.
350 =item B<english_list(@items)>
352 Given a list of scalars, turns them into a proper list in English
353 ("one and two", "one, two, three, and four"). This is used to help us
354 make nicer error messages.
356 =item B<meta_class_alias($to[, $from])>
358 =item B<meta_attribute_alias($to[, $from])>
360 Create an alias from the class C<$from> (or the current package, if
361 C<$from> is unspecified), so that
362 L<Moose/Metaclass and Trait Name Resolution> works properly.
368 Here is a list of possible functions to write
372 =item discovering original method from modified method
374 =item search for origin class of a method or attribute
380 All complex software has bugs lurking in it, and this module is no
381 exception. If you find a bug please either email me, or add the bug
386 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
388 B<with contributions from:>
390 Robert (phaylon) Sedlacek
394 =head1 COPYRIGHT AND LICENSE
396 Copyright 2007-2009 by Infinity Interactive, Inc.
398 L<http://www.iinteractive.com>
400 This library is free software; you can redistribute it and/or modify
401 it under the same terms as Perl itself.