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