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