8 use File::Copy qw/copy/;
9 use List::Util qw/max reduce/;
13 use CPAN::DistnameInfo;
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$//;
22 no warnings 'redefine';
23 *CPAN::DistnameInfo::new = $new_cdi_new;
26 use Capture::Tiny qw/capture/;
28 use Parse::CPAN::Packages::Fast;
31 use CPANPLUS::Dist::Gentoo::Atom;
32 use CPANPLUS::Dist::Gentoo::Maps;
34 use constant PACKAGES => File::Spec->catdir(
35 $ENV{HOME}, '.cpanplus', '02packages.details.txt.gz'
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';
45 'Audio-CD-disc-cover' => 0,
46 'WattsUp-Daemon' => 1,
50 my ($indent, $fmt, @args) = @_;
51 $fmt = (' ' x ($indent * 3)) . $fmt;
56 my $tm = File::Spec->catfile(PORTAGE, 'metadata', 'timestamp.chk');
58 open my $fh, '<', $tm;
63 my $timestamp = timestamp();
71 unless (defined $ua) {
72 $ua = LWP::UserAgent->new;
73 $ua->agent('CPANPLUS::Dist::Gentoo gentooisms generator/1.0');
76 my $r = $ua->head(CPAN_MIRROR . $path);
78 return $r && $r->code == 200;
83 my (@not_on_cpan, @unfindable, @missing, %name_mismatch, %version);
85 sub parse_portage_tree {
86 my $pcp = Parse::CPAN::Packages::Fast->new(PACKAGES);
88 for my $category (qw/perl-core dev-perl/) {
89 p(0, "Browsing the $category category.\n");
91 my $cat_dir = File::Spec->catdir(PORTAGE, $category);
93 for my $pkg_dir (glob File::Spec->catdir($cat_dir, '*')) {
94 next unless -d $pkg_dir;
96 my $pkg_name = (File::Spec->splitdir($pkg_dir))[-1];
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')
101 push @not_on_cpan, "$category/$pkg_name";
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/);
112 if (exists $fetched_uri{$ebuild}) {
113 $uri = $fetched_uri{$ebuild};
115 my @cmd = ('ebuild', $ebuild, 'help', '--debug');
117 (undef, my $err) = capture {
118 $ret = system { $cmd[0] } @cmd;
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";
125 while ($err =~ /SRC_URI=((['"]).*?\2|\S+)/gs) {
127 $uri =~ s{^(['"])(.*?)\1$}{$2}s;
129 $fetched_uri{$ebuild} = $uri;
136 my ($fqn_dist, $path);
138 if ($uri =~ m{cpan.*?/id/(\S+)}) {
140 $path = "authors/id/$fqn_dist";
141 $is_on_cpan{$pkg_name} = 1;
142 } elsif ($uri =~ m{mirror://cpan/(\S+)}) {
144 $is_on_cpan{$pkg_name} = 1;
145 } elsif ($uri =~ m{/([^/\s]+)(?:\s|$)}) {
147 my ($top_level) = $archive =~ /^([^-]+)/;
148 $path = "modules/by-module/$top_level/$archive";
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";
158 p(2, "fetches $path\n");
161 if (defined $fqn_dist) {
162 p(2, 'is indexed on the CPAN... ');
165 eval { $pcp->distribution($fqn_dist) }
167 print defined $dist ? "yes\n" : "no\n";
170 unless (defined $dist) {
171 p(2, 'can directly be found on a CPAN mirror... ');
172 if (cpan_http_test($path)) {
174 $dist = CPAN::DistnameInfo->new($path);
180 my ($pseudo_dist, $latest_dist);
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';
186 $pseudo_dist = CPAN::DistnameInfo->new($archive);
189 eval { $pcp->latest_distribution($pseudo_dist->dist) };
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",
197 (defined $latest_author ? $latest_author : 'unknown');
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);
214 unless (defined $dist) {
216 "$category/$pkg_name (latest is $latest_file by $latest_author)";
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";
227 p(2, "seems to come from the CPAN anyway\n");
229 p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
230 push @not_on_cpan, "$category/$pkg_name";
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;
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
248 if ($mapped_version ne $pkg_version) {
249 my $str = "$dist_version => $mapped_version != $pkg_version";
250 p(2, colored($str, 'bright_cyan') . "\n");
252 $version{$dist_name} = [ $dist_version => $pkg_version ];
257 my $already_parsed = 0;
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] };
270 printf "Obsolete state file %s, regenerating\n", STATE_FILE;
271 1 while unlink STATE_FILE;
275 unless ($already_parsed) {
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] };
282 printf "Obsolete data file %s, regenerating\n", DATA_FILE;
283 1 while unlink DATA_FILE;
287 parse_portage_tree();
298 printf "State stored to %s\n", STATE_FILE;
304 p(1, "Not on the CPAN:\n");
305 p(2, "$_\n") for @not_on_cpan;
307 p(1, "Alleged to be on the CPAN, but unfindable:\n");
308 p(2, "$_\n") for @unfindable;
310 p(1, "Only a different version is on the CPAN:\n");
311 p(2, "$_\n") for @missing;
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);
318 my $fixed = $mapped_name eq $pkg_name;
319 my $eq = $fixed ? '==' : '!=';
321 "$dist_name => $mapped_name $eq $pkg_name",
322 $fixed ? 'bright_green' : 'bright_red'
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(
334 my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
338 if ($default_mapped_version ne $pkg_version) {
339 my $fixed = $mapped_version eq $pkg_version;
340 my $eq = $fixed ? '==' : '!=';
342 "$dist_version => $mapped_version $eq $pkg_version",
343 $fixed ? 'bright_green' : 'bright_red'
349 copy TARGET, BACKUP or die "copy failed: $!";
351 open my $src, '<', BACKUP;
352 open my $dst, '>', TARGET;
354 my $max = max map length, keys %name_mismatch;
356 SRC: while (<$src>) {
359 printf $dst "%s%s %s\n", $_, (' ' x ($max - length)), $name_mismatch{$_}
360 for sort keys %name_mismatch;
365 print "\n" . +(keys %name_mismatch) . " name mismatches found\n";