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