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