8 use Scalar::Util 'blessed';
11 our $VERSION = '0.88';
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 ) = @_;
190 my $meta = find_meta($class_or_obj);
191 my $code = pop @{$args};
192 my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
193 if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
194 if ( $method_modifier_type eq 'Regexp' ) {
195 my @all_methods = $meta->get_all_methods;
197 = grep { $_->name =~ @{$args}[0] } @all_methods;
198 $meta->$add_modifier_method( $_->name, $code )
199 for @matched_methods;
203 $meta->$add_modifier_method( $_, $code ) for @{$args};
210 return $items[0] if @items == 1;
211 return "$items[0] and $items[1]" if @items == 2;
213 my $tail = pop @items;
214 my $list = join ', ', @items;
215 $list .= ', and ' . $tail;
221 my $level = @_ ? ($_[0] + 1) : 2;
223 @info{qw(package file line)} = caller($level);
228 my ($type, $name, $trait, $for) = @_;
229 my $package = _build_alias_package_name($type, $name, $trait);
230 Class::MOP::Class->initialize($package)->add_method(
231 register_implementation => sub { $for }
235 sub meta_attribute_alias {
236 my ($to, $from) = @_;
238 my $meta = Class::MOP::class_of($from);
239 my $trait = $meta->isa('Moose::Meta::Role');
240 _create_alias('Attribute', $to, $trait, $from);
243 sub meta_class_alias {
244 my ($to, $from) = @_;
246 my $meta = Class::MOP::class_of($from);
247 my $trait = $meta->isa('Moose::Meta::Role');
248 _create_alias('Class', $to, $trait, $from);
259 Moose::Util - Utilities for working with Moose classes
263 use Moose::Util qw/find_meta does_role search_class_by_role/;
265 my $meta = find_meta($object) || die "No metaclass found";
267 if (does_role($object, $role)) {
268 print "The object can do $role!\n";
271 my $class = search_class_by_role($object, 'FooRole');
272 print "Nearest class with 'FooRole' is $class\n";
276 This module provides a set of utility functions. Many of these
277 functions are intended for use in Moose itself or MooseX modules, but
278 some of them may be useful for use in your own code.
280 =head1 EXPORTED FUNCTIONS
284 =item B<find_meta($class_or_obj)>
286 This method takes a class name or object and attempts to find a
287 metaclass for the class, if one exists. It will B<not> create one if it
290 =item B<does_role($class_or_obj, $role_name)>
292 Returns true if C<$class_or_obj> does the given C<$role_name>.
294 The class must already have a metaclass for this to work.
296 =item B<search_class_by_role($class_or_obj, $role_name)>
298 Returns the first class in the class's precedence list that does
299 C<$role_name>, if any.
301 The class must already have a metaclass for this to work.
303 =item B<apply_all_roles($applicant, @roles)>
305 This function applies one or more roles to the given C<$applicant> The
306 applicant can be a role name, class name, or object.
308 The C<$applicant> must already have a metaclass object.
310 The list of C<@roles> should be a list of names, each of which can be
311 followed by an optional hash reference of options (C<excludes> and
314 =item B<ensure_all_roles($applicant, @roles)>
316 This function is similar to L</apply_all_roles>, but only applies roles that
317 C<$applicant> does not already consume.
319 =item B<get_all_attribute_values($meta, $instance)>
321 Returns a hash reference containing all of the C<$instance>'s
322 attributes. The keys are attribute names.
324 =item B<get_all_init_args($meta, $instance)>
326 Returns a hash reference containing all of the C<init_arg> values for
327 the instance's attributes. The values are the associated attribute
328 values. If an attribute does not have a defined C<init_arg>, it is
331 This could be useful in cloning an object.
333 =item B<resolve_metaclass_alias($category, $name, %options)>
335 =item B<resolve_metatrait_alias($category, $name, %options)>
337 Resolves a short name to a full class name. Short names are often used
338 when specifying the C<metaclass> or C<traits> option for an attribute:
344 The name resolution mechanism is covered in
345 L<Moose/Metaclass and Trait Name Resolution>.
347 =item B<english_list(@items)>
349 Given a list of scalars, turns them into a proper list in English
350 ("one and two", "one, two, three, and four"). This is used to help us
351 make nicer error messages.
353 =item B<meta_class_alias($to[, $from])>
355 =item B<meta_attribute_alias($to[, $from])>
357 Create an alias from the class C<$from> (or the current package, if
358 C<$from> is unspecified), so that
359 L<Moose/Metaclass and Trait Name Resolution> works properly.
365 Here is a list of possible functions to write
369 =item discovering original method from modified method
371 =item search for origin class of a method or attribute
377 All complex software has bugs lurking in it, and this module is no
378 exception. If you find a bug please either email me, or add the bug
383 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
385 B<with contributions from:>
387 Robert (phaylon) Sedlacek
391 =head1 COPYRIGHT AND LICENSE
393 Copyright 2007-2009 by Infinity Interactive, Inc.
395 L<http://www.iinteractive.com>
397 This library is free software; you can redistribute it and/or modify
398 it under the same terms as Perl itself.