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