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