#!/usr/bin/env perl
-# This scrit is meant to guess gentooisms by looking into the portage tree.
-# A really good one would use the CPANPLUS API to check if the dist name
-# candidates are really on CPAN.
-
use strict;
use warnings;
use Fatal;
-use Cwd qw/cwd/;
-use List::Util qw/max/;
+use File::Spec;
use File::Copy qw/copy/;
+use List::Util qw/max reduce/;
+use Storable ();
+use Term::ANSIColor;
-use constant PORTAGE => '/usr/portage';
-use constant TARGET => 'lib/CPANPLUS/Dist/Gentoo/Maps.pm';
-use constant BACKUP => TARGET . '.bak';
+use CPAN::DistnameInfo;
+use Capture::Tiny qw/capture/;
+use LWP::UserAgent;
+use Parse::CPAN::Packages::Fast;
-my %gentooism;
+use lib 'lib';
+use CPANPLUS::Dist::Gentoo::Atom;
+use CPANPLUS::Dist::Gentoo::Maps;
-my %where = (
- 'Audio-CD-disc-cover' => 1,
- 'aww' => 0,
- 'frontier-rpc' => 1,
- 'gimp-perl' => 1,
- 'gnome2-wnck' => 1,
- 'HTML-Object' => 0,
- 'JKFlow' => 0,
- 'PDF-Create' => 0,
+use constant PACKAGES => File::Spec->catdir(
+ $ENV{HOME}, '.cpanplus', '02packages.details.txt.gz'
);
+use constant CPAN_MIRROR => 'http://www.cpan.org/';
+use constant PORTAGE => '/usr/portage';
+use constant TARGET => 'lib/CPANPLUS/Dist/Gentoo/Maps.pm';
+use constant BACKUP => TARGET . '.bak';
+use constant STATE_FILE => 'gentooisms.sto';
-my $cwd = cwd();
-
-for my $category (qw/perl-core dev-perl/) {
- my $dir = PORTAGE . '/' . $category;
- chdir $dir;
- for my $name (<*>) {
- next unless -d $name;
- my $eb = (sort glob "$dir/$name/$name-*")[-1];
- open my $fh, '<', $eb;
- my ($pn, $on_cpan);
- $on_cpan = $where{$name} if exists $where{$name};
- while (<$fh>) {
- $on_cpan = 1 if not defined $on_cpan
- and /(?:MODULE_AUTHOR|SRC_URI=.*?(?i:cpan))/;
- if (not defined $pn and /_PN?=(.*)/) {
- $pn = $1;
- if ($pn =~ /^\s*["']?\s*\$\{PN?\}/) {
- undef $pn;
- next;
+my %gentooism;
+
+my %is_on_cpan = map { $_ => 1 } qw/
+ Business-FedEx-DirectConnect
+ CDDB_get
+ CursesWidgets
+ SpeedyCGI
+ WattsUp-Daemon
+ frontier-rpc
+ gnome2-perl
+ gnome2-wnck
+/;
+
+sub p {
+ my ($indent, $fmt, @args) = @_;
+ $fmt = (' ' x ($indent * 3)) . $fmt;
+ printf $fmt, @args;
+}
+
+my (@not_on_cpan, %name_mismatch, %version);
+
+sub parse_portage_tree {
+ my $pcp = Parse::CPAN::Packages::Fast->new(PACKAGES);
+
+ my $ua = LWP::UserAgent->new;
+ $ua->agent('CPANPLUS::Dist::Gentoo gentooisms generator/1.0');
+
+ for my $category (qw/perl-core dev-perl/) {
+ p(0, "Browsing the $category category.\n");
+
+ my $cat_dir = File::Spec->catdir(PORTAGE, $category);
+
+ for my $pkg_dir (glob File::Spec->catdir($cat_dir, '*')) {
+ next unless -d $pkg_dir;
+
+ my $pkg_name = (File::Spec->splitdir($pkg_dir))[-1];
+
+ my $last = reduce { $a->[1] > $b->[1] ? $a : $b }
+ map [ $_, CPANPLUS::Dist::Gentoo::Atom->new_from_ebuild($_) ],
+ glob File::Spec->catfile($pkg_dir, "$pkg_name-*");
+ my ($ebuild, $atom) = @$last;
+ p(1, "%s/%s-%s\n", map $atom->$_, qw/category name version/);
+
+ my @cmd = ('ebuild', $ebuild, 'help', '--debug');
+ my ($ret, $code);
+ (undef, my $err) = capture {
+ $ret = system { $cmd[0] } @cmd;
+ $code = $?;
+ };
+ if ($ret != 0 or $code == -1 or $code & 127 or $code >> 8) {
+ die "system(\"@cmd\") returned $ret and/or failed with status $code";
+ }
+
+ my ($uri, $fqn_dist, $path);
+ while ($err =~ /SRC_URI=((['"]).*?\2|\S+)/gs) {
+ $uri = $1;
+ $uri =~ s{^(['"])(.*?)\1$}{$2}s;
+ }
+ if (defined $uri) {
+ if ($uri =~ m{cpan.*?/id/(\S+)}) {
+ $fqn_dist = $1;
+ $path = "authors/id/$fqn_dist";
+ } elsif ($uri =~ m{mirror://cpan/(\S+)}) {
+ $path = $1;
+ } elsif ($is_on_cpan{$pkg_name} and $uri =~ m{/([^/\s]+)(?:\s|$)}) {
+ my $archive = $1;
+ my ($top_level) = $archive =~ /^([^-]+)/;
+ $path = "modules/by-module/$top_level/$archive";
}
- $pn =~ s!\$[{(][^/]*?[})]!!g;
- $pn =~ s!\$\{P?V.*?\}!!g;
- $pn =~ s/^\s*["']?\s*-*\s*//;
- $pn =~ s/\s*-*\s*["']?\s*$//;
- $pn =~ s/-\d+\..*//;
- if ($pn =~ m!\$\{PN?(/.*?/(?:.*/?)?)\}!) {
- my $s = $1;
- $s .= '/' if $s =~ tr!/!! <= 2;
- eval "(\$pn = \$name) =~ s$s";
+ }
+
+ unless (defined $path) {
+ p(2, "doesn't seem to be fetching its tarball from a CPAN mirror.\n");
+ p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
+ push @not_on_cpan, "$category/$pkg_name";
+ next;
+ }
+ p(2, "fetches $path\n");
+
+ my $dist;
+ if (defined $fqn_dist) {
+ $dist = eval { $pcp->distribution($fqn_dist) };
+ p(2, defined $dist ? "is indexed on the CPAN\n" : 'is not indexed, but ');
+ } else {
+ p(2, 'is ');
+ }
+ unless (defined $dist) {
+ print 'maybe on a CPAN mirror... ';
+ my $r = $ua->head(CPAN_MIRROR . $path);
+ if ($r and $r->code == 200) {
+ print "yes\n";
+ } else {
+ print "no\n";
+ p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
+ push @not_on_cpan, "$category/$pkg_name";
+ next;
}
+ $dist = CPAN::DistnameInfo->new($path);
}
- }
- if ($pn and $pn ne $name) {
- if ($on_cpan) {
- $gentooism{$pn} = $name;
- } elsif (not defined $on_cpan) {
- print STDERR "'$pn' => '$name' may not be on CPAN\n";
+
+ my $dist_name = $dist->dist;
+ if ($dist_name ne $pkg_name) {
+ p(2, colored("$dist_name => $pkg_name", 'bright_yellow') . "\n");
+ $name_mismatch{$dist_name} = $pkg_name;
+ }
+
+ my $pkg_version = $atom->version . '';
+ $pkg_version =~ s/-r\d+$//;
+ my $dist_version = $dist->version;
+ my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
+ undef, # default conversion
+ $dist_version,
+ );
+ if ($mapped_version ne $pkg_version) {
+ my $str = "$dist_version => $mapped_version != $pkg_version";
+ p(2, colored($str, 'bright_cyan') . "\n");
}
+ $version{$dist_name} = [ $dist_version => $pkg_version ];
}
}
}
-chdir $cwd;
+sub timestamp {
+ my $tm = File::Spec->catfile(PORTAGE, 'metadata', 'timestamp.chk');
+ return unless -e $tm;
+ open my $fh, '<', $tm;
+ local $/;
+ <$fh>;
+}
+
+my $already_parsed = 0;
+my $timestamp = timestamp();
+
+if (-e STATE_FILE) {
+ my $data = Storable::retrieve(STATE_FILE);
+ if ($data->[0] eq $timestamp) {
+ printf "Data retrieved from %s\n", STATE_FILE;
+ @not_on_cpan = @{ $data->[1] };
+ %name_mismatch = %{ $data->[2] };
+ %version = %{ $data->[3] };
+ $already_parsed = 1;
+ } else {
+ printf "Obsolete data file %s, regenerating data\n", STATE_FILE;
+ 1 while unlink STATE_FILE;
+ }
+}
+
+unless ($already_parsed) {
+ parse_portage_tree();
+ print "\n";
+ Storable::store([
+ $timestamp,
+ \@not_on_cpan,
+ \%name_mismatch,
+ \%version,
+ ] => STATE_FILE);
+ printf "Data stored to %s\n", STATE_FILE;
+}
+
+print "\n";
+p(0, "Summary\n");
+
+p(1, "Not on the CPAN:\n");
+p(2, "$_\n") for @not_on_cpan;
+
+p(1, "Name mismatch:\n");
+for my $dist_name (sort keys %name_mismatch) {
+ my $pkg_name = $name_mismatch{$dist_name};
+ my $mapped_name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($dist_name);
+
+ my $fixed = $mapped_name eq $pkg_name;
+ my $eq = $fixed ? '==' : '!=';
+ my $str = colored(
+ "$dist_name => $mapped_name $eq $pkg_name",
+ $fixed ? 'bright_green' : 'bright_red'
+ );
+ p(2, "$str\n");
+}
+
+p(1, "Version mismatch:\n");
+for (sort keys %version) {
+ my ($dist_version, $pkg_version) = @{$version{$_}};
+ my $default_mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
+ undef,
+ $dist_version,
+ );
+ my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
+ $_,
+ $dist_version,
+ );
+ if ($default_mapped_version ne $pkg_version) {
+ my $fixed = $mapped_version eq $pkg_version;
+ my $eq = $fixed ? '==' : '!=';
+ my $str = colored(
+ "$dist_version => $mapped_version $eq $pkg_version",
+ $fixed ? 'bright_green' : 'bright_red'
+ );
+ p(2, "$_: $str\n");
+ }
+}
copy TARGET, BACKUP or die "copy failed: $!";
open my $src, '<', BACKUP;
open my $dst, '>', TARGET;
-my $max = max map length, keys %gentooism;
+my $max = max map length, keys %name_mismatch;
SRC: while (<$src>) {
print $dst $_;
if (/^__DATA__$/) {
- printf $dst "%s%s %s\n", $_, (' ' x ($max - length)), $gentooism{$_}
- for sort keys %gentooism;
+ printf $dst "%s%s %s\n", $_, (' ' x ($max - length)), $name_mismatch{$_}
+ for sort keys %name_mismatch;
last SRC;
}
}
-print STDERR +(keys %gentooism) . " gentooisms found\n";
-
+print "\n" . +(keys %name_mismatch) . " name mismatches found\n";
projects / perl / modules / CPANPLUS-Dist-Gentoo.git / blobdiff