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