lib/CPAN/Distroprefs.pm

   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);
  46 BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
  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);
  60 BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
  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);
  67 BEGIN { @ISA = 'CPAN::Distroprefs::Result::Error' } ## no critic
  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);
  74 BEGIN { @ISA = 'CPAN::Distroprefs::Result' } ## no critic
  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
 204 sub has_match {
 205     my $match = $_[0]->data->{match} || return 0;
 206     exists $match->{$_[1]} || exists $match->{"not_$_[1]"}
 207 }
 208
 209 sub has_valid_subkeys {
 210     grep { exists $_[0]->data->{match}{$_} }
 211         map { $_, "not_$_" }
 212         $_[0]->match_attributes
 213 }
 214
 215 sub _pattern {
 216     my $re = shift;
 217     return eval sprintf 'qr{%s}', $re;
 218 }
 219
 220 sub _match_scalar {
 221     my ($match, $data) = @_;
 222     my $qr = _pattern($match);
 223     return $data =~ /$qr/;
 224 }
 225
 226 sub _match_hash {
 227     my ($match, $data) = @_;
 228     for my $mkey (keys %$match) {
 229         (my $dkey = $mkey) =~ s/^not_//;
 230         my $val = defined $data->{$dkey} ? $data->{$dkey} : '';
 231         if (_match_scalar($match->{$mkey}, $val)) {
 232             return 0 if $mkey =~ /^not_/;
 233         }
 234         else {
 235             return 0 if $mkey !~ /^not_/;
 236         }
 237     }
 238     return 1;
 239 }
 240
 241 sub _match {
 242     my ($self, $key, $data, $matcher) = @_;
 243     my $m = $self->data->{match};
 244     if (exists $m->{$key}) {
 245         return 0 unless $matcher->($m->{$key}, $data);
 246     }
 247     if (exists $m->{"not_$key"}) {
 248         return 0 if $matcher->($m->{"not_$key"}, $data);
 249     }
 250     return 1;
 251 }
 252
 253 sub _scalar_match {
 254     my ($self, $key, $data) = @_;
 255     return $self->_match($key, $data, \&_match_scalar);
 256 }
 257
 258 sub _hash_match {
 259     my ($self, $key, $data) = @_;
 260     return $self->_match($key, $data, \&_match_hash);
 261 }
 262
 263 # do not take the order of C<keys %$match> because "module" is by far the
 264 # slowest
 265 sub match_attributes { qw(env distribution perl perlconfig module) }
 266
 267 sub match_module {
 268     my ($self, $modules) = @_;
 269     return $self->_match("module", $modules, sub {
 270         my($match, $data) = @_;
 271         my $qr = _pattern($match);
 272         for my $module (@$data) {
 273             return 1 if $module =~ /$qr/;
 274         }
 275         return 0;
 276     });
 277 }
 278
 279 sub match_distribution { shift->_scalar_match(distribution => @_) }
 280 sub match_perl         { shift->_scalar_match(perl         => @_) }
 281
 282 sub match_perlconfig   { shift->_hash_match(perlconfig => @_) }
 283 sub match_env          { shift->_hash_match(env        => @_) }
 284
 285 sub matches {
 286     my ($self, $arg) = @_;
 287
 288     my $default_match = 0;
 289     for my $key (grep { $self->has_match($_) } $self->match_attributes) {
 290         unless (exists $arg->{$key}) {
 291             Carp::croak "Can't match pref: missing argument key $key";
 292         }
 293         $default_match = 1;
 294         my $val = $arg->{$key};
 295         # make it possible to avoid computing things until we have to
 296         if (ref($val) eq 'CODE') { $val = $val->() }
 297         my $meth = "match_$key";
 298         return 0 unless $self->$meth($val);
 299     }
 300
 301     return $default_match;
 302 }
 303
 304 1;
 305
 306 __END__
 307
 308 =head1 NAME
 309
 310 CPAN::Distroprefs -- read and match distroprefs
 311
 312 =head1 SYNOPSIS
 313
 314     use CPAN::Distroprefs;
 315
 316     my %info = (... distribution/environment info ...);
 317
 318     my $finder = CPAN::Distroprefs->find($prefs_dir, \%ext_map);
 319
 320     while (my $result = $finder->next) {
 321
 322         die $result->as_string if $result->is_fatal;
 323
 324         warn $result->as_string, next if $result->is_warning;
 325
 326         for my $pref (@{ $result->prefs }) {
 327             if ($pref->matches(\%info)) {
 328                 return $pref;
 329             }
 330         }
 331     }
 332
 333
 334 =head1 DESCRIPTION
 335
 336 This module encapsulates reading L<Distroprefs|CPAN> and matching them against CPAN distributions.
 337
 338 =head1 INTERFACE
 339
 340     my $finder = CPAN::Distroprefs->find($dir, \%ext_map);
 341
 342     while (my $result = $finder->next) { ... }
 343
 344 Build an iterator which finds distroprefs files in the given directory.
 345
 346 C<%ext_map> is a hashref whose keys are file extensions and whose values are
 347 modules used to load matching files:
 348
 349     {
 350         'yml' => 'YAML::Syck',
 351         'dd'  => 'Data::Dumper',
 352         ...
 353     }
 354
 355 Each time C<< $finder->next >> is called, the iterator returns one of two
 356 possible values:
 357
 358 =over
 359
 360 =item * a CPAN::Distroprefs::Result object
 361
 362 =item * C<undef>, indicating that no prefs files remain to be found
 363
 364 =back
 365
 366 =head1 RESULTS
 367
 368 L<C<find()>|/INTERFACE> returns CPAN::Distroprefs::Result objects to
 369 indicate success or failure when reading a prefs file.
 370
 371 =head2 Common
 372
 373 All results share some common attributes:
 374
 375 =head3 type
 376
 377 C<success>, C<warning>, or C<fatal>
 378
 379 =head3 file
 380
 381 the file from which these prefs were read, or to which this error refers (relative filename)
 382
 383 =head3 ext
 384
 385 the file's extension, which determines how to load it
 386
 387 =head3 dir
 388
 389 the directory the file was read from
 390
 391 =head3 abs
 392
 393 the absolute path to the file
 394
 395 =head2 Errors
 396
 397 Error results (warning and fatal) contain:
 398
 399 =head3 msg
 400
 401 the error message (usually either C<$!> or a YAML error)
 402
 403 =head2 Successes
 404
 405 Success results contain:
 406
 407 =head3 prefs
 408
 409 an arrayref of CPAN::Distroprefs::Pref objects
 410
 411 =head1 PREFS
 412
 413 CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
 414 They are constructed automatically as part of C<success> results from C<find()>.
 415
 416 =head3 data
 417
 418 the pref information as a hashref, suitable for e.g. passing to Kwalify
 419
 420 =head3 match_attributes
 421
 422 returns a list of the valid match attributes (see the Distroprefs section in L<CPAN>)
 423
 424 currently: C<env perl perlconfig distribution module>
 425
 426 =head3 has_any_match
 427
 428 true if this pref has a 'match' attribute at all
 429
 430 =head3 has_valid_subkeys
 431
 432 true if this pref has a 'match' attribute and at least one valid match attribute
 433
 434 =head3 matches
 435
 436   if ($pref->matches(\%arg)) { ... }
 437
 438 true if this pref matches the passed-in hashref, which must have a value for
 439 each of the C<match_attributes> (above)
 440
 441 =head1 LICENSE
 442
 443 This program is free software; you can redistribute it and/or modify it under
 444 the same terms as Perl itself.
 445
 446 =cut