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