Commit | Line | Data |
4093c859 |
1 | package Mouse::Util; |
2 | use strict; |
3 | use warnings; |
5c12655d |
4 | use base qw/Exporter/; |
3a63a2e7 |
5 | use Carp qw(confess); |
6 | use B (); |
4093c859 |
7 | |
eae80759 |
8 | our @EXPORT_OK = qw( |
eae80759 |
9 | get_linear_isa |
e2578812 |
10 | apply_all_roles |
67199842 |
11 | version |
12 | authority |
13 | identifier |
3a63a2e7 |
14 | get_code_info |
eae80759 |
15 | ); |
16 | our %EXPORT_TAGS = ( |
17 | all => \@EXPORT_OK, |
18 | ); |
19 | |
42d7df00 |
20 | BEGIN { |
272a1930 |
21 | my $impl; |
bcd39bf4 |
22 | if ($] >= 5.009_005) { |
388b8ebd |
23 | require mro; |
272a1930 |
24 | $impl = \&mro::get_linear_isa; |
25 | } else { |
e0396a57 |
26 | my $e = do { |
27 | local $@; |
28 | eval { require MRO::Compat }; |
29 | $@; |
f172d4e7 |
30 | }; |
e0396a57 |
31 | if (!$e) { |
272a1930 |
32 | $impl = \&mro::get_linear_isa; |
33 | } else { |
34 | # VVVVV CODE TAKEN FROM MRO::COMPAT VVVVV |
e0396a57 |
35 | my $_get_linear_isa_dfs; # this recurses so it isn't pretty |
36 | $_get_linear_isa_dfs = sub { |
272a1930 |
37 | no strict 'refs'; |
38 | |
39 | my $classname = shift; |
40 | |
41 | my @lin = ($classname); |
42 | my %stored; |
43 | foreach my $parent (@{"$classname\::ISA"}) { |
e0396a57 |
44 | my $plin = $_get_linear_isa_dfs->($parent); |
45 | foreach my $p(@$plin) { |
46 | next if exists $stored{$p}; |
47 | push(@lin, $p); |
48 | $stored{$p} = 1; |
272a1930 |
49 | } |
50 | } |
51 | return \@lin; |
52 | }; |
53 | # ^^^^^ CODE TAKEN FROM MRO::COMPAT ^^^^^ |
e0396a57 |
54 | $impl = $_get_linear_isa_dfs; |
eae80759 |
55 | } |
56 | } |
bcd39bf4 |
57 | |
272a1930 |
58 | no strict 'refs'; |
59 | *{ __PACKAGE__ . '::get_linear_isa'} = $impl; |
eae80759 |
60 | } |
61 | |
3a63a2e7 |
62 | { # taken from Sub::Identify |
63 | sub get_code_info($) {\r |
64 | my ($coderef) = @_;\r |
65 | ref($coderef) or return;\r |
66 | my $cv = B::svref_2object($coderef);\r |
67 | $cv->isa('B::CV') or return; |
68 | |
69 | my $gv = $cv->GV;\r |
70 | # bail out if GV is undefined\r |
71 | $gv->isa('B::SPECIAL') and return;\r |
72 | \r |
73 | return ($gv->STASH->NAME, $gv->NAME);\r |
74 | }\r |
75 | } |
76 | |
67199842 |
77 | { # adapted from Class::MOP::Module |
78 | |
79 | sub version { no strict 'refs'; ${shift->name.'::VERSION'} } |
80 | sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} } |
81 | sub identifier { |
82 | my $self = shift; |
83 | join '-' => ( |
84 | $self->name, |
85 | ($self->version || ()), |
86 | ($self->authority || ()), |
87 | ); |
88 | } |
89 | } |
90 | |
abfdffe0 |
91 | # taken from Class/MOP.pm |
92 | { |
93 | my %cache; |
94 | |
95 | sub resolve_metaclass_alias { |
96 | my ( $type, $metaclass_name, %options ) = @_; |
97 | |
98 | my $cache_key = $type; |
99 | return $cache{$cache_key}{$metaclass_name} |
100 | if $cache{$cache_key}{$metaclass_name}; |
101 | |
102 | my $possible_full_name = |
103 | 'Mouse::Meta::' |
104 | . $type |
105 | . '::Custom::' |
106 | . $metaclass_name; |
107 | |
108 | my $loaded_class = |
109 | load_first_existing_class( $possible_full_name, |
110 | $metaclass_name ); |
111 | |
112 | return $cache{$cache_key}{$metaclass_name} = |
113 | $loaded_class->can('register_implementation') |
114 | ? $loaded_class->register_implementation |
115 | : $loaded_class; |
116 | } |
117 | } |
118 | |
119 | # taken from Class/MOP.pm |
120 | sub _is_valid_class_name { |
121 | my $class = shift; |
122 | |
123 | return 0 if ref($class); |
124 | return 0 unless defined($class); |
125 | return 0 unless length($class); |
126 | |
127 | return 1 if $class =~ /^\w+(?:::\w+)*$/; |
128 | |
129 | return 0; |
130 | } |
131 | |
132 | # taken from Class/MOP.pm |
133 | sub load_first_existing_class { |
134 | my @classes = @_ |
135 | or return; |
136 | |
137 | foreach my $class (@classes) { |
138 | unless ( _is_valid_class_name($class) ) { |
139 | my $display = defined($class) ? $class : 'undef'; |
140 | confess "Invalid class name ($display)"; |
141 | } |
142 | } |
143 | |
144 | my $found; |
145 | my %exceptions; |
146 | for my $class (@classes) { |
147 | my $e = _try_load_one_class($class); |
148 | |
149 | if ($e) { |
150 | $exceptions{$class} = $e; |
151 | } |
152 | else { |
153 | $found = $class; |
154 | last; |
155 | } |
156 | } |
157 | return $found if $found; |
158 | |
159 | confess join( |
160 | "\n", |
161 | map { |
162 | sprintf( "Could not load class (%s) because : %s", |
163 | $_, $exceptions{$_} ) |
164 | } @classes |
165 | ); |
166 | } |
167 | |
168 | # taken from Class/MOP.pm |
169 | sub _try_load_one_class { |
170 | my $class = shift; |
171 | |
172 | return if Mouse::is_class_loaded($class); |
173 | |
174 | my $file = $class . '.pm'; |
175 | $file =~ s{::}{/}g; |
176 | |
177 | return do { |
178 | local $@; |
179 | eval { require($file) }; |
180 | $@; |
181 | }; |
182 | } |
183 | |
2e92bb89 |
184 | sub apply_all_roles { |
185 | my $meta = Mouse::Meta::Class->initialize(shift); |
2e92bb89 |
186 | |
21498b08 |
187 | my @roles; |
f6715552 |
188 | |
189 | # Basis of Data::OptList |
21498b08 |
190 | my $max = scalar(@_); |
191 | for (my $i = 0; $i < $max ; $i++) { |
192 | if ($i + 1 < $max && ref($_[$i + 1])) { |
193 | push @roles, [ $_[$i++] => $_[$i] ]; |
194 | } else { |
195 | push @roles, [ $_[$i] => {} ]; |
196 | } |
197 | } |
198 | |
199 | foreach my $role_spec (@roles) { |
200 | Mouse::load_class( $role_spec->[0] ); |
201 | } |
202 | |
203 | ( $_->[0]->can('meta') && $_->[0]->meta->isa('Mouse::Meta::Role') ) |
3a63a2e7 |
204 | || confess("You can only consume roles, " |
21498b08 |
205 | . $_->[0] |
206 | . " is not a Moose role") |
207 | foreach @roles; |
208 | |
209 | if ( scalar @roles == 1 ) { |
210 | my ( $role, $params ) = @{ $roles[0] }; |
211 | $role->meta->apply( $meta, ( defined $params ? %$params : () ) ); |
212 | } |
213 | else { |
214 | Mouse::Meta::Role->combine_apply($meta, @roles); |
215 | } |
216 | |
2e92bb89 |
217 | } |
218 | |
4093c859 |
219 | 1; |
220 | |
f38ce2d0 |
221 | __END__ |
222 | |
223 | =head1 NAME |
224 | |
225 | Mouse::Util - features, with or without their dependencies |
226 | |
227 | =head1 IMPLEMENTATIONS FOR |
228 | |
229 | =head2 L<MRO::Compat> |
230 | |
231 | =head3 get_linear_isa |
232 | |
f38ce2d0 |
233 | =cut |
234 | |