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 use Capture::Tiny qw/capture/;
  15 use LWP::UserAgent;
  16 use Parse::CPAN::Packages::Fast;
  17
  18 use lib 'lib';
  19 use CPANPLUS::Dist::Gentoo::Atom;
  20 use CPANPLUS::Dist::Gentoo::Maps;
  21
  22 use constant PACKAGES    => File::Spec->catdir(
  23  $ENV{HOME}, '.cpanplus', '02packages.details.txt.gz'
  24 );
  25 use constant CPAN_MIRROR => 'http://www.cpan.org/';
  26 use constant PORTAGE     => '/usr/portage';
  27 use constant TARGET      => 'lib/CPANPLUS/Dist/Gentoo/Maps.pm';
  28 use constant BACKUP      => TARGET . '.bak';
  29 use constant STATE_FILE  => 'gentooisms.sto';
  30
  31 my %gentooism;
  32
  33 my %is_on_cpan = map { $_ => 1 } qw/
  34  Business-FedEx-DirectConnect
  35  CDDB_get
  36  CursesWidgets
  37  SpeedyCGI
  38  WattsUp-Daemon
  39  frontier-rpc
  40  gnome2-perl
  41  gnome2-wnck
  42 /;
  43
  44 sub p {
  45  my ($indent, $fmt, @args) = @_;
  46  $fmt = (' ' x ($indent * 3)) . $fmt;
  47  printf $fmt, @args;
  48 }
  49
  50 my (@not_on_cpan, %name_mismatch, %version);
  51
  52 sub parse_portage_tree {
  53  my $pcp = Parse::CPAN::Packages::Fast->new(PACKAGES);
  54
  55  my $ua = LWP::UserAgent->new;
  56  $ua->agent('CPANPLUS::Dist::Gentoo gentooisms generator/1.0');
  57
  58  for my $category (qw/perl-core dev-perl/) {
  59   p(0, "Browsing the $category category.\n");
  60
  61   my $cat_dir = File::Spec->catdir(PORTAGE, $category);
  62
  63   for my $pkg_dir (glob File::Spec->catdir($cat_dir, '*')) {
  64    next unless -d $pkg_dir;
  65
  66    my $pkg_name = (File::Spec->splitdir($pkg_dir))[-1];
  67
  68    my $last = reduce { $a->[1] > $b->[1] ? $a : $b }
  69                map [ $_, CPANPLUS::Dist::Gentoo::Atom->new_from_ebuild($_) ],
  70                 glob File::Spec->catfile($pkg_dir, "$pkg_name-*");
  71    my ($ebuild, $atom) = @$last;
  72    p(1, "%s/%s-%s\n", map $atom->$_, qw/category name version/);
  73
  74    my @cmd = ('ebuild', $ebuild, 'help', '--debug');
  75    my ($ret, $code);
  76    (undef, my $err) = capture {
  77     $ret  = system { $cmd[0] } @cmd;
  78     $code = $?;
  79    };
  80    if ($ret != 0 or $code == -1 or $code & 127 or $code >> 8) {
  81     die "system(\"@cmd\") returned $ret and/or failed with status $code";
  82    }
  83
  84    my ($uri, $fqn_dist, $path);
  85    while ($err =~ /SRC_URI=((['"]).*?\2|\S+)/gs) {
  86     $uri = $1;
  87     $uri =~ s{^(['"])(.*?)\1$}{$2}s;
  88    }
  89    if (defined $uri) {
  90     if ($uri =~ m{cpan.*?/id/(\S+)}) {
  91      $fqn_dist = $1;
  92      $path     = "authors/id/$fqn_dist";
  93     } elsif ($uri =~ m{mirror://cpan/(\S+)}) {
  94      $path     = $1;
  95     } elsif ($is_on_cpan{$pkg_name} and $uri =~ m{/([^/\s]+)(?:\s|$)}) {
  96      my $archive = $1;
  97      my ($top_level) = $archive =~ /^([^-]+)/;
  98      $path = "modules/by-module/$top_level/$archive";
  99     }
 100    }
 101
 102    unless (defined $path) {
 103     p(2, "doesn't seem to be fetching its tarball from a CPAN mirror.\n");
 104     p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
 105     push @not_on_cpan, "$category/$pkg_name";
 106     next;
 107    }
 108    p(2, "fetches $path\n");
 109
 110    my $dist;
 111    if (defined $fqn_dist) {
 112     $dist = eval { $pcp->distribution($fqn_dist) };
 113     p(2, defined $dist ? "is indexed on the CPAN\n" : 'is not indexed, but ');
 114    } else {
 115     p(2, 'is ');
 116    }
 117    unless (defined $dist) {
 118     print 'maybe on a CPAN mirror... ';
 119     my $r = $ua->head(CPAN_MIRROR . $path);
 120     if ($r and $r->code == 200) {
 121      print "yes\n";
 122     } else {
 123      print "no\n";
 124      p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
 125      push @not_on_cpan, "$category/$pkg_name";
 126      next;
 127     }
 128     $dist = CPAN::DistnameInfo->new($path);
 129    }
 130
 131    my $dist_name = $dist->dist;
 132    if ($dist_name ne $pkg_name) {
 133     p(2, colored("$dist_name => $pkg_name", 'bright_yellow') . "\n");
 134     $name_mismatch{$dist_name} = $pkg_name;
 135    }
 136
 137    my $pkg_version = $atom->version . '';
 138    $pkg_version =~ s/-r\d+$//;
 139    my $dist_version = $dist->version;
 140    my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
 141     undef, # default conversion
 142     $dist_version,
 143    );
 144    if ($mapped_version ne $pkg_version) {
 145     my $str = "$dist_version => $mapped_version != $pkg_version";
 146     p(2, colored($str, 'bright_cyan') . "\n");
 147    }
 148    $version{$dist_name} = [ $dist_version => $pkg_version ];
 149   }
 150  }
 151 }
 152
 153 sub timestamp {
 154  my $tm = File::Spec->catfile(PORTAGE, 'metadata', 'timestamp.chk');
 155  return unless -e $tm;
 156  open my $fh, '<', $tm;
 157  local $/;
 158  <$fh>;
 159 }
 160
 161 my $already_parsed = 0;
 162 my $timestamp = timestamp();
 163
 164 if (-e STATE_FILE) {
 165  my $data = Storable::retrieve(STATE_FILE);
 166  if ($data->[0] eq $timestamp) {
 167   printf "Data retrieved from %s\n", STATE_FILE;
 168   @not_on_cpan    = @{ $data->[1] };
 169   %name_mismatch  = %{ $data->[2] };
 170   %version        = %{ $data->[3] };
 171   $already_parsed = 1;
 172  } else {
 173   printf "Obsolete data file %s, regenerating data\n", STATE_FILE;
 174   1 while unlink STATE_FILE;
 175  }
 176 }
 177
 178 unless ($already_parsed) {
 179  parse_portage_tree();
 180  print  "\n";
 181  Storable::store([
 182   $timestamp,
 183   \@not_on_cpan,
 184   \%name_mismatch,
 185   \%version,
 186  ] => STATE_FILE);
 187  printf "Data stored to %s\n", STATE_FILE;
 188 }
 189
 190 print "\n";
 191 p(0, "Summary\n");
 192
 193 p(1, "Not on the CPAN:\n");
 194 p(2, "$_\n") for @not_on_cpan;
 195
 196 p(1, "Name mismatch:\n");
 197 for my $dist_name (sort keys %name_mismatch) {
 198  my $pkg_name    = $name_mismatch{$dist_name};
 199  my $mapped_name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($dist_name);
 200
 201  my $fixed = $mapped_name eq $pkg_name;
 202  my $eq    = $fixed ? '==' : '!=';
 203  my $str   = colored(
 204   "$dist_name => $mapped_name $eq $pkg_name",
 205   $fixed ? 'bright_green' : 'bright_red'
 206  );
 207  p(2, "$str\n");
 208 }
 209
 210 p(1, "Version mismatch:\n");
 211 for (sort keys %version) {
 212  my ($dist_version, $pkg_version) = @{$version{$_}};
 213  my $default_mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
 214   undef,
 215   $dist_version,
 216  );
 217  my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
 218   $_,
 219   $dist_version,
 220  );
 221  if ($default_mapped_version ne $pkg_version) {
 222   my $fixed = $mapped_version eq $pkg_version;
 223   my $eq    = $fixed ? '==' : '!=';
 224   my $str   = colored(
 225    "$dist_version => $mapped_version $eq $pkg_version",
 226    $fixed ? 'bright_green' : 'bright_red'
 227   );
 228   p(2, "$_: $str\n");
 229  }
 230 }
 231
 232 copy TARGET, BACKUP or die "copy failed: $!";
 233
 234 open my $src, '<', BACKUP;
 235 open my $dst, '>', TARGET;
 236
 237 my $max = max map length, keys %name_mismatch;
 238
 239 SRC: while (<$src>) {
 240  print $dst $_;
 241  if (/^__DATA__$/) {
 242   printf $dst "%s%s %s\n", $_, (' ' x ($max - length)), $name_mismatch{$_}
 243                                                    for sort keys %name_mismatch;
 244   last SRC;
 245  }
 246 }
 247
 248 print "\n" . +(keys %name_mismatch) . " name mismatches found\n";