File Coverage

blib/lib/Moo/_Utils.pm
Criterion Covered Total %
statement 141 150 94.0
branch 54 68 79.4
condition 25 38 65.7
subroutine 30 31 96.7
pod n/a
total 250 287 87.1


line stmt bran cond sub pod time code
1             package Moo::_Utils;
2 228     228   1113498 use strict;
  228         507  
  228         6536  
3 228     228   1228 use warnings;
  228         471  
  228         6360  
4              
5             {
6 228     228   1204 no strict 'refs';
  228         534  
  228         6214  
7 228     228   1239 no warnings 'once';
  228         546  
  228         111792  
8 8506     8506   10586 sub _getglob { \*{$_[0]} }
  8506         41310  
9 1796     1796   5190 sub _getstash { \%{"$_[0]::"} }
  1796         7380  
10             }
11              
12             BEGIN {
13 228     228   1112 my ($su, $sn);
14             $su = $INC{'Sub/Util.pm'} && defined &Sub::Util::set_subname
15             or $sn = $INC{'Sub/Name.pm'}
16             or $su = eval { require Sub::Util; } && defined &Sub::Util::set_subname
17 228 100 66     2984 or $sn = eval { require Sub::Name; };
  4   66     118  
      66        
      100        
18              
19             *_subname = $su ? \&Sub::Util::set_subname
20             : $sn ? \&Sub::Name::subname
21 228 100   2   62949 : sub { $_[1] };
  2 100       172  
22 228 100 100     1157 *_CAN_SUBNAME = ($su || $sn) ? sub(){1} : sub(){0};
23              
24 228 50       1665 *_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0};
25             *_WORK_AROUND_HINT_LEAKAGE
26             = "$]" < 5.011 && !("$]" >= 5.009004 && "$]" < 5.010001)
27 228 50 33     1353 ? sub(){1} : sub(){0};
28              
29 228         1313 my $module_name_rx = qr/\A(?!\d)\w+(?:::\w+)*\z/;
30 228         6353 *_module_name_rx = sub(){$module_name_rx};
  0         0  
31             }
32              
33 228     228   1582 use Exporter ();
  228         603  
  228         5799  
34 228     228   3728 BEGIN { *import = \&Exporter::import }
35 228     228   1216 use Config ();
  228         454  
  228         4507  
36 228     228   1304 use Scalar::Util qw(weaken);
  228         524  
  228         10458  
37 228     228   1461 use Carp qw(croak);
  228         531  
  228         182661  
38              
39             # this should be empty, but some CPAN modules expect these
40             our @EXPORT = qw(
41             _install_coderef
42             _load_module
43             );
44              
45             our @EXPORT_OK = qw(
46             _check_tracked
47             _getglob
48             _getstash
49             _install_coderef
50             _install_modifier
51             _install_tracked
52             _load_module
53             _maybe_load_module
54             _module_name_rx
55             _name_coderef
56             _set_loaded
57             _unimport_coderefs
58             _linear_isa
59             _in_global_destruction
60             _in_global_destruction_code
61             );
62              
63             my %EXPORTS;
64              
65             sub _install_modifier {
66 68     68   344 my $target = $_[0];
67 68         107 my $type = $_[1];
68 68         112 my $code = $_[-1];
69 68         268 my @names = @_[2 .. $#_ - 1];
70              
71 68 100       224 @names = @{ $names[0] }
  2         5  
72             if ref($names[0]) eq 'ARRAY';
73              
74 68         211 my @tracked = _check_tracked($target, \@names);
75              
76 68 100       244 if ($INC{'Sub/Defer.pm'}) {
77 60         124 for my $name (@names) {
78             # CMM will throw for us if it doesn't exist
79 62 100       488 if (my $to_modify = $target->can($name)) {
80 60         183 Sub::Defer::undefer_sub($to_modify);
81             }
82             }
83             }
84              
85 68         13809 require Class::Method::Modifiers;
86 68         39855 Class::Method::Modifiers::install_modifier(@_);
87              
88 66 100       18339 if (@tracked) {
89 6         16 my $exports = $EXPORTS{$target};
90             weaken($exports->{$_} = $target->can($_))
91 6         47 for @tracked;
92             }
93              
94 66         3290 return;
95             }
96              
97             sub _install_tracked {
98 5772     5772   10914 my ($target, $name, $code) = @_;
99 5772         8797 my $from = caller;
100 5772         17170 weaken($EXPORTS{$target}{$name} = $code);
101 5772         15419 _install_coderef("${target}::${name}", "${from}::${name}", $code);
102             }
103              
104             sub Moo::_Util::__GUARD__::DESTROY {
105 0 0   0   0 delete $INC{$_[0]->[0]} if @{$_[0]};
  0         0  
106             }
107              
108             sub _require {
109 174     174   520 my ($file) = @_;
110 174         344 my $guard = _WORK_AROUND_BROKEN_MODULE_STATE
111             && bless([ $file ], 'Moo::_Util::__GUARD__');
112 174         294 local %^H if _WORK_AROUND_HINT_LEAKAGE;
113 174 100       347 if (!eval { require $file; 1 }) {
  174         54953  
  106         261713  
114 68   33     6625 my $e = $@ || "Can't locate $file";
115 68         130 my $me = __FILE__;
116 68         1202 $e =~ s{ at \Q$me\E line \d+\.\n\z}{};
117 68         425 return $e;
118             }
119 106         268 pop @$guard if _WORK_AROUND_BROKEN_MODULE_STATE;
120 106         336 return undef;
121             }
122              
123             sub _load_module {
124 606     606   10976 my ($module) = @_;
125 606 100       4322 croak qq{"$module" is not a module name!}
126             unless $module =~ _module_name_rx;
127 604         2269 (my $file = "$module.pm") =~ s{::}{/}g;
128             return 1
129 604 100       2292 if $INC{$file};
130              
131 76         223 my $e = _require $file;
132 76 100       270 return 1
133             if !defined $e;
134              
135 64 100       1558 croak $e
136             if $e !~ /\ACan't locate \Q$file\E /;
137              
138             # can't just ->can('can') because a sub-package Foo::Bar::Baz
139             # creates a 'Baz::' key in Foo::Bar's symbol table
140 60   50     231 my $stash = _getstash($module)||{};
141 228     228   1977 no strict 'refs';
  228         610  
  228         100424  
142 60 100       365 return 1 if grep +exists &{"${module}::$_"}, grep !/::\z/, keys %$stash;
  102         444  
143             return 1
144 12 100 66     204 if $INC{"Moose.pm"} && Class::MOP::class_of($module)
      33        
      66        
145             or Mouse::Util->can('find_meta') && Mouse::Util::find_meta($module);
146              
147 10         1675 croak $e;
148             }
149              
150             our %MAYBE_LOADED;
151             sub _maybe_load_module {
152 100     100   6673 my $module = $_[0];
153             return $MAYBE_LOADED{$module}
154 100 100       475 if exists $MAYBE_LOADED{$module};
155 98         831 (my $file = "$module.pm") =~ s{::}{/}g;
156              
157 98         497 my $e = _require $file;
158 98 100       491 if (!defined $e) {
    100          
159 94         833 return $MAYBE_LOADED{$module} = 1;
160             }
161             elsif ($e !~ /\ACan't locate \Q$file\E /) {
162 2         19 warn "$module exists but failed to load with error: $e";
163             }
164 4         40 return $MAYBE_LOADED{$module} = 0;
165             }
166              
167             BEGIN {
168             # optimize for newer perls
169             require mro
170 228 50   228   3519 if "$]" >= 5.009_005;
171              
172 228 50       1378 if (defined &mro::get_linear_isa) {
173 228         23323 *_linear_isa = \&mro::get_linear_isa;
174             }
175             else {
176 0         0 my $e;
177             {
178 0         0 local $@;
  0         0  
179 0 0       0 eval <<'END_CODE' or $e = $@;
180             sub _linear_isa($;$) {
181             my $class = shift;
182             my $type = shift || exists $Class::C3::MRO{$class} ? 'c3' : 'dfs';
183              
184             if ($type eq 'c3') {
185             require Class::C3;
186             return [Class::C3::calculateMRO($class)];
187             }
188              
189             my @check = ($class);
190             my @lin;
191              
192             my %found;
193             while (defined(my $check = shift @check)) {
194             push @lin, $check;
195             no strict 'refs';
196             unshift @check, grep !$found{$_}++, @{"$check\::ISA"};
197             }
198              
199             return \@lin;
200             }
201              
202             1;
203             END_CODE
204             }
205 0 0       0 die $e if defined $e;
206             }
207             }
208              
209             BEGIN {
210 228 0   228   1905 my $gd_code
    50          
211             = "$]" >= 5.014
212             ? q[${^GLOBAL_PHASE} eq 'DESTRUCT']
213             : _maybe_load_module('Devel::GlobalDestruction::XS')
214             ? 'Devel::GlobalDestruction::XS::in_global_destruction()'
215             : 'do { use B (); ${B::main_cv()} == 0 }';
216 228         2558 *_in_global_destruction_code = sub () { $gd_code };
  0         0  
217 228 50   52   20554 eval "sub _in_global_destruction () { $gd_code }; 1"
  52         634  
218             or die $@;
219             }
220              
221             sub _set_loaded {
222 1026     1026   5031 (my $file = "$_[0].pm") =~ s{::}{/}g;
223 1026   66     6355 $INC{$file} ||= $_[1];
224             }
225              
226             sub _install_coderef {
227 5782     5782   9858 my ($glob, $code) = (_getglob($_[0]), _name_coderef(@_));
228 228     228   1808 no warnings 'redefine';
  228         590  
  228         14361  
229 5782 100       8935 if (*{$glob}{CODE}) {
  5782         11160  
230 24         30 *{$glob} = $code;
  24         83  
231             }
232             # perl will sometimes warn about mismatched prototypes coming from the
233             # inheritance cache, so disable them if we aren't redefining a sub
234             else {
235 228     228   4400 no warnings 'prototype';
  228         857  
  228         81177  
236 5758         7079 *{$glob} = $code;
  5758         20162  
237             }
238             }
239              
240             sub _name_coderef {
241 5916 100   5916   12899 shift if @_ > 2; # three args is (target, name, sub)
242 5916         27429 _CAN_SUBNAME ? _subname(@_) : $_[1];
243             }
244              
245             sub _check_tracked {
246 538     538   1436 my ($target, $names) = @_;
247 538         1223 my $stash = _getstash($target);
248 538 100       2295 my $exports = $EXPORTS{$target}
249             or return;
250              
251 310 100       1054 $names = [keys %$exports]
252             if !$names;
253             my %rev =
254             map +($exports->{$_} => $_),
255 310         4188 grep defined $exports->{$_},
256             keys %$exports;
257              
258             return
259             grep {
260 310         1169 my $g = $stash->{$_};
  2304         4957  
261 2304 100 100     13485 $g && defined &$g && exists $rev{\&$g};
262             }
263             @$names;
264             }
265              
266             sub _unimport_coderefs {
267 26     26   57 my ($target) = @_;
268              
269 26         116 my $stash = _getstash($target);
270 26         58 my @exports = _check_tracked($target);
271              
272 26         128 foreach my $name (@exports) {
273 112         237 my $old = delete $stash->{$name};
274 112         248 my $full_name = join('::',$target,$name);
275             # Copy everything except the code slot back into place (e.g. $has)
276 112         176 foreach my $type (qw(SCALAR HASH ARRAY IO)) {
277 448 100       531 next unless defined(*{$old}{$type});
  448         5406  
278 228     228   2705 no strict 'refs';
  228         653  
  228         25300  
279 112         231 *$full_name = *{$old}{$type};
  112         434  
280             }
281             }
282             }
283              
284             if ($Config::Config{useithreads}) {
285             require Moo::HandleMoose::_TypeMap;
286             }
287              
288             1;