Commit | Line | Data |
9a641848 |
1 | package Moose::Util; |
2 | |
9a641848 |
3 | use strict; |
4 | use warnings; |
5 | |
7125b244 |
6 | use Sub::Exporter; |
7 | use Scalar::Util (); |
8 | use Class::MOP (); |
9a641848 |
9 | |
7125b244 |
10 | our $VERSION = '0.01'; |
11 | our $AUTHORITY = 'cpan:STEVAN'; |
9a641848 |
12 | |
7125b244 |
13 | my @exports = qw[ |
6532ca5a |
14 | find_meta |
15 | does_role |
7125b244 |
16 | search_class_by_role |
17 | ]; |
9a641848 |
18 | |
7125b244 |
19 | Sub::Exporter::setup_exporter({ |
20 | exports => \@exports, |
11065d1f |
21 | groups => { all => \@exports } |
7125b244 |
22 | }); |
23 | |
24 | ## some utils for the utils ... |
25 | |
6532ca5a |
26 | sub find_meta { |
7125b244 |
27 | return unless $_[0]; |
28 | return Class::MOP::get_metaclass_by_name(ref($_[0]) || $_[0]); |
29 | } |
9a641848 |
30 | |
7125b244 |
31 | ## the functions ... |
adf82331 |
32 | |
7125b244 |
33 | sub does_role { |
34 | my ($class_or_obj, $role) = @_; |
adf82331 |
35 | |
6532ca5a |
36 | my $meta = find_meta($class_or_obj); |
7125b244 |
37 | |
38 | return unless defined $meta; |
adf82331 |
39 | |
7125b244 |
40 | return 1 if $meta->does_role($role); |
41 | return; |
9a641848 |
42 | } |
43 | |
1631b53f |
44 | sub search_class_by_role { |
7125b244 |
45 | my ($class_or_obj, $role_name) = @_; |
46 | |
6532ca5a |
47 | my $meta = find_meta($class_or_obj); |
7125b244 |
48 | |
49 | return unless defined $meta; |
50 | |
51 | foreach my $class ($meta->class_precedence_list) { |
52 | |
6532ca5a |
53 | my $_meta = find_meta($class); |
1631b53f |
54 | |
7125b244 |
55 | next unless defined $_meta; |
56 | |
57 | foreach my $role (@{ $_meta->roles || [] }) { |
1631b53f |
58 | return $class if $role->name eq $role_name; |
59 | } |
60 | } |
61 | |
7125b244 |
62 | return; |
1631b53f |
63 | } |
64 | |
9a641848 |
65 | 1; |
66 | |
67 | __END__ |
68 | |
69 | =pod |
70 | |
71 | =head1 NAME |
72 | |
7125b244 |
73 | Moose::Util - Utilities for working with Moose classes |
9a641848 |
74 | |
75 | =head1 SYNOPSIS |
76 | |
6532ca5a |
77 | use Moose::Util qw/find_meta does_role search_class_by_role/; |
78 | |
79 | my $meta = find_meta($object) || die "No metaclass found"; |
9a641848 |
80 | |
adf82331 |
81 | if (does_role($object, $role)) { |
82 | print "The object can do $role!\n"; |
9a641848 |
83 | } |
84 | |
1631b53f |
85 | my $class = search_class_by_role($object, 'FooRole'); |
86 | print "Nearest class with 'FooRole' is $class\n"; |
87 | |
7125b244 |
88 | =head1 DESCRIPTION |
89 | |
90 | This is a set of utility functions to help working with Moose classes. This |
91 | is an experimental module, and it's not 100% clear what purpose it will serve. |
92 | That said, ideas, suggestions and contributions to this collection are most |
93 | welcome. See the L<TODO> section below for a list of ideas for possible |
94 | functions to write. |
95 | |
96 | =head1 EXPORTED FUNCTIONS |
9a641848 |
97 | |
98 | =over 4 |
99 | |
6532ca5a |
100 | =item B<find_meta ($class_or_obj)> |
101 | |
102 | This will attempt to locate a metaclass for the given C<$class_or_obj> |
103 | and return it. |
104 | |
7125b244 |
105 | =item B<does_role ($class_or_obj, $role_name)> |
106 | |
107 | Returns true if C<$class_or_obj> can do the role C<$role_name>. |
108 | |
109 | =item B<search_class_by_role ($class_or_obj, $role_name)> |
110 | |
111 | Returns first class in precedence list that consumed C<$role_name>. |
112 | |
113 | =back |
9a641848 |
114 | |
7125b244 |
115 | =head1 TODO |
9a641848 |
116 | |
7125b244 |
117 | Here is a list of possible functions to write |
9a641848 |
118 | |
7125b244 |
119 | =over 4 |
1631b53f |
120 | |
7125b244 |
121 | =item discovering original method from modified method |
1631b53f |
122 | |
7125b244 |
123 | =item search for origin class of a method or attribute |
1631b53f |
124 | |
9a641848 |
125 | =back |
126 | |
127 | =head1 BUGS |
128 | |
129 | All complex software has bugs lurking in it, and this module is no |
130 | exception. If you find a bug please either email me, or add the bug |
131 | to cpan-RT. |
132 | |
133 | =head1 AUTHOR |
134 | |
135 | Anders Nor Berle E<lt>debolaz@gmail.comE<gt> |
136 | |
7125b244 |
137 | B<with contributions from:> |
138 | |
139 | Robert (phaylon) Sedlacek |
140 | |
141 | Stevan Little |
142 | |
9a641848 |
143 | =head1 COPYRIGHT AND LICENSE |
144 | |
778db3ac |
145 | Copyright 2007-2008 by Infinity Interactive, Inc. |
9a641848 |
146 | |
147 | L<http://www.iinteractive.com> |
148 | |
149 | This library is free software; you can redistribute it and/or modify |
150 | it under the same terms as Perl itself. |
151 | |
152 | =cut |
153 | |