Commit | Line | Data |
---|---|---|
5254b38e SP |
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 SP |
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 SP |
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 SP |
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 SP |
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 A |
204 | sub has_match { |
205 | my $match = $_[0]->data->{match} || return 0; | |
206 | exists $match->{$_[1]} || exists $match->{"not_$_[1]"} | |
207 | } | |
5254b38e SP |
208 | |
209 | sub has_valid_subkeys { | |
210 | grep { exists $_[0]->data->{match}{$_} } | |
f9916dde | 211 | map { $_, "not_$_" } |
5254b38e SP |
212 | $_[0]->match_attributes |
213 | } | |
214 | ||
215 | sub _pattern { | |
f9916dde | 216 | my $re = shift; |
2f2071b1 A |
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 A |
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 SP |
256 | } |
257 | ||
258 | sub _scalar_match { | |
259 | my ($self, $key, $data) = @_; | |
f9916dde | 260 | return $self->_match($key, $data, \&_match_scalar); |
5254b38e SP |
261 | } |
262 | ||
263 | sub _hash_match { | |
264 | my ($self, $key, $data) = @_; | |
f9916dde | 265 | return $self->_match($key, $data, \&_match_hash); |
5254b38e SP |
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 A |
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 SP |
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 SP |
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 |