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     } elsif ($uri =~ m{mirror://cpan/(\S+)}) {
 141      $path           = $1;
 142     } elsif ($uri =~ m{/([^/\s]+)(?:\s|$)}) {
 143      my $archive     = $1;
 144      my ($top_level) = $archive =~ /^([^-]+)/;
 145      $path           = "modules/by-module/$top_level/$archive";
 146     }
 147    }
 148
 149    unless (defined $path) {
 150     p(2, "doesn't seem to be fetching its tarball from a CPAN mirror\n");
 151     p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
 152     push @not_on_cpan, "$category/$pkg_name";
 153     next;
 154    }
 155
 156    my $dist;
 157    if (defined $fqn_dist) {
 158     p(2, "is $fqn_dist indexed on the CPAN... ");
 159     $dist = do {
 160      local $@;
 161      eval { $pcp->distribution($fqn_dist) }
 162     };
 163     print defined $dist ? "yes\n" : "no\n";
 164    }
 165
 166    unless (defined $dist) {
 167     p(2, "can $path be found on a CPAN mirror... ");
 168     if (cpan_http_test($path)) {
 169      print "yes\n";
 170      $dist = CPAN::DistnameInfo->new($path);
 171     } else {
 172      print "no\n";
 173     }
 174    }
 175
 176    my ($pseudo_dist, $latest_dist);
 177
 178    unless (defined $dist) {
 179     $path =~ m{([^/\s]+)$} or die 'Could not get the last part of the path';
 180     my $archive  = $1;
 181     $pseudo_dist = CPAN::DistnameInfo->new($archive);
 182
 183     p(2, 'is ' . $pseudo_dist->dist . ' the name of a CPAN distribution... ');
 184     $latest_dist = do {
 185      local $@;
 186      eval { $pcp->latest_distribution($pseudo_dist->dist) };
 187     };
 188
 189     unless (defined $latest_dist) {
 190      print "no\n";
 191      (my $mod_name = $pkg_name) =~ s/-/::/g;
 192      p(2, "is $mod_name indexed in another CPAN distribution... ");
 193      $latest_dist = do {
 194       local $@;
 195       eval {
 196        my $module = $pcp->package($mod_name);
 197        defined $module ? $module->distribution : undef;
 198       };
 199      };
 200      if (defined $latest_dist) {
 201       # Re-forge the pseudo dist so that it will pick up the correct dist
 202       # name when looking for a mismatch.
 203       $pseudo_dist = CPAN::DistnameInfo->new(
 204        $latest_dist->dist . '-' . $pseudo_dist->version
 205                           . '.' . $pseudo_dist->extension
 206       );
 207      }
 208     }
 209
 210     my ($latest_file, $latest_author);
 211     if (defined $latest_dist) {
 212      $latest_file   = $latest_dist->filename;
 213      $latest_author = $latest_dist->cpanid;
 214      printf "yes, in %s by %s\n",
 215             $latest_file,
 216             (defined $latest_author ? $latest_author : 'unknown');
 217     } else {
 218      print "no\n";
 219     }
 220
 221     if (defined $latest_author) {
 222      my ($au, $a) = $latest_author =~ /^((.).)/ or die 'Author name too short';
 223      p(2, "is $archive in that author\'s CPAN directory... ");
 224      my $alternate_path = "authors/id/$a/$au/$latest_author/$archive";
 225      if ($alternate_path eq $path) {
 226       print "already checked\n";
 227      } elsif (cpan_http_test($alternate_path)) {
 228       $dist = CPAN::DistnameInfo->new($alternate_path);
 229       print "yes\n";
 230      } else {
 231       print "no\n";
 232      }
 233      unless (defined $dist) {
 234       push @missing,
 235            "$category/$pkg_name (latest is $latest_file by $latest_author)";
 236      }
 237     }
 238    }
 239
 240    unless (defined $dist) {
 241     if ($latest_dist or $is_on_cpan{$pkg_name}) {
 242      $dist = $pseudo_dist;
 243      p(2, "seems to be a CPAN distribution");
 244      if ($latest_dist) {
 245       print "\n";
 246      } else {
 247       # Implies $is_on_cpan{$pkg_name}
 248       print " (forced)\n";
 249       push @unfindable, "$category/$pkg_name";
 250      }
 251     } else {
 252      p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
 253      push @not_on_cpan, "$category/$pkg_name";
 254      next;
 255     }
 256    }
 257
 258    my $dist_name = $dist->dist;
 259    if ($dist_name ne $pkg_name) {
 260     p(2, colored("$dist_name => $pkg_name", 'bright_yellow') . "\n");
 261     $name_mismatch{$dist_name} = $pkg_name;
 262    }
 263
 264    my $pkg_version = $atom->version . '';
 265    $pkg_version =~ s/-r\d+$//;
 266    my $dist_version = $dist->version;
 267    my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
 268     undef, # default conversion
 269     $dist_version,
 270    );
 271    if ($mapped_version ne $pkg_version) {
 272     my $str = "$dist_version => $mapped_version != $pkg_version";
 273     p(2, colored($str, 'bright_cyan') . "\n");
 274    }
 275    $version{$dist_name} = [ $dist_version => $pkg_version ];
 276   }
 277  }
 278 }
 279
 280 my $already_parsed = 0;
 281
 282 if (-e STATE_FILE) {
 283  my $state = Storable::retrieve(STATE_FILE);
 284  if ($state->[0] == $timestamp) {
 285   printf "State retrieved from %s\n", STATE_FILE;
 286   @not_on_cpan   = @{ $state->[1] };
 287   @unfindable    = @{ $state->[2] };
 288   @missing       = @{ $state->[3] };
 289   %name_mismatch = %{ $state->[4] };
 290   %version       = %{ $state->[5] };
 291   $already_parsed = 1;
 292  } else {
 293   printf "Obsolete state file %s, regenerating\n", STATE_FILE;
 294   1 while unlink STATE_FILE;
 295  }
 296 }
 297
 298 unless ($already_parsed) {
 299  if (-e DATA_FILE) {
 300   my $data = Storable::retrieve(DATA_FILE);
 301   if ($data->[0] == $timestamp) {
 302    printf "Data retrieved from %s\n", DATA_FILE;
 303    %fetched_uri = %{ $data->[1] };
 304   } else {
 305    printf "Obsolete data file %s, regenerating\n", DATA_FILE;
 306    1 while unlink DATA_FILE;
 307   }
 308  }
 309
 310  parse_portage_tree();
 311  print  "\n";
 312
 313  Storable::store([
 314   $timestamp,
 315   \@not_on_cpan,
 316   \@unfindable,
 317   \@missing,
 318   \%name_mismatch,
 319   \%version,
 320  ] => STATE_FILE);
 321  printf "State stored to %s\n", STATE_FILE;
 322 }
 323
 324 print "\n";
 325 p(0, "Summary\n");
 326
 327 p(1, "Not on the CPAN:\n");
 328 p(2, "$_\n") for @not_on_cpan;
 329
 330 p(1, "Alleged to be on the CPAN, but unfindable:\n");
 331 p(2, "$_\n") for @unfindable;
 332
 333 p(1, "Only a different version is on the CPAN:\n");
 334 p(2, "$_\n") for @missing;
 335
 336 p(1, "Name mismatch:\n");
 337 for my $dist_name (sort keys %name_mismatch) {
 338  my $pkg_name    = $name_mismatch{$dist_name};
 339  my $mapped_name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($dist_name);
 340
 341  my $fixed = $mapped_name eq $pkg_name;
 342  my $eq    = $fixed ? '==' : '!=';
 343  my $str   = colored(
 344   "$dist_name => $mapped_name $eq $pkg_name",
 345   $fixed ? 'bright_green' : 'bright_red'
 346  );
 347  p(2, "$str\n");
 348 }
 349
 350 p(1, "Version mismatch:\n");
 351 for (sort keys %version) {
 352  my ($dist_version, $pkg_version) = @{$version{$_}};
 353  my $default_mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
 354   undef,
 355   $dist_version,
 356  );
 357  my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
 358   $_,
 359   $dist_version,
 360  );
 361  if ($default_mapped_version ne $pkg_version) {
 362   my $fixed = $mapped_version eq $pkg_version;
 363   my $eq    = $fixed ? '==' : '!=';
 364   my $str   = colored(
 365    "$dist_version => $mapped_version $eq $pkg_version",
 366    $fixed ? 'bright_green' : 'bright_red'
 367   );
 368   p(2, "$_: $str\n");
 369  }
 370 }
 371
 372 copy TARGET, BACKUP or die "copy failed: $!";
 373
 374 open my $src, '<', BACKUP;
 375 open my $dst, '>', TARGET;
 376
 377 my $max = max map length, keys %name_mismatch;
 378
 379 SRC: while (<$src>) {
 380  if (/^sub TIMESTAMP/) {
 381   print  $dst "sub TIMESTAMP () { $timestamp }\n";
 382  } elsif (/^__DATA__$/) {
 383   print  $dst "__DATA__\n";
 384   printf $dst "%s%s %s\n", $_, (' ' x ($max - length)), $name_mismatch{$_}
 385                                                    for sort keys %name_mismatch;
 386   last SRC;
 387  } else {
 388   print $dst $_;
 389  }
 390 }
 391
 392 print "\n" . +(keys %name_mismatch) . " name mismatches found\n";