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.89';
  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_name) = @_;
  55
  56     my $meta = find_meta($class_or_obj);
  57
  58     return unless defined $meta;
  59
  60     foreach my $class ($meta->class_precedence_list) {
  61
  62         my $_meta = find_meta($class);
  63
  64         next unless defined $_meta;
  65
  66         foreach my $role (@{ $_meta->roles || [] }) {
  67             return $class if $role->name eq $role_name;
  68         }
  69     }
  70
  71     return;
  72 }
  73
  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, $_) }, @_);
  80 }
  81
  82 sub apply_all_roles {
  83     my $applicant = shift;
  84     _apply_all_roles($applicant, undef, @_);
  85 }
  86
  87 sub _apply_all_roles {
  88     my $applicant = shift;
  89     my $role_filter = shift;
  90
  91     unless (@_) {
  92         require Moose;
  93         Moose->throw_error("Must specify at least one role to apply to $applicant");
  94     }
  95
  96     my $roles = Data::OptList::mkopt( [@_] );
  97
  98     foreach my $role (@$roles) {
  99         Class::MOP::load_class( $role->[0] );
 100         my $meta = Class::MOP::class_of( $role->[0] );
 101
 102         unless ($meta && $meta->isa('Moose::Meta::Role') ) {
 103             require Moose;
 104             Moose->throw_error( "You can only consume roles, "
 105                     . $role->[0]
 106                     . " is not a Moose role" );
 107         }
 108     }
 109
 110     if ( defined $role_filter ) {
 111         @$roles = grep { local $_ = $_->[0]; $role_filter->() } @$roles;
 112     }
 113
 114     return unless @$roles;
 115
 116     my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
 117
 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 : () ) );
 122     }
 123     else {
 124         Moose::Meta::Role->combine( @$roles )->apply($meta);
 125     }
 126 }
 127
 128 # instance deconstruction ...
 129
 130 sub get_all_attribute_values {
 131     my ($class, $instance) = @_;
 132     return +{
 133         map { $_->name => $_->get_value($instance) }
 134             grep { $_->has_value($instance) }
 135                 $class->get_all_attributes
 136     };
 137 }
 138
 139 sub get_all_init_args {
 140     my ($class, $instance) = @_;
 141     return +{
 142         map { $_->init_arg => $_->get_value($instance) }
 143             grep { $_->has_value($instance) }
 144                 grep { defined($_->init_arg) }
 145                     $class->get_all_attributes
 146     };
 147 }
 148
 149 sub resolve_metatrait_alias {
 150     return resolve_metaclass_alias( @_, trait => 1 );
 151 }
 152
 153 sub _build_alias_package_name {
 154     my ($type, $name, $trait) = @_;
 155     return 'Moose::Meta::'
 156          . $type
 157          . '::Custom::'
 158          . ( $trait ? 'Trait::' : '' )
 159          . $name;
 160 }
 161
 162 {
 163     my %cache;
 164
 165     sub resolve_metaclass_alias {
 166         my ( $type, $metaclass_name, %options ) = @_;
 167
 168         my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );
 169         return $cache{$cache_key}{$metaclass_name}
 170             if $cache{$cache_key}{$metaclass_name};
 171
 172         my $possible_full_name = _build_alias_package_name(
 173             $type, $metaclass_name, $options{trait}
 174         );
 175
 176         my $loaded_class = Class::MOP::load_first_existing_class(
 177             $possible_full_name,
 178             $metaclass_name
 179         );
 180
 181         return $cache{$cache_key}{$metaclass_name}
 182             = $loaded_class->can('register_implementation')
 183             ? $loaded_class->register_implementation
 184             : $loaded_class;
 185     }
 186 }
 187
 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;
 196             my @matched_methods
 197                 = grep { $_->name =~ @{$args}[0] } @all_methods;
 198             $meta->$add_modifier_method( $_->name, $code )
 199                 for @matched_methods;
 200         }
 201     }
 202     else {
 203         $meta->$add_modifier_method( $_, $code ) for @{$args};
 204     }
 205 }
 206
 207 sub english_list {
 208     my @items = sort @_;
 209
 210     return $items[0] if @items == 1;
 211     return "$items[0] and $items[1]" if @items == 2;
 212
 213     my $tail = pop @items;
 214     my $list = join ', ', @items;
 215     $list .= ', and ' . $tail;
 216
 217     return $list;
 218 }
 219
 220 sub _caller_info {
 221     my $level = @_ ? ($_[0] + 1) : 2;
 222     my %info;
 223     @info{qw(package file line)} = caller($level);
 224     return \%info;
 225 }
 226
 227 sub _create_alias {
 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 }
 232     );
 233 }
 234
 235 sub meta_attribute_alias {
 236     my ($to, $from) = @_;
 237     $from ||= caller;
 238     my $meta = Class::MOP::class_of($from);
 239     my $trait = $meta->isa('Moose::Meta::Role');
 240     _create_alias('Attribute', $to, $trait, $from);
 241 }
 242
 243 sub meta_class_alias {
 244     my ($to, $from) = @_;
 245     $from ||= caller;
 246     my $meta = Class::MOP::class_of($from);
 247     my $trait = $meta->isa('Moose::Meta::Role');
 248     _create_alias('Class', $to, $trait, $from);
 249 }
 250
 251 1;
 252
 253 __END__
 254
 255 =pod
 256
 257 =head1 NAME
 258
 259 Moose::Util - Utilities for working with Moose classes
 260
 261 =head1 SYNOPSIS
 262
 263   use Moose::Util qw/find_meta does_role search_class_by_role/;
 264
 265   my $meta = find_meta($object) || die "No metaclass found";
 266
 267   if (does_role($object, $role)) {
 268     print "The object can do $role!\n";
 269   }
 270
 271   my $class = search_class_by_role($object, 'FooRole');
 272   print "Nearest class with 'FooRole' is $class\n";
 273
 274 =head1 DESCRIPTION
 275
 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.
 279
 280 =head1 EXPORTED FUNCTIONS
 281
 282 =over 4
 283
 284 =item B<find_meta($class_or_obj)>
 285
 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
 288 does not yet exist.
 289
 290 =item B<does_role($class_or_obj, $role_name)>
 291
 292 Returns true if C<$class_or_obj> does the given C<$role_name>.
 293
 294 The class must already have a metaclass for this to work.
 295
 296 =item B<search_class_by_role($class_or_obj, $role_name)>
 297
 298 Returns the first class in the class's precedence list that does
 299 C<$role_name>, if any.
 300
 301 The class must already have a metaclass for this to work.
 302
 303 =item B<apply_all_roles($applicant, @roles)>
 304
 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.
 307
 308 The C<$applicant> must already have a metaclass object.
 309
 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
 312 C<alias>).
 313
 314 =item B<ensure_all_roles($applicant, @roles)>
 315
 316 This function is similar to L</apply_all_roles>, but only applies roles that
 317 C<$applicant> does not already consume.
 318
 319 =item B<get_all_attribute_values($meta, $instance)>
 320
 321 Returns a hash reference containing all of the C<$instance>'s
 322 attributes. The keys are attribute names.
 323
 324 =item B<get_all_init_args($meta, $instance)>
 325
 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
 329 skipped.
 330
 331 This could be useful in cloning an object.
 332
 333 =item B<resolve_metaclass_alias($category, $name, %options)>
 334
 335 =item B<resolve_metatrait_alias($category, $name, %options)>
 336
 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:
 339
 340     has foo => (
 341         metaclass => "Bar",
 342     );
 343
 344 The name resolution mechanism is covered in
 345 L<Moose/Metaclass and Trait Name Resolution>.
 346
 347 =item B<english_list(@items)>
 348
 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.
 352
 353 =item B<meta_class_alias($to[, $from])>
 354
 355 =item B<meta_attribute_alias($to[, $from])>
 356
 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.
 360
 361 =back
 362
 363 =head1 TODO
 364
 365 Here is a list of possible functions to write
 366
 367 =over 4
 368
 369 =item discovering original method from modified method
 370
 371 =item search for origin class of a method or attribute
 372
 373 =back
 374
 375 =head1 BUGS
 376
 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
 379 to cpan-RT.
 380
 381 =head1 AUTHOR
 382
 383 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
 384
 385 B<with contributions from:>
 386
 387 Robert (phaylon) Sedlacek
 388
 389 Stevan Little
 390
 391 =head1 COPYRIGHT AND LICENSE
 392
 393 Copyright 2007-2009 by Infinity Interactive, Inc.
 394
 395 L<http://www.iinteractive.com>
 396
 397 This library is free software; you can redistribute it and/or modify
 398 it under the same terms as Perl itself.
 399
 400 =cut
 401