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