8 use File::Copy qw/copy/;
9 use List::Util qw/max reduce/;
13 use CPAN::DistnameInfo;
14 use Capture::Tiny qw/capture/;
16 use Parse::CPAN::Packages::Fast;
19 use CPANPLUS::Dist::Gentoo::Atom;
20 use CPANPLUS::Dist::Gentoo::Maps;
22 use constant PACKAGES => File::Spec->catdir(
23 $ENV{HOME}, '.cpanplus', '02packages.details.txt.gz'
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';
33 my %is_on_cpan = map { $_ => 1 } qw/
34 Business-FedEx-DirectConnect
45 my ($indent, $fmt, @args) = @_;
46 $fmt = (' ' x ($indent * 3)) . $fmt;
50 my (@not_on_cpan, %name_mismatch, %version);
52 sub parse_portage_tree {
53 my $pcp = Parse::CPAN::Packages::Fast->new(PACKAGES);
55 my $ua = LWP::UserAgent->new;
56 $ua->agent('CPANPLUS::Dist::Gentoo gentooisms generator/1.0');
58 for my $category (qw/perl-core dev-perl/) {
59 p(0, "Browsing the $category category.\n");
61 my $cat_dir = File::Spec->catdir(PORTAGE, $category);
63 for my $pkg_dir (glob File::Spec->catdir($cat_dir, '*')) {
64 next unless -d $pkg_dir;
66 my $pkg_name = (File::Spec->splitdir($pkg_dir))[-1];
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/);
74 my @cmd = ('ebuild', $ebuild, 'help', '--debug');
76 (undef, my $err) = capture {
77 $ret = system { $cmd[0] } @cmd;
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";
84 my ($uri, $fqn_dist, $path);
85 while ($err =~ /SRC_URI=((['"]).*?\2|\S+)/gs) {
87 $uri =~ s{^(['"])(.*?)\1$}{$2}s;
90 if ($uri =~ m{cpan.*?/id/(\S+)}) {
92 $path = "authors/id/$fqn_dist";
93 } elsif ($uri =~ m{mirror://cpan/(\S+)}) {
95 } elsif ($is_on_cpan{$pkg_name} and $uri =~ m{/([^/\s]+)(?:\s|$)}) {
97 my ($top_level) = $archive =~ /^([^-]+)/;
98 $path = "modules/by-module/$top_level/$archive";
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";
108 p(2, "fetches $path\n");
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 ');
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) {
124 p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
125 push @not_on_cpan, "$category/$pkg_name";
128 $dist = CPAN::DistnameInfo->new($path);
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;
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
144 if ($mapped_version ne $pkg_version) {
145 my $str = "$dist_version => $mapped_version != $pkg_version";
146 p(2, colored($str, 'bright_cyan') . "\n");
148 $version{$dist_name} = [ $dist_version => $pkg_version ];
154 my $tm = File::Spec->catfile(PORTAGE, 'metadata', 'timestamp.chk');
155 return unless -e $tm;
156 open my $fh, '<', $tm;
161 my $already_parsed = 0;
162 my $timestamp = timestamp();
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] };
173 printf "Obsolete data file %s, regenerating data\n", STATE_FILE;
174 1 while unlink STATE_FILE;
178 unless ($already_parsed) {
179 parse_portage_tree();
187 printf "Data stored to %s\n", STATE_FILE;
193 p(1, "Not on the CPAN:\n");
194 p(2, "$_\n") for @not_on_cpan;
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);
201 my $fixed = $mapped_name eq $pkg_name;
202 my $eq = $fixed ? '==' : '!=';
204 "$dist_name => $mapped_name $eq $pkg_name",
205 $fixed ? 'bright_green' : 'bright_red'
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(
217 my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
221 if ($default_mapped_version ne $pkg_version) {
222 my $fixed = $mapped_version eq $pkg_version;
223 my $eq = $fixed ? '==' : '!=';
225 "$dist_version => $mapped_version $eq $pkg_version",
226 $fixed ? 'bright_green' : 'bright_red'
232 copy TARGET, BACKUP or die "copy failed: $!";
234 open my $src, '<', BACKUP;
235 open my $dst, '>', TARGET;
237 my $max = max map length, keys %name_mismatch;
239 SRC: while (<$src>) {
242 printf $dst "%s%s %s\n", $_, (' ' x ($max - length)), $name_mismatch{$_}
243 for sort keys %name_mismatch;
248 print "\n" . +(keys %name_mismatch) . " name mismatches found\n";