File Coverage

blib/lib/CPAN/Distroprefs.pm
Criterion Covered Total %
statement 113 218 51.8
branch 25 72 34.7
condition 1 13 7.6
subroutine 43 70 61.4
pod 0 1 0.0
total 182 374 48.6


line stmt bran cond sub pod time code
1             # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2             # vim: ts=4 sts=4 sw=4:
3              
4 14     14   25363 use 5.006;
  14         34  
5 14     14   41 use strict;
  14         13  
  14         358  
6             package CPAN::Distroprefs;
7              
8 14     14   43 use vars qw($VERSION);
  14         106  
  14         620  
9             $VERSION = '6.0001';
10              
11             package CPAN::Distroprefs::Result;
12              
13 14     14   45 use File::Spec;
  14         11  
  14         1147  
14              
15 0   0 0   0 sub new { bless $_[1] || {} => $_[0] }
16              
17 0     0   0 sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) }
18              
19             sub __cloner {
20 42     42   57 my ($class, $name, $newclass) = @_;
21 42         60 $newclass = 'CPAN::Distroprefs::Result::' . $newclass;
22 14     14   756 no strict 'refs';
  14         12  
  14         1054  
23 42         943 *{$class . '::' . $name} = sub {
24             $newclass->new({
25 0         0 %{ $_[0] },
26 0     0   0 %{ $_[1] },
  0         0  
27             });
28 42         116 };
29             }
30 14     14   32 BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') }
31 14     14   26 BEGIN { __PACKAGE__->__cloner(as_fatal => 'Fatal') }
32 14     14   35 BEGIN { __PACKAGE__->__cloner(as_success => 'Success') }
33              
34             sub __accessor {
35 98     98   109 my ($class, $key) = @_;
36 14     14   47 no strict 'refs';
  14         17  
  14         898  
37 98     0   206 *{$class . '::' . $key} = sub { $_[0]->{$key} };
  98         2851  
  0         0  
38             }
39 14     14   75 BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) }
40              
41 0     0   0 sub is_warning { 0 }
42 0     0   0 sub is_fatal { 0 }
43 0     0   0 sub is_success { 0 }
44              
45             package CPAN::Distroprefs::Result::Error;
46 14     14   53 use vars qw(@ISA);
  14         12  
  14         466  
47 14     14   416 BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
48 14     14   65 BEGIN { __PACKAGE__->__accessor($_) for qw(msg) }
49              
50             sub as_string {
51 0     0   0 my ($self) = @_;
52 0 0       0 if ($self->msg) {
53 0         0 return sprintf $self->fmt_reason, $self->file, $self->msg;
54             } else {
55 0         0 return sprintf $self->fmt_unknown, $self->file;
56             }
57             }
58              
59             package CPAN::Distroprefs::Result::Warning;
60 14     14   53 use vars qw(@ISA);
  14         11  
  14         428  
61 14     14   779 BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
62 0     0   0 sub is_warning { 1 }
63 0     0   0 sub fmt_reason { "Error reading distroprefs file %s, skipping: %s" }
64 0     0   0 sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." }
65              
66             package CPAN::Distroprefs::Result::Fatal;
67 14     14   46 use vars qw(@ISA);
  14         16  
  14         472  
68 14     14   880 BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
69 0     0   0 sub is_fatal { 1 }
70 0     0   0 sub fmt_reason { "Error reading distroprefs file %s: %s" }
71 0     0   0 sub fmt_unknown { "Unknown error reading distroprefs file %s." }
72              
73             package CPAN::Distroprefs::Result::Success;
74 14     14   44 use vars qw(@ISA);
  14         14  
  14         439  
75 14     14   379 BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
76 14     14   69 BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) }
77 0     0   0 sub is_success { 1 }
78              
79             package CPAN::Distroprefs::Iterator;
80              
81 0     0   0 sub new { bless $_[1] => $_[0] }
82              
83 0     0   0 sub next { $_[0]->() }
84              
85             package CPAN::Distroprefs;
86              
87 14     14   55 use Carp ();
  14         18  
  14         183  
88 14     14   5109 use DirHandle;
  14         16190  
  14         2835  
89              
90             sub _load_method {
91 0     0   0 my ($self, $loader, $result) = @_;
92 0 0 0     0 return '_load_yaml' if $loader eq 'CPAN' or $loader =~ /^YAML(::|$)/;
93 0         0 return '_load_' . $result->ext;
94             }
95              
96             sub _load_yaml {
97 0     0   0 my ($self, $loader, $result) = @_;
98 0         0 my $data = eval {
99 0 0       0 $loader eq 'CPAN'
100             ? $loader->_yaml_loadfile($result->abs)
101             : [ $loader->can('LoadFile')->($result->abs) ]
102             };
103 0 0       0 if (my $err = $@) {
    0          
104 0         0 die $result->as_warning({
105             msg => $err,
106             });
107             } elsif (!$data) {
108 0         0 die $result->as_warning;
109             } else {
110 0         0 return @$data;
111             }
112             }
113              
114             sub _load_dd {
115 0     0   0 my ($self, $loader, $result) = @_;
116 0         0 my @data;
117             {
118 0         0 package CPAN::Eval;
119             # this caused a die in CPAN.pm, and I am leaving it 'fatal', though I'm
120             # not sure why we wouldn't just skip the file as we do for all other
121             # errors. -- hdp
122 0         0 my $abs = $result->abs;
123 0 0       0 open FH, "<$abs" or die $result->as_fatal(msg => "$!");
124 0         0 local $/;
125 0         0 my $eval = ;
126 0         0 close FH;
127 14     14   66 no strict;
  14         16  
  14         7665  
128 0         0 eval $eval;
129 0 0       0 if (my $err = $@) {
130 0         0 die $result->as_warning({ msg => $err });
131             }
132 0         0 my $i = 1;
133 0         0 while (${"VAR$i"}) {
  0         0  
134 0         0 push @data, ${"VAR$i"};
  0         0  
135 0         0 $i++;
136             }
137             }
138 0         0 return @data;
139             }
140              
141             sub _load_st {
142 0     0   0 my ($self, $loader, $result) = @_;
143             # eval because Storable is never forward compatible
144 0         0 my @data = eval { @{scalar $loader->can('retrieve')->($result->abs) } };
  0         0  
  0         0  
145 0 0       0 if (my $err = $@) {
146 0         0 die $result->as_warning({ msg => $err });
147             }
148 0         0 return @data;
149             }
150              
151             sub _build_file_list {
152 0 0   0   0 if (@_ > 3) {
153 0         0 die "_build_file_list should be called with 3 arguments, was called with more. First argument is '$_[0]'.";
154             }
155 0         0 my ($dir, $dir1, $ext_re) = @_;
156 0         0 my @list;
157             my $dh;
158 0 0       0 unless (opendir($dh, $dir)) {
159 0         0 $CPAN::Frontend->mywarn("ignoring prefs directory '$dir': $!");
160 0         0 return @list;
161             }
162 0         0 while (my $fn = readdir $dh) {
163 0 0 0     0 next if $fn eq '.' || $fn eq '..';
164 0 0       0 if (-d "$dir/$fn") {
165 0 0       0 next if $fn =~ /^[._]/; # prune .svn, .git, .hg, _darcs and what the user wants to hide
166 0         0 push @list, _build_file_list("$dir/$fn", "$dir1$fn/", $ext_re);
167             } else {
168 0 0       0 if ($fn =~ $ext_re) {
169 0         0 push @list, "$dir1$fn";
170             }
171             }
172             }
173 0         0 return @list;
174             }
175              
176             sub find {
177 0     0 0 0 my ($self, $dir, $ext_map) = @_;
178              
179 0 0   0   0 return CPAN::Distroprefs::Iterator->new(sub { return }) unless %$ext_map;
  0         0  
180              
181 0         0 my $possible_ext = join "|", map { quotemeta } keys %$ext_map;
  0         0  
182 0         0 my $ext_re = qr/\.($possible_ext)$/;
183              
184 0         0 my @files = _build_file_list($dir, '', $ext_re);
185 0 0       0 @files = sort @files if @files;
186              
187             # label the block so that we can use redo in the middle
188             return CPAN::Distroprefs::Iterator->new(sub { LOOP: {
189              
190 0     0   0 my $fn = shift @files;
  0         0  
191 0 0       0 return unless defined $fn;
192 0         0 my ($ext) = $fn =~ $ext_re;
193              
194 0         0 my $loader = $ext_map->{$ext};
195              
196 0         0 my $result = CPAN::Distroprefs::Result->new({
197             file => $fn, ext => $ext, dir => $dir
198             });
199             # copied from CPAN.pm; is this ever actually possible?
200 0 0       0 redo unless -f $result->abs;
201              
202 0         0 my $load_method = $self->_load_method($loader, $result);
203 0         0 my @prefs = eval { $self->$load_method($loader, $result) };
  0         0  
204 0 0       0 if (my $err = $@) {
    0          
205 0 0 0     0 if (ref($err) && eval { $err->isa('CPAN::Distroprefs::Result') }) {
  0         0  
206 0         0 return $err;
207             }
208             # rethrow any exceptions that we did not generate
209 0         0 die $err;
210             } elsif (!@prefs) {
211             # the loader should have handled this, but just in case:
212 0         0 return $result->as_warning;
213             }
214             return $result->as_success({
215             prefs => [
216 0         0 map { CPAN::Distroprefs::Pref->new({ data => $_ }) } @prefs
  0         0  
217             ],
218             });
219 0         0 } });
220             }
221              
222             package CPAN::Distroprefs::Pref;
223              
224 14     14   63 use Carp ();
  14         13  
  14         10271  
225              
226 4     4   410 sub new { bless $_[1] => $_[0] }
227              
228 97     97   156 sub data { shift->{data} }
229              
230 2 50   2   4 sub has_any_match { $_[0]->data->{match} ? 1 : 0 }
231              
232             sub has_match {
233 59   50 59   56 my $match = $_[0]->data->{match} || return 0;
234 59 100       190 exists $match->{$_[1]} || exists $match->{"not_$_[1]"}
235             }
236              
237             sub has_valid_subkeys {
238 20         21 grep { exists $_[0]->data->{match}{$_} }
239 2     2   6 map { $_, "not_$_" }
  10         14  
240             $_[0]->match_attributes
241             }
242              
243             sub _pattern {
244 22     22   15 my $re = shift;
245 22         1052 my $p = eval sprintf 'qr{%s}', $re;
246 22 50       50 if ($@) {
247 0         0 $@ =~ s/\n$//;
248 0         0 die "Error in Distroprefs pattern qr{$re}\n$@";
249             }
250 22         23 return $p;
251             }
252              
253             sub _match_scalar {
254 17     17   13 my ($match, $data) = @_;
255 17         20 my $qr = _pattern($match);
256 17         90 return $data =~ /$qr/;
257             }
258              
259             sub _match_hash {
260 3     3   3 my ($match, $data) = @_;
261 3         7 for my $mkey (keys %$match) {
262 5         8 (my $dkey = $mkey) =~ s/^not_//;
263 5 50       11 my $val = defined $data->{$dkey} ? $data->{$dkey} : '';
264 5 100       6 if (_match_scalar($match->{$mkey}, $val)) {
265 3 100       13 return 0 if $mkey =~ /^not_/;
266             }
267             else {
268 2 100       12 return 0 if $mkey !~ /^not_/;
269             }
270             }
271 1         2 return 1;
272             }
273              
274             sub _match {
275 14     14   11 my ($self, $key, $data, $matcher) = @_;
276 14         16 my $m = $self->data->{match};
277 14 100       24 if (exists $m->{$key}) {
278 12 100       15 return 0 unless $matcher->($m->{$key}, $data);
279             }
280 10 100       23 if (exists $m->{"not_$key"}) {
281 8 100       13 return 0 if $matcher->($m->{"not_$key"}, $data);
282             }
283 7         22 return 1;
284             }
285              
286             sub _scalar_match {
287 8     8   10 my ($self, $key, $data) = @_;
288 8         14 return $self->_match($key, $data, \&_match_scalar);
289             }
290              
291             sub _hash_match {
292 3     3   4 my ($self, $key, $data) = @_;
293 3         7 return $self->_match($key, $data, \&_match_hash);
294             }
295              
296             # do not take the order of C because "module" is by far the
297             # slowest
298 13     13   23 sub match_attributes { qw(env distribution perl perlconfig module) }
299              
300             sub match_module {
301 3     3   3 my ($self, $modules) = @_;
302             return $self->_match("module", $modules, sub {
303 5     5   6 my($match, $data) = @_;
304 5         6 my $qr = _pattern($match);
305 5         8 for my $module (@$data) {
306 6 100       30 return 1 if $module =~ /$qr/;
307             }
308 2         7 return 0;
309 3         13 });
310             }
311              
312 8     8   12 sub match_distribution { shift->_scalar_match(distribution => @_) }
313 0     0   0 sub match_perl { shift->_scalar_match(perl => @_) }
314              
315 3     3   6 sub match_perlconfig { shift->_hash_match(perlconfig => @_) }
316 0     0   0 sub match_env { shift->_hash_match(env => @_) }
317              
318             sub matches {
319 11     11   24 my ($self, $arg) = @_;
320              
321 11         10 my $default_match = 0;
322 11         15 for my $key (grep { $self->has_match($_) } $self->match_attributes) {
  55         51  
323 14 50       23 unless (exists $arg->{$key}) {
324 0         0 Carp::croak "Can't match pref: missing argument key $key";
325             }
326 14         12 $default_match = 1;
327 14         13 my $val = $arg->{$key};
328             # make it possible to avoid computing things until we have to
329 14 50       22 if (ref($val) eq 'CODE') { $val = $val->() }
  0         0  
330 14         15 my $meth = "match_$key";
331 14 100       36 return 0 unless $self->$meth($val);
332             }
333              
334 4         10 return $default_match;
335             }
336              
337             1;
338              
339             __END__