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' => { |
9 | 'blessed' => do { |
10 | do { |
11 | no strict 'refs'; |
12 | *UNIVERSAL::a_sub_not_likely_to_be_here = sub { |
13 | my $ref = ref($_[0]); |
14 | |
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. :/ |
19 | |
20 | # \*STDOUT would be allowed as an object in PP blessed |
21 | # but not XS |
22 | return $ref eq 'GLOB' ? undef : $ref; |
23 | }; |
24 | }; |
25 | |
26 | sub { |
27 | local($@, $SIG{__DIE__}, $SIG{__WARN__}); |
28 | length(ref($_[0])) |
29 | ? eval { $_[0]->a_sub_not_likely_to_be_here } |
30 | : undef; |
31 | }, |
32 | }, |
58fe9fb7 |
33 | 'looks_like_number' => sub { |
34 | local $_ = shift; |
35 | |
36 | # checks from perlfaq4 |
37 | return 0 if !defined($_) or ref($_); |
38 | return 1 if (/^[+-]?\d+$/); # is a +/- integer |
39 | return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float |
40 | return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i); |
41 | |
42 | 0; |
43 | }, |
d8aea268 |
44 | 'reftype' => sub { |
45 | local($@, $SIG{__DIE__}, $SIG{__WARN__}); |
46 | my $r = shift; |
47 | my $t; |
48 | |
49 | length($t = ref($r)) or return undef; |
50 | |
51 | # This eval will fail if the reference is not blessed |
52 | eval { $r->a_sub_not_likely_to_be_here; 1 } |
53 | ? do { |
54 | $t = eval { |
55 | # we have a GLOB or an IO. Stringify a GLOB gives it's name |
56 | my $q = *$r; |
57 | $q =~ /^\*/ ? "GLOB" : "IO"; |
58 | } |
59 | or do { |
60 | # OK, if we don't have a GLOB what parts of |
61 | # a glob will it populate. |
62 | # NOTE: A glob always has a SCALAR |
63 | local *glob = $r; |
64 | defined *glob{ARRAY} && "ARRAY" |
65 | or defined *glob{HASH} && "HASH" |
66 | or defined *glob{CODE} && "CODE" |
67 | or length(ref(${$r})) ? "REF" : "SCALAR"; |
68 | } |
69 | } |
70 | : $t |
71 | }, |
29312fc3 |
72 | 'openhandle' => sub { |
73 | my $fh = shift; |
74 | my $rt = reftype($fh) || ''; |
75 | |
76 | return defined(fileno($fh)) ? $fh : undef |
77 | if $rt eq 'IO'; |
78 | |
79 | if (reftype(\$fh) eq 'GLOB') { # handle openhandle(*DATA) |
80 | $fh = \(my $tmp=$fh); |
81 | } |
82 | elsif ($rt ne 'GLOB') { |
83 | return undef; |
84 | } |
85 | |
86 | (tied(*$fh) or defined(fileno($fh))) |
87 | ? $fh : undef; |
88 | }, |
8fcbe7fb |
89 | }, |
4093c859 |
90 | 'MRO::Compat' => { |
91 | 'get_linear_isa' => { |
92 | loaded => \&mro::get_linear_isa, |
93 | not_loaded => do { |
94 | # this recurses so it isn't pretty |
95 | my $code; |
96 | $code = sub { |
97 | no strict 'refs'; |
98 | |
99 | my $classname = shift; |
100 | |
101 | my @lin = ($classname); |
102 | my %stored; |
103 | foreach my $parent (@{"$classname\::ISA"}) { |
104 | my $plin = $code->($parent); |
105 | foreach (@$plin) { |
106 | next if exists $stored{$_}; |
107 | push(@lin, $_); |
108 | $stored{$_} = 1; |
109 | } |
110 | } |
111 | return \@lin; |
112 | } |
113 | }, |
114 | }, |
115 | }, |
116 | ); |
117 | |
118 | our @EXPORT_OK = map { keys %$_ } values %dependencies; |
119 | |
120 | for my $module_name (keys %dependencies) { |
121 | (my $file = "$module_name.pm") =~ s{::}{/}g; |
122 | |
123 | my $loaded = do { |
124 | local $SIG{__DIE__} = 'DEFAULT'; |
125 | eval "require '$file'; 1"; |
126 | }; |
127 | |
128 | for my $method_name (keys %{ $dependencies{ $module_name } }) { |
129 | my $producer = $dependencies{$module_name}{$method_name}; |
130 | my $implementation; |
131 | |
132 | if (ref($producer) eq 'HASH') { |
133 | $implementation = $loaded |
134 | ? $producer->{loaded} |
135 | : $producer->{not_loaded}; |
136 | } |
137 | else { |
138 | $implementation = $loaded |
139 | ? $module_name->can($method_name) |
140 | : $producer; |
141 | } |
142 | |
143 | no strict 'refs'; |
144 | *{ __PACKAGE__ . '::' . $method_name } = $implementation; |
145 | } |
146 | } |
147 | |
148 | 1; |
149 | |