1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2 # vim: ts=4 sts=4 sw=4:
5 package CPAN::Distroprefs;
10 package CPAN::Distroprefs::Result;
14 sub new { bless $_[1] || {} => $_[0] }
16 sub abs { File::Spec->catfile($_[0]->dir, $_[0]->file) }
19 my ($class, $name, $newclass) = @_;
20 $newclass = 'CPAN::Distroprefs::Result::' . $newclass;
22 *{$class . '::' . $name} = sub {
29 BEGIN { __PACKAGE__->__cloner(as_warning => 'Warning') }
30 BEGIN { __PACKAGE__->__cloner(as_fatal => 'Fatal') }
31 BEGIN { __PACKAGE__->__cloner(as_success => 'Success') }
34 my ($class, $key) = @_;
36 *{$class . '::' . $key} = sub { $_[0]->{$key} };
38 BEGIN { __PACKAGE__->__accessor($_) for qw(type file ext dir) }
44 package CPAN::Distroprefs::Result::Error;
46 BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
47 BEGIN { __PACKAGE__->__accessor($_) for qw(msg) }
52 return sprintf $self->fmt_reason, $self->file, $self->msg;
54 return sprintf $self->fmt_unknown, $self->file;
58 package CPAN::Distroprefs::Result::Warning;
60 BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
62 sub fmt_reason { "Error reading distroprefs file %s, skipping: %s" }
63 sub fmt_unknown { "Unknown error reading distroprefs file %s, skipping." }
65 package CPAN::Distroprefs::Result::Fatal;
67 BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
69 sub fmt_reason { "Error reading distroprefs file %s: %s" }
70 sub fmt_unknown { "Unknown error reading distroprefs file %s." }
72 package CPAN::Distroprefs::Result::Success;
74 BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
75 BEGIN { __PACKAGE__->__accessor($_) for qw(prefs extension) }
78 package CPAN::Distroprefs::Iterator;
80 sub new { bless $_[1] => $_[0] }
82 sub next { $_[0]->() }
84 package CPAN::Distroprefs;
90 my ($self, $loader, $result) = @_;
91 return '_load_yaml' if $loader eq 'CPAN' or $loader =~ /^YAML(::|$)/;
92 return '_load_' . $result->ext;
96 my ($self, $loader, $result) = @_;
99 ? $loader->_yaml_loadfile($result->abs)
100 : [ $loader->can('LoadFile')->($result->abs) ]
103 die $result->as_warning({
107 die $result->as_warning;
114 my ($self, $loader, $result) = @_;
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
121 my $abs = $result->abs;
122 open FH, "<$abs" or die $result->as_fatal(msg => "$!");
129 die $result->as_warning({ msg => $err });
133 push @data, ${"VAR$i"};
141 my ($self, $loader, $result) = @_;
142 # eval because Storable is never forward compatible
143 my @data = eval { @{scalar $loader->can('retrieve')->($result->abs) } };
145 die $result->as_warning({ msg => $err });
151 my ($self, $dir, $ext_map) = @_;
153 my $dh = DirHandle->new($dir) or Carp::croak("Couldn't open '$dir': $!");
154 my @files = sort $dh->read;
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;
160 local $_ = shift @files;
161 return unless defined;
162 redo if $_ eq '.' || $_ eq '..';
164 my $possible_ext = join "|", map { quotemeta } keys %$ext_map;
165 my ($ext) = /\.($possible_ext)$/ or redo;
166 my $loader = $ext_map->{$ext};
168 my $result = CPAN::Distroprefs::Result->new({
169 file => $_, ext => $ext, dir => $dir
171 # copied from CPAN.pm; is this ever actually possible?
172 redo unless -f $result->abs;
174 my $load_method = $self->_load_method($loader, $result);
175 my @prefs = eval { $self->$load_method($loader, $result) };
177 if (ref($err) && eval { $err->isa('CPAN::Distroprefs::Result') }) {
180 # rethrow any exceptions that we did not generate
183 # the loader should have handled this, but just in case:
184 return $result->as_warning;
186 return $result->as_success({
188 map { CPAN::Distroprefs::Pref->new({ data => $_ }) } @prefs
194 package CPAN::Distroprefs::Pref;
198 sub new { bless $_[1] => $_[0] }
200 sub data { shift->{data} }
202 sub has_any_match { $_[0]->data->{match} ? 1 : 0 }
205 my $match = $_[0]->data->{match} || return 0;
206 exists $match->{$_[1]} || exists $match->{"not_$_[1]"}
209 sub has_valid_subkeys {
210 grep { exists $_[0]->data->{match}{$_} }
212 $_[0]->match_attributes
217 my $p = eval sprintf 'qr{%s}', $re;
220 die "Error in Distroprefs pattern qr{$re}\n$@";
226 my ($match, $data) = @_;
227 my $qr = _pattern($match);
228 return $data =~ /$qr/;
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_/;
240 return 0 if $mkey !~ /^not_/;
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);
252 if (exists $m->{"not_$key"}) {
253 return 0 if $matcher->($m->{"not_$key"}, $data);
259 my ($self, $key, $data) = @_;
260 return $self->_match($key, $data, \&_match_scalar);
264 my ($self, $key, $data) = @_;
265 return $self->_match($key, $data, \&_match_hash);
268 # do not take the order of C<keys %$match> because "module" is by far the
270 sub match_attributes { qw(env distribution perl perlconfig module) }
273 my ($self, $modules) = @_;
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/;
284 sub match_distribution { shift->_scalar_match(distribution => @_) }
285 sub match_perl { shift->_scalar_match(perl => @_) }
287 sub match_perlconfig { shift->_hash_match(perlconfig => @_) }
288 sub match_env { shift->_hash_match(env => @_) }
291 my ($self, $arg) = @_;
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";
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);
306 return $default_match;
315 CPAN::Distroprefs -- read and match distroprefs
319 use CPAN::Distroprefs;
321 my %info = (... distribution/environment info ...);
323 my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map);
325 while (my $result = $finder->next) {
327 die $result->as_string if $result->is_fatal;
329 warn($result->as_string), next if $result->is_warning;
331 for my $pref (@{ $result->prefs }) {
332 if ($pref->matches(\%info)) {
341 This module encapsulates reading L<Distroprefs|CPAN> and matching them against CPAN distributions.
345 my $finder = CPAN::Distroprefs->find($dir, \%ext_map);
347 while (my $result = $finder->next) { ... }
349 Build an iterator which finds distroprefs files in the given directory.
351 C<%ext_map> is a hashref whose keys are file extensions and whose values are
352 modules used to load matching files:
355 'yml' => 'YAML::Syck',
356 'dd' => 'Data::Dumper',
360 Each time C<< $finder->next >> is called, the iterator returns one of two
365 =item * a CPAN::Distroprefs::Result object
367 =item * C<undef>, indicating that no prefs files remain to be found
373 L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to
374 indicate success or failure when reading a prefs file.
378 All results share some common attributes:
382 C<success>, C<warning>, or C<fatal>
386 the file from which these prefs were read, or to which this error refers (relative filename)
390 the file's extension, which determines how to load it
394 the directory the file was read from
398 the absolute path to the file
402 Error results (warning and fatal) contain:
406 the error message (usually either C<$!> or a YAML error)
410 Success results contain:
414 an arrayref of CPAN::Distroprefs::Pref objects
418 CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
419 They are constructed automatically as part of C<success> results from C<find()>.
423 the pref information as a hashref, suitable for e.g. passing to Kwalify
425 =head3 match_attributes
427 returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>)
429 currently: C<env perl perlconfig distribution module>
433 true if this pref has a 'match' attribute at all
435 =head3 has_valid_subkeys
437 true if this pref has a 'match' attribute and at least one valid match attribute
441 if ($pref->matches(\%arg)) { ... }
443 true if this pref matches the passed-in hashref, which must have a value for
444 each of the C<match_attributes> (above)
448 This program is free software; you can redistribute it and/or modify it under
449 the same terms as Perl itself.