samples/gengentooisms

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Fatal;
   7 use File::Spec;
   8 use File::Copy qw<copy>;
   9 use List::Util qw<max reduce>;
  10 use Storable ();
  11 use Term::ANSIColor;
  12
  13 use CPAN::DistnameInfo 0.11;
  14
  15 use Capture::Tiny qw<capture>;
  16 use LWP::UserAgent;
  17 use Parse::CPAN::Packages::Fast;
  18
  19 use lib 'lib';
  20 use CPANPLUS::Dist::Gentoo::Atom;
  21 use CPANPLUS::Dist::Gentoo::Maps;
  22
  23 use constant PACKAGES    => File::Spec->catdir(
  24  $ENV{HOME}, '.cpanplus', '02packages.details.txt.gz'
  25 );
  26 use constant CPAN_MIRROR => 'http://www.cpan.org/';
  27 use constant PORTAGE     => '/usr/portage';
  28 use constant TARGET      => 'lib/CPANPLUS/Dist/Gentoo/Maps.pm';
  29 use constant BACKUP      => TARGET . '.bak';
  30 use constant DATA_FILE   => 'gentooisms.data.sto';
  31 use constant STATE_FILE  => 'gentooisms.state.sto';
  32
  33 my %is_on_cpan = (
  34  'Audio-CD-disc-cover' => 0,
  35  'WattsUp-Daemon'      => 1,
  36 );
  37
  38 sub p {
  39  my ($indent, $fmt, @args) = @_;
  40  $fmt = (' ' x ($indent * 3)) . $fmt;
  41  printf $fmt, @args;
  42 }
  43
  44 sub timestamp {
  45  my $tm = File::Spec->catfile(PORTAGE, 'metadata', 'timestamp.chk');
  46  return unless -e $tm;
  47  open my $fh, '<', $tm;
  48  local $/;
  49  <$fh>;
  50 }
  51
  52 my $timestamp = timestamp();
  53
  54 {
  55  my $ua;
  56
  57  sub cpan_http_test {
  58   my ($path) = @_;
  59
  60   unless (defined $ua) {
  61    $ua = LWP::UserAgent->new;
  62    $ua->agent('CPANPLUS::Dist::Gentoo gentooisms generator/1.0');
  63   }
  64
  65   my $r = $ua->head(CPAN_MIRROR . $path);
  66
  67   return $r && $r->code == 200;
  68  }
  69 }
  70
  71 my %fetched_uri;
  72 my (@not_on_cpan, @unfindable, @missing, %name_mismatch, %version);
  73
  74 sub parse_portage_tree {
  75  my $pcp = Parse::CPAN::Packages::Fast->new(PACKAGES);
  76
  77  for my $category (qw<perl-core dev-perl>) {
  78   p(0, "Browsing the $category category.\n");
  79
  80   my $cat_dir = File::Spec->catdir(PORTAGE, $category);
  81
  82   for my $pkg_dir (glob File::Spec->catdir($cat_dir, '*')) {
  83    next unless -d $pkg_dir;
  84
  85    my $pkg_name = (File::Spec->splitdir($pkg_dir))[-1];
  86
  87    my $last = reduce { $a->[1] > $b->[1] ? $a : $b }
  88                grep $_->[1] != 9999,
  89                 map [ $_, CPANPLUS::Dist::Gentoo::Atom->new_from_ebuild($_) ],
  90                  glob File::Spec->catfile($pkg_dir, "$pkg_name-*");
  91    my ($ebuild, $atom) = @$last;
  92    p(1, "%s/%s-%s\n", map $atom->$_, qw<category name version>);
  93
  94    if (exists $is_on_cpan{$pkg_name} and not $is_on_cpan{$pkg_name}) {
  95     p(2, colored("$pkg_name is not a CPAN distribution (forced)", 'bright_red')
  96          . "\n");
  97     push @not_on_cpan, "$category/$pkg_name";
  98     next;
  99    }
 100
 101    my $uri;
 102    if (exists $fetched_uri{$ebuild}) {
 103     $uri = $fetched_uri{$ebuild};
 104    } else {
 105     my @cmd = ('ebuild', $ebuild, 'help', '--debug');
 106     my ($ret, $code);
 107     (undef, my $err) = capture {
 108      $ret  = system { $cmd[0] } @cmd;
 109      $code = $?;
 110     };
 111     if ($ret != 0 or $code == -1 or $code & 127 or $code >> 8) {
 112      die "system(\"@cmd\") returned $ret and/or failed with status $code";
 113     }
 114
 115     while ($err =~ /SRC_URI=((['"]).*?\2|\S+)/gs) {
 116      $uri = $1;
 117      $uri =~ s{^(['"])(.*?)\1$}{$2}s;
 118     }
 119     $fetched_uri{$ebuild} = $uri;
 120     Storable::store([
 121      $timestamp,
 122      \%fetched_uri,
 123     ] => DATA_FILE);
 124    }
 125
 126    my ($fqn_dist, $path);
 127    if (defined $uri) {
 128     if ($uri =~ m{cpan.*?/id/(\S+)}) {
 129      $fqn_dist = $1;
 130      $path     = "authors/id/$fqn_dist";
 131      $is_on_cpan{$pkg_name} = 1;
 132     } elsif ($uri =~ m{mirror://cpan/(\S+)}) {
 133      $path     = $1;
 134      $is_on_cpan{$pkg_name} = 1;
 135     } elsif ($uri =~ m{/([^/\s]+)(?:\s|$)}) {
 136      my $archive = $1;
 137      my ($top_level) = $archive =~ /^([^-]+)/;
 138      $path = "modules/by-module/$top_level/$archive";
 139     }
 140    }
 141
 142    unless (defined $path) {
 143     p(2, "doesn't seem to be fetching its tarball from a CPAN mirror\n");
 144     p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
 145     push @not_on_cpan, "$category/$pkg_name";
 146     next;
 147    }
 148    p(2, "fetches $path\n");
 149
 150    my $dist;
 151    if (defined $fqn_dist) {
 152     p(2, 'is indexed on the CPAN... ');
 153     $dist = do {
 154      local $@;
 155      eval { $pcp->distribution($fqn_dist) }
 156     };
 157     print defined $dist ? "yes\n" : "no\n";
 158    }
 159
 160    unless (defined $dist) {
 161     p(2, 'can directly be found on a CPAN mirror... ');
 162     if (cpan_http_test($path)) {
 163      print "yes\n";
 164      $dist = CPAN::DistnameInfo->new($path);
 165     } else {
 166      print "no\n";
 167     }
 168    }
 169
 170    my ($pseudo_dist, $latest_dist);
 171
 172    unless (defined $dist) {
 173     p(2, 'has the same name as a distribution on the CPAN... ');
 174     $path =~ m{([^/\s]+)$} or die 'Could not get the last part of the path';
 175     my $archive  = $1;
 176     $pseudo_dist = CPAN::DistnameInfo->new($archive);
 177     $latest_dist = do {
 178      local $@;
 179      eval { $pcp->latest_distribution($pseudo_dist->dist) };
 180     };
 181     my ($latest_file, $latest_author);
 182     if (defined $latest_dist) {
 183      $latest_file   = $latest_dist->filename;
 184      $latest_author = $latest_dist->cpanid;
 185      printf "yes, %s by %s\n",
 186             $latest_file,
 187             (defined $latest_author ? $latest_author : 'unknown');
 188     } else {
 189      print "no\n";
 190     }
 191
 192     if (defined $latest_author) {
 193      my ($au, $a) = $latest_author =~ /^((.).)/ or die 'Author name too short';
 194      p(2, 'is in that author\'s CPAN directory... ');
 195      my $alternate_path = "authors/id/$a/$au/$latest_author/$archive";
 196      if ($alternate_path eq $path) {
 197       print "already checked\n";
 198      } elsif (cpan_http_test($alternate_path)) {
 199       $dist = CPAN::DistnameInfo->new($alternate_path);
 200       print "yes\n";
 201      } else {
 202       print "no\n";
 203      }
 204      unless (defined $dist) {
 205       push @missing,
 206            "$category/$pkg_name (latest is $latest_file by $latest_author)";
 207      }
 208     }
 209    }
 210
 211    unless (defined $dist) {
 212     if ($latest_dist or $is_on_cpan{$pkg_name}) {
 213      $dist = $pseudo_dist;
 214      unless ($latest_dist) {
 215       push @unfindable, "$category/$pkg_name";
 216      }
 217      p(2, "seems to come from the CPAN anyway\n");
 218     } else {
 219      p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
 220      push @not_on_cpan, "$category/$pkg_name";
 221      next;
 222     }
 223    }
 224
 225    my $dist_name = $dist->dist;
 226    if ($dist_name ne $pkg_name) {
 227     p(2, colored("$dist_name => $pkg_name", 'bright_yellow') . "\n");
 228     $name_mismatch{$dist_name} = $pkg_name;
 229    }
 230
 231    my $pkg_version = $atom->version . '';
 232    $pkg_version =~ s/-r\d+$//;
 233    my $dist_version = $dist->version;
 234    my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
 235     undef, # default conversion
 236     $dist_version,
 237    );
 238    if ($mapped_version ne $pkg_version) {
 239     my $str = "$dist_version => $mapped_version != $pkg_version";
 240     p(2, colored($str, 'bright_cyan') . "\n");
 241    }
 242    $version{$dist_name} = [ $dist_version => $pkg_version ];
 243   }
 244  }
 245 }
 246
 247 my $already_parsed = 0;
 248
 249 if (-e STATE_FILE) {
 250  my $state = Storable::retrieve(STATE_FILE);
 251  if ($state->[0] eq $timestamp) {
 252   printf "State retrieved from %s\n", STATE_FILE;
 253   @not_on_cpan   = @{ $state->[1] };
 254   @unfindable    = @{ $state->[2] };
 255   @missing       = @{ $state->[3] };
 256   %name_mismatch = %{ $state->[4] };
 257   %version       = %{ $state->[5] };
 258   $already_parsed = 1;
 259  } else {
 260   printf "Obsolete state file %s, regenerating\n", STATE_FILE;
 261   1 while unlink STATE_FILE;
 262  }
 263 }
 264
 265 unless ($already_parsed) {
 266  if (-e DATA_FILE) {
 267   my $data = Storable::retrieve(DATA_FILE);
 268   if ($data->[0] eq $timestamp) {
 269    printf "Data retrieved from %s\n", DATA_FILE;
 270    %fetched_uri = %{ $data->[1] };
 271   } else {
 272    printf "Obsolete data file %s, regenerating\n", DATA_FILE;
 273    1 while unlink DATA_FILE;
 274   }
 275  }
 276
 277  parse_portage_tree();
 278  print  "\n";
 279
 280  Storable::store([
 281   $timestamp,
 282   \@not_on_cpan,
 283   \@unfindable,
 284   \@missing,
 285   \%name_mismatch,
 286   \%version,
 287  ] => STATE_FILE);
 288  printf "State stored to %s\n", STATE_FILE;
 289 }
 290
 291 print "\n";
 292 p(0, "Summary\n");
 293
 294 p(1, "Not on the CPAN:\n");
 295 p(2, "$_\n") for @not_on_cpan;
 296
 297 p(1, "Alleged to be on the CPAN, but unfindable:\n");
 298 p(2, "$_\n") for @unfindable;
 299
 300 p(1, "Only a different version is on the CPAN:\n");
 301 p(2, "$_\n") for @missing;
 302
 303 p(1, "Name mismatch:\n");
 304 for my $dist_name (sort keys %name_mismatch) {
 305  my $pkg_name    = $name_mismatch{$dist_name};
 306  my $mapped_name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($dist_name);
 307
 308  my $fixed = $mapped_name eq $pkg_name;
 309  my $eq    = $fixed ? '==' : '!=';
 310  my $str   = colored(
 311   "$dist_name => $mapped_name $eq $pkg_name",
 312   $fixed ? 'bright_green' : 'bright_red'
 313  );
 314  p(2, "$str\n");
 315 }
 316
 317 p(1, "Version mismatch:\n");
 318 for (sort keys %version) {
 319  my ($dist_version, $pkg_version) = @{$version{$_}};
 320  my $default_mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
 321   undef,
 322   $dist_version,
 323  );
 324  my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
 325   $_,
 326   $dist_version,
 327  );
 328  if ($default_mapped_version ne $pkg_version) {
 329   my $fixed = $mapped_version eq $pkg_version;
 330   my $eq    = $fixed ? '==' : '!=';
 331   my $str   = colored(
 332    "$dist_version => $mapped_version $eq $pkg_version",
 333    $fixed ? 'bright_green' : 'bright_red'
 334   );
 335   p(2, "$_: $str\n");
 336  }
 337 }
 338
 339 copy TARGET, BACKUP or die "copy failed: $!";
 340
 341 open my $src, '<', BACKUP;
 342 open my $dst, '>', TARGET;
 343
 344 my $max = max map length, keys %name_mismatch;
 345
 346 SRC: while (<$src>) {
 347  print $dst $_;
 348  if (/^__DATA__$/) {
 349   printf $dst "%s%s %s\n", $_, (' ' x ($max - length)), $name_mismatch{$_}
 350                                                    for sort keys %name_mismatch;
 351   last SRC;
 352  }
 353 }
 354
 355 print "\n" . +(keys %name_mismatch) . " name mismatches found\n";