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     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;
 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;
 256 }
 257
 258 sub _scalar_match {
 259     my ($self, $key, $data) = @_;
 260     return $self->_match($key, $data, \&_match_scalar);
 261 }
 262
 263 sub _hash_match {
 264     my ($self, $key, $data) = @_;
 265     return $self->_match($key, $data, \&_match_hash);
 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) = @_;
 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     });
 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
 329         warn($result->as_string), next if $result->is_warning;
 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