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