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