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