Commit | Line | Data |
5254b38e |
1 | # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- |
2 | # vim: ts=4 sts=4 sw=4: |
3 | |
4 | use strict; |
5 | package CPAN::Distroprefs; |
6 | |
7 | use vars qw($VERSION); |
8 | $VERSION = '6'; |
9 | |
10 | package CPAN::Distroprefs::Result; |
11 | |
12 | use File::Spec; |
13 | |
14 | sub new { bless $_[1] || {} => $_[0] } |
15 | |
16 | sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) } |
17 | |
18 | sub __cloner { |
19 | my ($class, $name, $newclass) = @_; |
20 | $newclass = 'CPAN::Distroprefs::Result::' . $newclass; |
21 | no strict 'refs'; |
22 | *{$class . '::' . $name} = sub { |
23 | $newclass->new({ |
24 | %{ $_[0] }, |
25 | %{ $_[1] }, |
26 | }); |
27 | }; |
28 | } |
29 | BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') } |
30 | BEGIN { __PACKAGE__->__cloner(as_fatal => 'Fatal') } |
31 | BEGIN { __PACKAGE__->__cloner(as_success => 'Success') } |
32 | |
33 | sub __accessor { |
34 | my ($class, $key) = @_; |
35 | no strict 'refs'; |
36 | *{$class . '::' . $key} = sub { $_[0]->{$key} }; |
37 | } |
38 | BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) } |
39 | |
40 | sub is_warning { 0 } |
41 | sub is_fatal { 0 } |
42 | sub is_success { 0 } |
43 | |
44 | package CPAN::Distroprefs::Result::Error; |
45 | use vars qw(@ISA); |
f9916dde |
46 | BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic |
5254b38e |
47 | BEGIN { __PACKAGE__->__accessor($_) for qw(msg) } |
48 | |
49 | sub as_string { |
50 | my ($self) = @_; |
51 | if ($self->msg) { |
52 | return sprintf $self->fmt_reason, $self->file, $self->msg; |
53 | } else { |
54 | return sprintf $self->fmt_unknown, $self->file; |
55 | } |
56 | } |
57 | |
58 | package CPAN::Distroprefs::Result::Warning; |
59 | use vars qw(@ISA); |
f9916dde |
60 | BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic |
5254b38e |
61 | sub is_warning { 1 } |
62 | sub fmt_reason { "Error reading distroprefs file %s, skipping: %s" } |
63 | sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." } |
64 | |
65 | package CPAN::Distroprefs::Result::Fatal; |
66 | use vars qw(@ISA); |
f9916dde |
67 | BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic |
5254b38e |
68 | sub is_fatal { 1 } |
69 | sub fmt_reason { "Error reading distroprefs file %s: %s" } |
70 | sub fmt_unknown { "Unknown error reading distroprefs file %s." } |
71 | |
72 | package CPAN::Distroprefs::Result::Success; |
73 | use vars qw(@ISA); |
f9916dde |
74 | BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic |
5254b38e |
75 | BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) } |
76 | sub is_success { 1 } |
77 | |
78 | package CPAN::Distroprefs::Iterator; |
79 | |
80 | sub new { bless $_[1] => $_[0] } |
81 | |
82 | sub next { $_[0]->() } |
83 | |
84 | package CPAN::Distroprefs; |
85 | |
86 | use Carp (); |
87 | use DirHandle; |
88 | |
89 | sub _load_method { |
90 | my ($self, $loader, $result) = @_; |
91 | return '_load_yaml' if $loader eq 'CPAN' or $loader =~ /^YAML(::|$)/; |
92 | return '_load_' . $result->ext; |
93 | } |
94 | |
95 | sub _load_yaml { |
96 | my ($self, $loader, $result) = @_; |
97 | my $data = eval { |
98 | $loader eq 'CPAN' |
99 | ? $loader->_yaml_loadfile($result->abs) |
100 | : [ $loader->can('LoadFile')->($result->abs) ] |
101 | }; |
102 | if (my $err = $@) { |
103 | die $result->as_warning({ |
104 | msg => $err, |
105 | }); |
106 | } elsif (!$data) { |
107 | die $result->as_warning; |
108 | } else { |
109 | return @$data; |
110 | } |
111 | } |
112 | |
113 | sub _load_dd { |
114 | my ($self, $loader, $result) = @_; |
115 | my @data; |
116 | { |
117 | package CPAN::Eval; |
118 | # this caused a die in CPAN.pm, and I am leaving it 'fatal', though I'm |
119 | # not sure why we wouldn't just skip the file as we do for all other |
120 | # errors. -- hdp |
121 | my $abs = $result->abs; |
122 | open FH, "<$abs" or die $result->as_fatal(msg => "$!"); |
123 | local $/; |
124 | my $eval = <FH>; |
125 | close FH; |
126 | no strict; |
127 | eval $eval; |
128 | if (my $err = $@) { |
129 | die $result->as_warning({ msg => $err }); |
130 | } |
131 | my $i = 1; |
132 | while (${"VAR$i"}) { |
133 | push @data, ${"VAR$i"}; |
134 | $i++; |
135 | } |
136 | } |
137 | return @data; |
138 | } |
139 | |
140 | sub _load_st { |
141 | my ($self, $loader, $result) = @_; |
142 | # eval because Storable is never forward compatible |
143 | my @data = eval { @{scalar $loader->can('retrieve')->($result->abs) } }; |
144 | if (my $err = $@) { |
145 | die $result->as_warning({ msg => $err }); |
146 | } |
147 | return @data; |
148 | } |
149 | |
150 | sub find { |
151 | my ($self, $dir, $ext_map) = @_; |
152 | |
153 | my $dh = DirHandle->new($dir) or Carp::croak("Couldn't open '$dir': $!"); |
154 | my @files = sort $dh->read; |
155 | |
156 | # label the block so that we can use redo in the middle |
157 | return CPAN::Distroprefs::Iterator->new(sub { LOOP: { |
158 | return unless %$ext_map; |
159 | |
160 | local $_ = shift @files; |
161 | return unless defined; |
162 | redo if $_ eq '.' || $_ eq '..'; |
163 | |
164 | my $possible_ext = join "|", map { quotemeta } keys %$ext_map; |
165 | my ($ext) = /\.($possible_ext)$/ or redo; |
166 | my $loader = $ext_map->{$ext}; |
167 | |
168 | my $result = CPAN::Distroprefs::Result->new({ |
169 | file => $_, ext => $ext, dir => $dir |
170 | }); |
171 | # copied from CPAN.pm; is this ever actually possible? |
172 | redo unless -f $result->abs; |
173 | |
174 | my $load_method = $self->_load_method($loader, $result); |
175 | my @prefs = eval { $self->$load_method($loader, $result) }; |
176 | if (my $err = $@) { |
177 | if (ref($err) && eval { $err->isa('CPAN::Distroprefs::Result') }) { |
178 | return $err; |
179 | } |
180 | # rethrow any exceptions that we did not generate |
181 | die $err; |
182 | } elsif (!@prefs) { |
183 | # the loader should have handled this, but just in case: |
184 | return $result->as_warning; |
185 | } |
186 | return $result->as_success({ |
187 | prefs => [ |
188 | map { CPAN::Distroprefs::Pref->new({ data => $_ }) } @prefs |
189 | ], |
190 | }); |
191 | } }); |
192 | } |
193 | |
194 | package CPAN::Distroprefs::Pref; |
195 | |
196 | use Carp (); |
197 | |
198 | sub new { bless $_[1] => $_[0] } |
199 | |
200 | sub data { shift->{data} } |
201 | |
202 | sub has_any_match { $_[0]->data->{match} ? 1 : 0 } |
203 | |
f9916dde |
204 | sub has_match { |
205 | my $match = $_[0]->data->{match} || return 0; |
206 | exists $match->{$_[1]} || exists $match->{"not_$_[1]"} |
207 | } |
5254b38e |
208 | |
209 | sub has_valid_subkeys { |
210 | grep { exists $_[0]->data->{match}{$_} } |
f9916dde |
211 | map { $_, "not_$_" } |
5254b38e |
212 | $_[0]->match_attributes |
213 | } |
214 | |
215 | sub _pattern { |
f9916dde |
216 | my $re = shift; |
2f2071b1 |
217 | my $p = eval sprintf 'qr{%s}', $re; |
218 | if ($@) { |
219 | $@ =~ s/\n$//; |
220 | die "Error in Distroprefs pattern qr{$re}\n$@"; |
221 | } |
222 | return $p; |
f9916dde |
223 | } |
224 | |
225 | sub _match_scalar { |
226 | my ($match, $data) = @_; |
227 | my $qr = _pattern($match); |
228 | return $data =~ /$qr/; |
229 | } |
230 | |
231 | sub _match_hash { |
232 | my ($match, $data) = @_; |
233 | for my $mkey (keys %$match) { |
234 | (my $dkey = $mkey) =~ s/^not_//; |
235 | my $val = defined $data->{$dkey} ? $data->{$dkey} : ''; |
236 | if (_match_scalar($match->{$mkey}, $val)) { |
237 | return 0 if $mkey =~ /^not_/; |
238 | } |
239 | else { |
240 | return 0 if $mkey !~ /^not_/; |
241 | } |
242 | } |
243 | return 1; |
244 | } |
245 | |
246 | sub _match { |
247 | my ($self, $key, $data, $matcher) = @_; |
248 | my $m = $self->data->{match}; |
249 | if (exists $m->{$key}) { |
250 | return 0 unless $matcher->($m->{$key}, $data); |
251 | } |
252 | if (exists $m->{"not_$key"}) { |
253 | return 0 if $matcher->($m->{"not_$key"}, $data); |
254 | } |
255 | return 1; |
5254b38e |
256 | } |
257 | |
258 | sub _scalar_match { |
259 | my ($self, $key, $data) = @_; |
f9916dde |
260 | return $self->_match($key, $data, \&_match_scalar); |
5254b38e |
261 | } |
262 | |
263 | sub _hash_match { |
264 | my ($self, $key, $data) = @_; |
f9916dde |
265 | return $self->_match($key, $data, \&_match_hash); |
5254b38e |
266 | } |
267 | |
268 | # do not take the order of C<keys %$match> because "module" is by far the |
269 | # slowest |
270 | sub match_attributes { qw(env distribution perl perlconfig module) } |
271 | |
272 | sub match_module { |
273 | my ($self, $modules) = @_; |
f9916dde |
274 | return $self->_match("module", $modules, sub { |
275 | my($match, $data) = @_; |
276 | my $qr = _pattern($match); |
277 | for my $module (@$data) { |
278 | return 1 if $module =~ /$qr/; |
279 | } |
280 | return 0; |
281 | }); |
5254b38e |
282 | } |
283 | |
284 | sub match_distribution { shift->_scalar_match(distribution => @_) } |
285 | sub match_perl { shift->_scalar_match(perl => @_) } |
286 | |
287 | sub match_perlconfig { shift->_hash_match(perlconfig => @_) } |
288 | sub match_env { shift->_hash_match(env => @_) } |
289 | |
290 | sub matches { |
291 | my ($self, $arg) = @_; |
292 | |
293 | my $default_match = 0; |
294 | for my $key (grep { $self->has_match($_) } $self->match_attributes) { |
295 | unless (exists $arg->{$key}) { |
296 | Carp::croak "Can't match pref: missing argument key $key"; |
297 | } |
298 | $default_match = 1; |
299 | my $val = $arg->{$key}; |
300 | # make it possible to avoid computing things until we have to |
301 | if (ref($val) eq 'CODE') { $val = $val->() } |
302 | my $meth = "match_$key"; |
303 | return 0 unless $self->$meth($val); |
304 | } |
305 | |
306 | return $default_match; |
307 | } |
308 | |
309 | 1; |
310 | |
311 | __END__ |
312 | |
313 | =head1 NAME |
314 | |
315 | CPAN::Distroprefs -- read and match distroprefs |
316 | |
317 | =head1 SYNOPSIS |
318 | |
319 | use CPAN::Distroprefs; |
320 | |
321 | my %info = (... distribution/environment info ...); |
322 | |
323 | my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map); |
324 | |
325 | while (my $result = $finder->next) { |
326 | |
327 | die $result->as_string if $result->is_fatal; |
328 | |
94fe740e |
329 | warn($result->as_string), next if $result->is_warning; |
5254b38e |
330 | |
331 | for my $pref (@{ $result->prefs }) { |
332 | if ($pref->matches(\%info)) { |
333 | return $pref; |
334 | } |
335 | } |
336 | } |
337 | |
338 | |
339 | =head1 DESCRIPTION |
340 | |
341 | This module encapsulates reading L<Distroprefs|CPAN> and matching them against CPAN distributions. |
342 | |
343 | =head1 INTERFACE |
344 | |
345 | my $finder = CPAN::Distroprefs->find($dir, \%ext_map); |
346 | |
347 | while (my $result = $finder->next) { ... } |
348 | |
349 | Build an iterator which finds distroprefs files in the given directory. |
350 | |
351 | C<%ext_map> is a hashref whose keys are file extensions and whose values are |
352 | modules used to load matching files: |
353 | |
354 | { |
355 | 'yml' => 'YAML::Syck', |
356 | 'dd' => 'Data::Dumper', |
357 | ... |
358 | } |
359 | |
360 | Each time C<< $finder->next >> is called, the iterator returns one of two |
361 | possible values: |
362 | |
363 | =over |
364 | |
365 | =item * a CPAN::Distroprefs::Result object |
366 | |
367 | =item * C<undef>, indicating that no prefs files remain to be found |
368 | |
369 | =back |
370 | |
371 | =head1 RESULTS |
372 | |
373 | L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to |
374 | indicate success or failure when reading a prefs file. |
375 | |
376 | =head2 Common |
377 | |
378 | All results share some common attributes: |
379 | |
380 | =head3 type |
381 | |
382 | C<success>, C<warning>, or C<fatal> |
383 | |
384 | =head3 file |
385 | |
386 | the file from which these prefs were read, or to which this error refers (relative filename) |
387 | |
388 | =head3 ext |
389 | |
390 | the file's extension, which determines how to load it |
391 | |
392 | =head3 dir |
393 | |
394 | the directory the file was read from |
395 | |
396 | =head3 abs |
397 | |
398 | the absolute path to the file |
399 | |
400 | =head2 Errors |
401 | |
402 | Error results (warning and fatal) contain: |
403 | |
404 | =head3 msg |
405 | |
406 | the error message (usually either C<$!> or a YAML error) |
407 | |
408 | =head2 Successes |
409 | |
410 | Success results contain: |
411 | |
412 | =head3 prefs |
413 | |
414 | an arrayref of CPAN::Distroprefs::Pref objects |
415 | |
416 | =head1 PREFS |
417 | |
418 | CPAN::Distroprefs::Pref objects represent individual distroprefs documents. |
419 | They are constructed automatically as part of C<success> results from C<find()>. |
420 | |
421 | =head3 data |
422 | |
423 | the pref information as a hashref, suitable for e.g. passing to Kwalify |
424 | |
425 | =head3 match_attributes |
426 | |
427 | returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>) |
428 | |
429 | currently: C<env perl perlconfig distribution module> |
430 | |
431 | =head3 has_any_match |
432 | |
433 | true if this pref has a 'match' attribute at all |
434 | |
435 | =head3 has_valid_subkeys |
436 | |
437 | true if this pref has a 'match' attribute and at least one valid match attribute |
438 | |
439 | =head3 matches |
440 | |
441 | if ($pref->matches(\%arg)) { ... } |
442 | |
443 | true if this pref matches the passed-in hashref, which must have a value for |
444 | each of the C<match_attributes> (above) |
445 | |
446 | =head1 LICENSE |
447 | |
448 | This program is free software; you can redistribute it and/or modify it under |
449 | the same terms as Perl itself. |
450 | |
451 | =cut |