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_01';
  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
 191         = $class_or_obj->can('add_before_method_modifier')
 192         ? $class_or_obj
 193         : find_meta($class_or_obj);
 194     my $code                = pop @{$args};
 195     my $add_modifier_method = 'add_' . $modifier_name . '_method_modifier';
 196     if ( my $method_modifier_type = ref( @{$args}[0] ) ) {
 197         if ( $method_modifier_type eq 'Regexp' ) {
 198             my @all_methods = $meta->get_all_methods;
 199             my @matched_methods
 200                 = grep { $_->name =~ @{$args}[0] } @all_methods;
 201             $meta->$add_modifier_method( $_->name, $code )
 202                 for @matched_methods;
 203         }
 204     }
 205     else {
 206         $meta->$add_modifier_method( $_, $code ) for @{$args};
 207     }
 208 }
 209
 210 sub english_list {
 211     my @items = sort @_;
 212
 213     return $items[0] if @items == 1;
 214     return "$items[0] and $items[1]" if @items == 2;
 215
 216     my $tail = pop @items;
 217     my $list = join ', ', @items;
 218     $list .= ', and ' . $tail;
 219
 220     return $list;
 221 }
 222
 223 sub _caller_info {
 224     my $level = @_ ? ($_[0] + 1) : 2;
 225     my %info;
 226     @info{qw(package file line)} = caller($level);
 227     return \%info;
 228 }
 229
 230 sub _create_alias {
 231     my ($type, $name, $trait, $for) = @_;
 232     my $package = _build_alias_package_name($type, $name, $trait);
 233     Class::MOP::Class->initialize($package)->add_method(
 234         register_implementation => sub { $for }
 235     );
 236 }
 237
 238 sub meta_attribute_alias {
 239     my ($to, $from) = @_;
 240     $from ||= caller;
 241     my $meta = Class::MOP::class_of($from);
 242     my $trait = $meta->isa('Moose::Meta::Role');
 243     _create_alias('Attribute', $to, $trait, $from);
 244 }
 245
 246 sub meta_class_alias {
 247     my ($to, $from) = @_;
 248     $from ||= caller;
 249     my $meta = Class::MOP::class_of($from);
 250     my $trait = $meta->isa('Moose::Meta::Role');
 251     _create_alias('Class', $to, $trait, $from);
 252 }
 253
 254 1;
 255
 256 __END__
 257
 258 =pod
 259
 260 =head1 NAME
 261
 262 Moose::Util - Utilities for working with Moose classes
 263
 264 =head1 SYNOPSIS
 265
 266   use Moose::Util qw/find_meta does_role search_class_by_role/;
 267
 268   my $meta = find_meta($object) || die "No metaclass found";
 269
 270   if (does_role($object, $role)) {
 271     print "The object can do $role!\n";
 272   }
 273
 274   my $class = search_class_by_role($object, 'FooRole');
 275   print "Nearest class with 'FooRole' is $class\n";
 276
 277 =head1 DESCRIPTION
 278
 279 This module provides a set of utility functions. Many of these
 280 functions are intended for use in Moose itself or MooseX modules, but
 281 some of them may be useful for use in your own code.
 282
 283 =head1 EXPORTED FUNCTIONS
 284
 285 =over 4
 286
 287 =item B<find_meta($class_or_obj)>
 288
 289 This method takes a class name or object and attempts to find a
 290 metaclass for the class, if one exists. It will B<not> create one if it
 291 does not yet exist.
 292
 293 =item B<does_role($class_or_obj, $role_name)>
 294
 295 Returns true if C<$class_or_obj> does the given C<$role_name>.
 296
 297 The class must already have a metaclass for this to work.
 298
 299 =item B<search_class_by_role($class_or_obj, $role_name)>
 300
 301 Returns the first class in the class's precedence list that does
 302 C<$role_name>, if any.
 303
 304 The class must already have a metaclass for this to work.
 305
 306 =item B<apply_all_roles($applicant, @roles)>
 307
 308 This function applies one or more roles to the given C<$applicant> The
 309 applicant can be a role name, class name, or object.
 310
 311 The C<$applicant> must already have a metaclass object.
 312
 313 The list of C<@roles> should be a list of names, each of which can be
 314 followed by an optional hash reference of options (C<-excludes> and
 315 C<-alias>).
 316
 317 =item B<ensure_all_roles($applicant, @roles)>
 318
 319 This function is similar to L</apply_all_roles>, but only applies roles that
 320 C<$applicant> does not already consume.
 321
 322 =item B<get_all_attribute_values($meta, $instance)>
 323
 324 Returns a hash reference containing all of the C<$instance>'s
 325 attributes. The keys are attribute names.
 326
 327 =item B<get_all_init_args($meta, $instance)>
 328
 329 Returns a hash reference containing all of the C<init_arg> values for
 330 the instance's attributes. The values are the associated attribute
 331 values. If an attribute does not have a defined C<init_arg>, it is
 332 skipped.
 333
 334 This could be useful in cloning an object.
 335
 336 =item B<resolve_metaclass_alias($category, $name, %options)>
 337
 338 =item B<resolve_metatrait_alias($category, $name, %options)>
 339
 340 Resolves a short name to a full class name. Short names are often used
 341 when specifying the C<metaclass> or C<traits> option for an attribute:
 342
 343     has foo => (
 344         metaclass => "Bar",
 345     );
 346
 347 The name resolution mechanism is covered in
 348 L<Moose/Metaclass and Trait Name Resolution>.
 349
 350 =item B<english_list(@items)>
 351
 352 Given a list of scalars, turns them into a proper list in English
 353 ("one and two", "one, two, three, and four"). This is used to help us
 354 make nicer error messages.
 355
 356 =item B<meta_class_alias($to[, $from])>
 357
 358 =item B<meta_attribute_alias($to[, $from])>
 359
 360 Create an alias from the class C<$from> (or the current package, if
 361 C<$from> is unspecified), so that
 362 L<Moose/Metaclass and Trait Name Resolution> works properly.
 363
 364 =back
 365
 366 =head1 TODO
 367
 368 Here is a list of possible functions to write
 369
 370 =over 4
 371
 372 =item discovering original method from modified method
 373
 374 =item search for origin class of a method or attribute
 375
 376 =back
 377
 378 =head1 BUGS
 379
 380 All complex software has bugs lurking in it, and this module is no
 381 exception. If you find a bug please either email me, or add the bug
 382 to cpan-RT.
 383
 384 =head1 AUTHOR
 385
 386 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
 387
 388 B<with contributions from:>
 389
 390 Robert (phaylon) Sedlacek
 391
 392 Stevan Little
 393
 394 =head1 COPYRIGHT AND LICENSE
 395
 396 Copyright 2007-2009 by Infinity Interactive, Inc.
 397
 398 L<http://www.iinteractive.com>
 399
 400 This library is free software; you can redistribute it and/or modify
 401 it under the same terms as Perl itself.
 402
 403 =cut
 404