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