lib/Moose/Util.pm

   1 package Moose::Util;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Data::OptList;
   7 use Sub::Exporter;
   8 use Scalar::Util 'blessed';
   9 use Class::MOP   0.60;
  10
  11 our $VERSION   = '1.09';
  12 $VERSION = eval $VERSION;
  13 our $AUTHORITY = 'cpan:STEVAN';
  14
  15 my @exports = qw[
  16     find_meta
  17     does_role
  18     search_class_by_role
  19     ensure_all_roles
  20     apply_all_roles
  21     with_traits
  22     get_all_init_args
  23     get_all_attribute_values
  24     resolve_metatrait_alias
  25     resolve_metaclass_alias
  26     add_method_modifier
  27     english_list
  28     meta_attribute_alias
  29     meta_class_alias
  30 ];
  31
  32 Sub::Exporter::setup_exporter({
  33     exports => \@exports,
  34     groups  => { all => \@exports }
  35 });
  36
  37 ## some utils for the utils ...
  38
  39 sub find_meta { Class::MOP::class_of(@_) }
  40
  41 ## the functions ...
  42
  43 sub does_role {
  44     my ($class_or_obj, $role) = @_;
  45
  46     my $meta = find_meta($class_or_obj);
  47
  48     return unless defined $meta;
  49     return unless $meta->can('does_role');
  50     return 1 if $meta->does_role($role);
  51     return;
  52 }
  53
  54 sub search_class_by_role {
  55     my ($class_or_obj, $role) = @_;
  56
  57     my $meta = find_meta($class_or_obj);
  58
  59     return unless defined $meta;
  60
  61     my $role_name = blessed $role ? $role->name : $role;
  62
  63     foreach my $class ($meta->class_precedence_list) {
  64
  65         my $_meta = find_meta($class);
  66
  67         next unless defined $_meta;
  68
  69         foreach my $role (@{ $_meta->roles || [] }) {
  70             return $class if $role->name eq $role_name;
  71         }
  72     }
  73
  74     return;
  75 }
  76
  77 # this can possibly behave in unexpected ways because the roles being composed
  78 # before being applied could differ from call to call; I'm not sure if or how
  79 # to document this possible quirk.
  80 sub ensure_all_roles {
  81     my $applicant = shift;
  82     _apply_all_roles($applicant, sub { !does_role($applicant, $_) }, @_);
  83 }
  84
  85 sub apply_all_roles {
  86     my $applicant = shift;
  87     _apply_all_roles($applicant, undef, @_);
  88 }
  89
  90 sub _apply_all_roles {
  91     my $applicant = shift;
  92     my $role_filter = shift;
  93
  94     unless (@_) {
  95         require Moose;
  96         Moose->throw_error("Must specify at least one role to apply to $applicant");
  97     }
  98
  99     my $roles = Data::OptList::mkopt( [@_] );
 100
 101     my @role_metas;
 102     foreach my $role (@$roles) {
 103         my $meta;
 104
 105         if ( blessed $role->[0] ) {
 106             $meta = $role->[0];
 107         }
 108         else {
 109             Class::MOP::load_class( $role->[0] , $role->[1] );
 110             $meta = Class::MOP::class_of( $role->[0] );
 111         }
 112
 113         unless ($meta && $meta->isa('Moose::Meta::Role') ) {
 114             require Moose;
 115             Moose->throw_error( "You can only consume roles, "
 116                     . $role->[0]
 117                     . " is not a Moose role" );
 118         }
 119
 120         push @role_metas, [ $meta, $role->[1] ];
 121     }
 122
 123     if ( defined $role_filter ) {
 124         @role_metas = grep { local $_ = $_->[0]; $role_filter->() } @role_metas;
 125     }
 126
 127     return unless @role_metas;
 128
 129     my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
 130
 131     if ( scalar @role_metas == 1 ) {
 132         my ( $role, $params ) = @{ $role_metas[0] };
 133         $role->apply( $meta, ( defined $params ? %$params : () ) );
 134     }
 135     else {
 136         Moose::Meta::Role->combine(@role_metas)->apply($meta);
 137     }
 138 }
 139
 140 sub with_traits {
 141     my ($class, @roles) = @_;
 142     return $class unless @roles;
 143     return Moose::Meta::Class->create_anon_class(
 144         superclasses => [$class],
 145         roles        => \@roles,
 146         cache        => 1,
 147     )->name;
 148 }
 149
 150 # instance deconstruction ...
 151
 152 sub get_all_attribute_values {
 153     my ($class, $instance) = @_;
 154     return +{
 155         map { $_->name => $_->get_value($instance) }
 156             grep { $_->has_value($instance) }
 157                 $class->get_all_attributes
 158     };
 159 }
 160
 161 sub get_all_init_args {
 162     my ($class, $instance) = @_;
 163     return +{
 164         map { $_->init_arg => $_->get_value($instance) }
 165             grep { $_->has_value($instance) }
 166                 grep { defined($_->init_arg) }
 167                     $class->get_all_attributes
 168     };
 169 }
 170
 171 sub resolve_metatrait_alias {
 172     return resolve_metaclass_alias( @_, trait => 1 );
 173 }
 174
 175 sub _build_alias_package_name {
 176     my ($type, $name, $trait) = @_;
 177     return 'Moose::Meta::'
 178          . $type
 179          . '::Custom::'
 180          . ( $trait ? 'Trait::' : '' )
 181          . $name;
 182 }
 183
 184 {
 185     my %cache;
 186
 187     sub resolve_metaclass_alias {
 188         my ( $type, $metaclass_name, %options ) = @_;
 189
 190         my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
 191         return $cache{$cache_key}{$metaclass_name}
 192             if $cache{$cache_key}{$metaclass_name};
 193
 194         my $possible_full_name = _build_alias_package_name(
 195             $type, $metaclass_name, $options{trait}
 196         );
 197
 198         my $loaded_class = Class::MOP::load_first_existing_class(
 199             $possible_full_name,
 200             $metaclass_name
 201         );
 202
 203         return $cache{$cache_key}{$metaclass_name}
 204             = $loaded_class->can('register_implementation')
 205             ? $loaded_class->register_implementation
 206             : $loaded_class;
 207     }
 208 }
 209
 210 sub add_method_modifier {
 211     my ( $class_or_obj, $modifier_name, $args ) = @_;
 212     my $meta
 213         = $class_or_obj->can('add_before_method_modifier')
 214         ? $class_or_obj
 215         : find_meta($class_or_obj);
 216     my $code                = pop @{$args};
 217     my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
 218     if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
 219         if ( $method_modifier_type eq 'Regexp' ) {
 220             my @all_methods = $meta->get_all_methods;
 221             my @matched_methods
 222                 = grep { $_->name =~ @{$args}[0] } @all_methods;
 223             $meta->$add_modifier_method( $_->name, $code )
 224                 for @matched_methods;
 225         }
 226         elsif ($method_modifier_type eq 'ARRAY') {
 227             $meta->$add_modifier_method( $_, $code ) for @{$args->[0]};
 228         }
 229         else {
 230             $meta->throw_error(
 231                 sprintf(
 232                     "Methods passed to %s must be provided as a list, arrayref or regex, not %s",
 233                     $modifier_name,
 234                     $method_modifier_type,
 235                 )
 236             );
 237         }
 238     }
 239     else {
 240         $meta->$add_modifier_method( $_, $code ) for @{$args};
 241     }
 242 }
 243
 244 sub english_list {
 245     my @items = sort @_;
 246
 247     return $items[0] if @items == 1;
 248     return "$items[0] and $items[1]" if @items == 2;
 249
 250     my $tail = pop @items;
 251     my $list = join ', ', @items;
 252     $list .= ', and ' . $tail;
 253
 254     return $list;
 255 }
 256
 257 sub _caller_info {
 258     my $level = @_ ? ($_[0] + 1) : 2;
 259     my %info;
 260     @info{qw(package file line)} = caller($level);
 261     return \%info;
 262 }
 263
 264 sub _create_alias {
 265     my ($type, $name, $trait, $for) = @_;
 266     my $package = _build_alias_package_name($type, $name, $trait);
 267     Class::MOP::Class->initialize($package)->add_method(
 268         register_implementation => sub { $for }
 269     );
 270 }
 271
 272 sub meta_attribute_alias {
 273     my ($to, $from) = @_;
 274     $from ||= caller;
 275     my $meta = Class::MOP::class_of($from);
 276     my $trait = $meta->isa('Moose::Meta::Role');
 277     _create_alias('Attribute', $to, $trait, $from);
 278 }
 279
 280 sub meta_class_alias {
 281     my ($to, $from) = @_;
 282     $from ||= caller;
 283     my $meta = Class::MOP::class_of($from);
 284     my $trait = $meta->isa('Moose::Meta::Role');
 285     _create_alias('Class', $to, $trait, $from);
 286 }
 287
 288 1;
 289
 290 __END__
 291
 292 =pod
 293
 294 =head1 NAME
 295
 296 Moose::Util - Utilities for working with Moose classes
 297
 298 =head1 SYNOPSIS
 299
 300   use Moose::Util qw/find_meta does_role search_class_by_role/;
 301
 302   my $meta = find_meta($object) || die "No metaclass found";
 303
 304   if (does_role($object, $role)) {
 305     print "The object can do $role!\n";
 306   }
 307
 308   my $class = search_class_by_role($object, 'FooRole');
 309   print "Nearest class with 'FooRole' is $class\n";
 310
 311 =head1 DESCRIPTION
 312
 313 This module provides a set of utility functions. Many of these
 314 functions are intended for use in Moose itself or MooseX modules, but
 315 some of them may be useful for use in your own code.
 316
 317 =head1 EXPORTED FUNCTIONS
 318
 319 =over 4
 320
 321 =item B<find_meta($class_or_obj)>
 322
 323 This method takes a class name or object and attempts to find a
 324 metaclass for the class, if one exists. It will B<not> create one if it
 325 does not yet exist.
 326
 327 =item B<does_role($class_or_obj, $role_or_obj)>
 328
 329 Returns true if C<$class_or_obj> does the given C<$role_or_obj>. The role can
 330 be provided as a name or a L<Moose::Meta::Role> object.
 331
 332 The class must already have a metaclass for this to work. If it doesn't, this
 333 function simply returns false.
 334
 335 =item B<search_class_by_role($class_or_obj, $role_or_obj)>
 336
 337 Returns the first class in the class's precedence list that does
 338 C<$role_or_obj>, if any. The role can be either a name or a
 339 L<Moose::Meta::Role> object.
 340
 341 The class must already have a metaclass for this to work.
 342
 343 =item B<apply_all_roles($applicant, @roles)>
 344
 345 This function applies one or more roles to the given C<$applicant> The
 346 applicant can be a role name, class name, or object.
 347
 348 The C<$applicant> must already have a metaclass object.
 349
 350 The list of C<@roles> should a list of names or L<Moose::Meta::Role> objects,
 351 each of which can be followed by an optional hash reference of options
 352 (C<-excludes> and C<-alias>).
 353
 354 =item B<ensure_all_roles($applicant, @roles)>
 355
 356 This function is similar to L</apply_all_roles>, but only applies roles that
 357 C<$applicant> does not already consume.
 358
 359 =item B<with_traits($class_name, @role_names)>
 360
 361 This function creates a new class from C<$class_name> with each of
 362 C<@role_names> applied. It returns the name of the new class.
 363
 364 =item B<get_all_attribute_values($meta, $instance)>
 365
 366 Returns a hash reference containing all of the C<$instance>'s
 367 attributes. The keys are attribute names.
 368
 369 =item B<get_all_init_args($meta, $instance)>
 370
 371 Returns a hash reference containing all of the C<init_arg> values for
 372 the instance's attributes. The values are the associated attribute
 373 values. If an attribute does not have a defined C<init_arg>, it is
 374 skipped.
 375
 376 This could be useful in cloning an object.
 377
 378 =item B<resolve_metaclass_alias($category, $name, %options)>
 379
 380 =item B<resolve_metatrait_alias($category, $name, %options)>
 381
 382 Resolves a short name to a full class name. Short names are often used
 383 when specifying the C<metaclass> or C<traits> option for an attribute:
 384
 385     has foo => (
 386         metaclass => "Bar",
 387     );
 388
 389 The name resolution mechanism is covered in
 390 L<Moose/Metaclass and Trait Name Resolution>.
 391
 392 =item B<meta_class_alias($to[, $from])>
 393
 394 =item B<meta_attribute_alias($to[, $from])>
 395
 396 Create an alias from the class C<$from> (or the current package, if
 397 C<$from> is unspecified), so that
 398 L<Moose/Metaclass and Trait Name Resolution> works properly.
 399
 400 =item B<english_list(@items)>
 401
 402 Given a list of scalars, turns them into a proper list in English
 403 ("one and two", "one, two, three, and four"). This is used to help us
 404 make nicer error messages.
 405
 406 =back
 407
 408 =head1 TODO
 409
 410 Here is a list of possible functions to write
 411
 412 =over 4
 413
 414 =item discovering original method from modified method
 415
 416 =item search for origin class of a method or attribute
 417
 418 =back
 419
 420 =head1 BUGS
 421
 422 See L<Moose/BUGS> for details on reporting bugs.
 423
 424 =head1 AUTHOR
 425
 426 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
 427
 428 B<with contributions from:>
 429
 430 Robert (phaylon) Sedlacek
 431
 432 Stevan Little
 433
 434 =head1 COPYRIGHT AND LICENSE
 435
 436 Copyright 2007-2009 by Infinity Interactive, Inc.
 437
 438 L<http://www.iinteractive.com>
 439
 440 This library is free software; you can redistribute it and/or modify
 441 it under the same terms as Perl itself.
 442
 443 =cut
 444