lib/Moose/Util.pm

   1 package Moose::Util;
   2
   3 use Exporter qw/import/;
   4 use Scalar::Util;
   5
   6 use strict;
   7 use warnings;
   8
   9 our $VERSION = '0.01';
  10
  11 our $AUTHORITY = 'cpan:BERLE';
  12
  13 our @EXPORT_OK = qw/does_role search_class_by_role/;
  14
  15 sub does_role {
  16   my ($class, $role) = @_;
  17
  18   return unless defined $class;
  19
  20   my $meta = Class::MOP::get_metaclass_by_name (ref $class || $class);
  21
  22   return unless defined $meta;
  23
  24   return $meta->does_role ($role);
  25 }
  26
  27 sub search_class_by_role {
  28     my ($obj, $role_name) = @_;
  29
  30     for my $class ($obj->meta->class_precedence_list) {
  31         for my $role (@{ $class->meta->roles || [] }) {
  32             return $class if $role->name eq $role_name;
  33         }
  34     }
  35
  36     return undef;
  37 }
  38
  39 1;
  40
  41 __END__
  42
  43 =pod
  44
  45 =head1 NAME
  46
  47 Moose::Util - Moose utilities
  48
  49 =head1 SYNOPSIS
  50
  51   use Moose::Util qw/can_role search_class_by_role/;
  52
  53   if (does_role($object, $role)) {
  54     print "The object can do $role!\n";
  55   }
  56
  57   my $class = search_class_by_role($object, 'FooRole');
  58   print "Nearest class with 'FooRole' is $class\n";
  59
  60 =head1 FUNCTIONS
  61
  62 =over 4
  63
  64 =item does_role
  65
  66   does_role($object, $rolename);
  67
  68 Returns true if $object can do the role $rolename.
  69
  70 =item search_class_by_role
  71
  72   my $class = search_class_by_role($object, $rolename);
  73
  74 Returns first class in precedence list that consumed C<$rolename>.
  75
  76 =back
  77
  78 =head1 BUGS
  79
  80 All complex software has bugs lurking in it, and this module is no
  81 exception. If you find a bug please either email me, or add the bug
  82 to cpan-RT.
  83
  84 =head1 AUTHOR
  85
  86 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
  87
  88 =head1 COPYRIGHT AND LICENSE
  89
  90 Copyright 2007 by Infinity Interactive, Inc.
  91
  92 L<http://www.iinteractive.com>
  93
  94 This library is free software; you can redistribute it and/or modify
  95 it under the same terms as Perl itself.
  96
  97 =cut
  98