lib/Moose/Util.pm

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