Commit | Line | Data |
4093c859 |
1 | #!/usr/bin/env perl |
2 | package Mouse::Util; |
3 | use strict; |
4 | use warnings; |
eae80759 |
5 | use Exporter 'import'; |
d72006ca |
6 | use Carp; |
4093c859 |
7 | |
eae80759 |
8 | our @EXPORT_OK = qw( |
9 | blessed |
10 | get_linear_isa |
11 | looks_like_number |
12 | openhandle |
13 | reftype |
14 | weaken |
15 | ); |
16 | our %EXPORT_TAGS = ( |
17 | all => \@EXPORT_OK, |
18 | ); |
19 | |
20 | # We only have to do this nastiness if we haven't loaded XS version of |
21 | # Mouse.pm, so check if we're running under PurePerl or not |
42d7df00 |
22 | BEGIN { |
3f8f481d |
23 | # Checking for undefinedness will ensure that our functions are |
24 | # properly loaded without loading Mouse, but this is kind of ugly |
25 | if ($Mouse::PurePerl || ! defined $Mouse::PurePerl) { |
64959bc9 |
26 | my %dependencies = ( |
27 | 'Scalar::Util' => { |
28 | # VVVVV CODE TAKEN FROM SCALAR::UTIL VVVVV |
29 | 'blessed' => do { |
30 | *UNIVERSAL::a_sub_not_likely_to_be_here = sub { |
31 | my $ref = ref($_[0]); |
32 | |
33 | # deviation from Scalar::Util |
34 | # XS returns undef, PP returns GLOB. |
35 | # let's make that more consistent by having PP return |
36 | # undef if it's a GLOB. :/ |
37 | |
38 | # \*STDOUT would be allowed as an object in PP blessed |
39 | # but not XS |
40 | return $ref eq 'GLOB' ? undef : $ref; |
41 | }; |
42 | |
43 | sub { |
44 | local($@, $SIG{__DIE__}, $SIG{__WARN__}); |
45 | length(ref($_[0])) |
46 | ? eval { $_[0]->a_sub_not_likely_to_be_here } |
47 | : undef; |
48 | }, |
49 | }, |
50 | 'looks_like_number' => sub { |
51 | local $_ = shift; |
52 | |
53 | # checks from perlfaq4 |
54 | return 0 if !defined($_) or ref($_); |
55 | return 1 if (/^[+-]?\d+$/); # is a +/- integer |
56 | return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float |
57 | return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); |
58 | |
59 | 0; |
60 | }, |
61 | 'reftype' => sub { |
62 | local($@, $SIG{__DIE__}, $SIG{__WARN__}); |
63 | my $r = shift; |
64 | my $t; |
65 | |
66 | length($t = ref($r)) or return undef; |
67 | |
68 | # This eval will fail if the reference is not blessed |
69 | eval { $r->a_sub_not_likely_to_be_here; 1 } |
70 | ? do { |
71 | $t = eval { |
72 | # we have a GLOB or an IO. Stringify a GLOB gives it's name |
73 | my $q = *$r; |
74 | $q =~ /^\*/ ? "GLOB" : "IO"; |
75 | } |
76 | or do { |
77 | # OK, if we don't have a GLOB what parts of |
78 | # a glob will it populate. |
79 | # NOTE: A glob always has a SCALAR |
80 | local *glob = $r; |
81 | defined *glob{ARRAY} && "ARRAY" |
82 | or defined *glob{HASH} && "HASH" |
83 | or defined *glob{CODE} && "CODE" |
84 | or length(ref(${$r})) ? "REF" : "SCALAR"; |
85 | } |
86 | } |
87 | : $t |
88 | }, |
89 | 'openhandle' => sub { |
90 | my $fh = shift; |
91 | my $rt = reftype($fh) || ''; |
92 | |
93 | return defined(fileno($fh)) ? $fh : undef |
94 | if $rt eq 'IO'; |
95 | |
96 | if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA) |
97 | $fh = \(my $tmp=$fh); |
98 | } |
99 | elsif ($rt ne 'GLOB') { |
100 | return undef; |
101 | } |
102 | |
103 | (tied(*$fh) or defined(fileno($fh))) |
104 | ? $fh : undef; |
105 | }, |
106 | weaken => { |
107 | loaded => \&Scalar::Util::weaken, |
108 | not_loaded => sub { die "Scalar::Util required for weak reference support" }, |
109 | }, |
110 | # ^^^^^ CODE TAKEN FROM SCALAR::UTIL ^^^^^ |
111 | }, |
112 | 'MRO::Compat' => { |
113 | # VVVVV CODE TAKEN FROM MRO::COMPAT VVVVV |
114 | 'get_linear_isa' => { |
115 | loaded => \&mro::get_linear_isa, |
116 | not_loaded => do { |
117 | # this recurses so it isn't pretty |
118 | my $code; |
119 | $code = sub { |
120 | no strict 'refs'; |
121 | |
122 | my $classname = shift; |
123 | |
124 | my @lin = ($classname); |
125 | my %stored; |
126 | foreach my $parent (@{"$classname\::ISA"}) { |
127 | my $plin = $code->($parent); |
128 | foreach (@$plin) { |
129 | next if exists $stored{$_}; |
130 | push(@lin, $_); |
131 | $stored{$_} = 1; |
132 | } |
133 | } |
134 | return \@lin; |
135 | } |
136 | }, |
137 | }, |
138 | # ^^^^^ CODE TAKEN FROM MRO::COMPAT ^^^^^ |
139 | }, |
140 | ); |
141 | |
142 | my %loaded; |
143 | for my $module_name (keys %dependencies) { |
144 | my $loaded = do { |
145 | local $SIG{__DIE__} = 'DEFAULT'; |
146 | eval "require $module_name; 1"; |
147 | }; |
148 | |
149 | $loaded{$module_name} = $loaded; |
150 | |
151 | for my $method_name (keys %{ $dependencies{ $module_name } }) { |
152 | my $producer = $dependencies{$module_name}{$method_name}; |
153 | my $implementation; |
154 | |
155 | if (ref($producer) eq 'HASH') { |
156 | $implementation = $loaded |
157 | ? $producer->{loaded} |
158 | : $producer->{not_loaded}; |
159 | } |
160 | else { |
161 | $implementation = $loaded |
162 | ? $module_name->can($method_name) |
163 | : $producer; |
164 | } |
165 | |
166 | no strict 'refs'; |
167 | *{ __PACKAGE__ . '::' . $method_name } = $implementation; |
168 | } |
169 | } |
eae80759 |
170 | } else { |
171 | # If we're running under XS, we can provide |
172 | # blessed |
173 | # looks_like_number |
174 | # reftype |
175 | # weaken |
176 | # other functions need to be loaded from our respective sources |
177 | |
9524350b |
178 | if (defined &Scalar::Util::openhandle) { |
eae80759 |
179 | *openhandle = \&Scalar::Util::openhandle; |
180 | } else { |
181 | # XXX - room for improvement |
182 | *openhandle = sub { |
21313741 |
183 | my $fh = shift; |
184 | my $rt = reftype($fh) || ''; |
577be390 |
185 | |
21313741 |
186 | return defined(fileno($fh)) ? $fh : undef |
187 | if $rt eq 'IO'; |
eae80759 |
188 | |
21313741 |
189 | if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA) |
190 | $fh = \(my $tmp=$fh); |
eae80759 |
191 | } |
21313741 |
192 | elsif ($rt ne 'GLOB') { |
193 | return undef; |
194 | } |
195 | |
196 | (tied(*$fh) or defined(fileno($fh))) |
197 | ? $fh : undef; |
eae80759 |
198 | }; |
199 | } |
200 | |
214c3ab9 |
201 | if (defined &mro::get_linear_isa || eval { require MRO::Compat; 1; }) { |
eae80759 |
202 | *get_linear_isa = \&mro::get_linear_isa; |
203 | } else { |
204 | # this recurses so it isn't pretty |
205 | my $code; |
206 | *get_linear_isa = $code = sub { |
207 | no strict 'refs'; |
208 | |
209 | my $classname = shift; |
210 | |
211 | my @lin = ($classname); |
212 | my %stored; |
213 | foreach my $parent (@{"$classname\::ISA"}) { |
214 | my $plin = $code->($parent); |
215 | foreach (@$plin) { |
216 | next if exists $stored{$_}; |
217 | push(@lin, $_); |
218 | $stored{$_} = 1; |
219 | } |
220 | } |
221 | return \@lin; |
222 | }; |
223 | } |
224 | } |
225 | } |
226 | |
2e92bb89 |
227 | sub apply_all_roles { |
228 | my $meta = Mouse::Meta::Class->initialize(shift); |
229 | my $role = shift; |
230 | confess "Mouse::Util only supports 'apply_all_roles' on individual roles at a time" if @_; |
231 | |
232 | Mouse::load_class($role); |
233 | $role->meta->apply($meta); |
234 | } |
235 | |
4093c859 |
236 | 1; |
237 | |
f38ce2d0 |
238 | __END__ |
239 | |
240 | =head1 NAME |
241 | |
242 | Mouse::Util - features, with or without their dependencies |
243 | |
244 | =head1 IMPLEMENTATIONS FOR |
245 | |
246 | =head2 L<MRO::Compat> |
247 | |
248 | =head3 get_linear_isa |
249 | |
250 | =head2 L<Scalar::Util> |
251 | |
252 | =head3 blessed |
253 | |
254 | =head3 looks_like_number |
255 | |
256 | =head3 reftype |
257 | |
258 | =head3 openhandle |
259 | |
260 | =head3 weaken |
261 | |
262 | C<weaken> I<must> be implemented in XS. If the user tries to use C<weaken> |
263 | without L<Scalar::Util>, an error is thrown. |
264 | |
ea0b9e39 |
265 | =head2 Test::Exception |
266 | |
267 | =head3 throws_ok |
268 | |
269 | =head3 lives_ok |
270 | |
f38ce2d0 |
271 | =cut |
272 | |