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