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