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' }
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' }
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' }
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' }
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 }
204 sub has_match { exists $_[0]->data->{match}{$_[1]} }
206 sub has_valid_subkeys {
207 grep { exists $_[0]->data->{match}{$_} }
208 $_[0]->match_attributes
212 my ($self, $key) = @_;
213 return eval sprintf 'qr{%s}', $self->data->{match}{$key};
217 my ($self, $key, $data) = @_;
218 my $qr = $self->_pattern($key);
219 return $data =~ /$qr/ ? 1 : 0;
223 my ($self, $key, $data) = @_;
224 my $match = $self->data->{match}{$key};
225 for my $mkey (keys %$match) {
226 my $val = defined $data->{$mkey} ? $data->{$mkey} : '';
227 my $qr = eval sprintf 'qr{%s}', $match->{$mkey};
228 return 0 unless $val =~ /$qr/;
233 # do not take the order of C<keys %$match> because "module" is by far the
235 sub match_attributes { qw(env distribution perl perlconfig module) }
238 my ($self, $modules) = @_;
239 my $qr = $self->_pattern('module');
240 for my $module (@$modules) {
241 return 1 if $module =~ /$qr/;
246 sub match_distribution { shift->_scalar_match(distribution => @_) }
247 sub match_perl { shift->_scalar_match(perl => @_) }
249 sub match_perlconfig { shift->_hash_match(perlconfig => @_) }
250 sub match_env { shift->_hash_match(env => @_) }
253 my ($self, $arg) = @_;
255 my $default_match = 0;
256 for my $key (grep { $self->has_match($_) } $self->match_attributes) {
257 unless (exists $arg->{$key}) {
258 Carp::croak "Can't match pref: missing argument key $key";
261 my $val = $arg->{$key};
262 # make it possible to avoid computing things until we have to
263 if (ref($val) eq 'CODE') { $val = $val->() }
264 my $meth = "match_$key";
265 return 0 unless $self->$meth($val);
268 return $default_match;
277 CPAN::Distroprefs -- read and match distroprefs
281 use CPAN::Distroprefs;
283 my %info = (... distribution/environment info ...);
285 my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map);
287 while (my $result = $finder->next) {
289 die $result->as_string if $result->is_fatal;
291 warn $result->as_string, next if $result->is_warning;
293 for my $pref (@{ $result->prefs }) {
294 if ($pref->matches(\%info)) {
303 This module encapsulates reading L<Distroprefs|CPAN> and matching them against CPAN distributions.
307 my $finder = CPAN::Distroprefs->find($dir, \%ext_map);
309 while (my $result = $finder->next) { ... }
311 Build an iterator which finds distroprefs files in the given directory.
313 C<%ext_map> is a hashref whose keys are file extensions and whose values are
314 modules used to load matching files:
317 'yml' => 'YAML::Syck',
318 'dd' => 'Data::Dumper',
322 Each time C<< $finder->next >> is called, the iterator returns one of two
327 =item * a CPAN::Distroprefs::Result object
329 =item * C<undef>, indicating that no prefs files remain to be found
335 L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to
336 indicate success or failure when reading a prefs file.
340 All results share some common attributes:
344 C<success>, C<warning>, or C<fatal>
348 the file from which these prefs were read, or to which this error refers (relative filename)
352 the file's extension, which determines how to load it
356 the directory the file was read from
360 the absolute path to the file
364 Error results (warning and fatal) contain:
368 the error message (usually either C<$!> or a YAML error)
372 Success results contain:
376 an arrayref of CPAN::Distroprefs::Pref objects
380 CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
381 They are constructed automatically as part of C<success> results from C<find()>.
385 the pref information as a hashref, suitable for e.g. passing to Kwalify
387 =head3 match_attributes
389 returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>)
391 currently: C<env perl perlconfig distribution module>
395 true if this pref has a 'match' attribute at all
397 =head3 has_valid_subkeys
399 true if this pref has a 'match' attribute and at least one valid match attribute
403 if ($pref->matches(\%arg)) { ... }
405 true if this pref matches the passed-in hashref, which must have a value for
406 each of the C<match_attributes> (above)
410 This program is free software; you can redistribute it and/or modify it under
411 the same terms as Perl itself.