lib/Moose/Util.pm

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