This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update CPAN.pm to 1.93_53
[perl5.git] / lib / CPAN / Distroprefs.pm
CommitLineData
5254b38e
SP
1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2# vim: ts=4 sts=4 sw=4:
3
4use strict;
5package CPAN::Distroprefs;
6
7use vars qw($VERSION);
8$VERSION = '6';
9
10package CPAN::Distroprefs::Result;
11
12use File::Spec;
13
14sub new { bless $_[1] || {} => $_[0] }
15
16sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) }
17
18sub __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}
29BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') }
30BEGIN { __PACKAGE__->__cloner(as_fatal => 'Fatal') }
31BEGIN { __PACKAGE__->__cloner(as_success => 'Success') }
32
33sub __accessor {
34 my ($class, $key) = @_;
35 no strict 'refs';
36 *{$class . '::' . $key} = sub { $_[0]->{$key} };
37}
38BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) }
39
40sub is_warning { 0 }
41sub is_fatal { 0 }
42sub is_success { 0 }
43
44package CPAN::Distroprefs::Result::Error;
45use vars qw(@ISA);
f9916dde 46BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
5254b38e
SP
47BEGIN { __PACKAGE__->__accessor($_) for qw(msg) }
48
49sub 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
58package CPAN::Distroprefs::Result::Warning;
59use vars qw(@ISA);
f9916dde 60BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
5254b38e
SP
61sub is_warning { 1 }
62sub fmt_reason { "Error reading distroprefs file %s, skipping: %s" }
63sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." }
64
65package CPAN::Distroprefs::Result::Fatal;
66use vars qw(@ISA);
f9916dde 67BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
5254b38e
SP
68sub is_fatal { 1 }
69sub fmt_reason { "Error reading distroprefs file %s: %s" }
70sub fmt_unknown { "Unknown error reading distroprefs file %s." }
71
72package CPAN::Distroprefs::Result::Success;
73use vars qw(@ISA);
f9916dde 74BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
5254b38e
SP
75BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) }
76sub is_success { 1 }
77
78package CPAN::Distroprefs::Iterator;
79
80sub new { bless $_[1] => $_[0] }
81
82sub next { $_[0]->() }
83
84package CPAN::Distroprefs;
85
86use Carp ();
87use DirHandle;
88
89sub _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
95sub _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
113sub _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
140sub _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
150sub 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
194package CPAN::Distroprefs::Pref;
195
196use Carp ();
197
198sub new { bless $_[1] => $_[0] }
199
200sub data { shift->{data} }
201
202sub has_any_match { $_[0]->data->{match} ? 1 : 0 }
203
f9916dde
AK
204sub has_match {
205 my $match = $_[0]->data->{match} || return 0;
206 exists $match->{$_[1]} || exists $match->{"not_$_[1]"}
207}
5254b38e
SP
208
209sub has_valid_subkeys {
210 grep { exists $_[0]->data->{match}{$_} }
f9916dde 211 map { $_, "not_$_" }
5254b38e
SP
212 $_[0]->match_attributes
213}
214
215sub _pattern {
f9916dde 216 my $re = shift;
2f2071b1
AK
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
AK
223}
224
225sub _match_scalar {
226 my ($match, $data) = @_;
227 my $qr = _pattern($match);
228 return $data =~ /$qr/;
229}
230
231sub _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
246sub _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
258sub _scalar_match {
259 my ($self, $key, $data) = @_;
f9916dde 260 return $self->_match($key, $data, \&_match_scalar);
5254b38e
SP
261}
262
263sub _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
270sub match_attributes { qw(env distribution perl perlconfig module) }
271
272sub match_module {
273 my ($self, $modules) = @_;
f9916dde
AK
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
284sub match_distribution { shift->_scalar_match(distribution => @_) }
285sub match_perl { shift->_scalar_match(perl => @_) }
286
287sub match_perlconfig { shift->_hash_match(perlconfig => @_) }
288sub match_env { shift->_hash_match(env => @_) }
289
290sub 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
3091;
310
311__END__
312
313=head1 NAME
314
315CPAN::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
341This 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
349Build an iterator which finds distroprefs files in the given directory.
350
351C<%ext_map> is a hashref whose keys are file extensions and whose values are
352modules used to load matching files:
353
354 {
355 'yml' => 'YAML::Syck',
356 'dd' => 'Data::Dumper',
357 ...
358 }
359
360Each time C<< $finder->next >> is called, the iterator returns one of two
361possible 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
373L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to
374indicate success or failure when reading a prefs file.
375
376=head2 Common
377
378All results share some common attributes:
379
380=head3 type
381
382C<success>, C<warning>, or C<fatal>
383
384=head3 file
385
386the file from which these prefs were read, or to which this error refers (relative filename)
387
388=head3 ext
389
390the file's extension, which determines how to load it
391
392=head3 dir
393
394the directory the file was read from
395
396=head3 abs
397
398the absolute path to the file
399
400=head2 Errors
401
402Error results (warning and fatal) contain:
403
404=head3 msg
405
406the error message (usually either C<$!> or a YAML error)
407
408=head2 Successes
409
410Success results contain:
411
412=head3 prefs
413
414an arrayref of CPAN::Distroprefs::Pref objects
415
416=head1 PREFS
417
418CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
419They are constructed automatically as part of C<success> results from C<find()>.
420
421=head3 data
422
423the pref information as a hashref, suitable for e.g. passing to Kwalify
424
425=head3 match_attributes
426
427returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>)
428
429currently: C<env perl perlconfig distribution module>
430
431=head3 has_any_match
432
433true if this pref has a 'match' attribute at all
434
435=head3 has_valid_subkeys
436
437true 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
443true if this pref matches the passed-in hashref, which must have a value for
444each of the C<match_attributes> (above)
445
446=head1 LICENSE
447
448This program is free software; you can redistribute it and/or modify it under
449the same terms as Perl itself.
450
451=cut