8 use File::Copy qw<copy>;
9 use List::Util qw<max reduce>;
13 use CPAN::DistnameInfo 0.11;
15 use Capture::Tiny qw<capture>;
17 use Parse::CPAN::Packages::Fast;
20 use CPANPLUS::Dist::Gentoo::Atom;
21 use CPANPLUS::Dist::Gentoo::Maps;
23 use constant PACKAGES => File::Spec->catdir(
24 $ENV{HOME}, '.cpanplus', '02packages.details.txt.gz'
26 use constant CPAN_MIRROR => 'http://www.cpan.org/';
27 use constant PORTAGE => '/usr/portage';
28 use constant TARGET => 'lib/CPANPLUS/Dist/Gentoo/Maps.pm';
29 use constant BACKUP => TARGET . '.bak';
30 use constant DATA_FILE => 'gentooisms.data.sto';
31 use constant STATE_FILE => 'gentooisms.state.sto';
34 'Audio-CD-disc-cover' => 0,
35 'Video-Frequencies' => 0,
37 'WattsUp-Daemon' => 1,
41 my ($indent, $fmt, @args) = @_;
42 $fmt = (' ' x ($indent * 3)) . $fmt;
46 my $timestamp = CPANPLUS::Dist::Gentoo::Maps::get_portage_timestamp(PORTAGE);
54 unless (defined $ua) {
55 $ua = LWP::UserAgent->new;
56 $ua->agent('CPANPLUS::Dist::Gentoo gentooisms generator/1.0');
59 my $r = $ua->head(CPAN_MIRROR . $path);
61 return $r && $r->code == 200;
66 my (@not_on_cpan, @unfindable, @missing, %name_mismatch, %version);
68 sub parse_portage_tree {
69 my $pcp = Parse::CPAN::Packages::Fast->new(PACKAGES);
71 for my $category (qw<perl-core dev-perl>) {
72 p(0, "Browsing the $category category.\n");
74 my $cat_dir = File::Spec->catdir(PORTAGE, $category);
76 for my $pkg_dir (glob File::Spec->catdir($cat_dir, '*')) {
77 next unless -d $pkg_dir;
79 my $pkg_name = (File::Spec->splitdir($pkg_dir))[-1];
81 my $last = reduce { $a->[1] > $b->[1] ? $a : $b }
83 map [ $_, CPANPLUS::Dist::Gentoo::Atom->new_from_ebuild($_) ],
84 glob File::Spec->catfile($pkg_dir, "$pkg_name-*");
85 my ($ebuild, $atom) = @$last;
86 p(1, "%s/%s-%s\n", map $atom->$_, qw<category name version>);
88 if (exists $is_on_cpan{$pkg_name} and not $is_on_cpan{$pkg_name}) {
89 p(2, colored("$pkg_name is not a CPAN distribution (forced)", 'bright_red')
91 push @not_on_cpan, "$category/$pkg_name";
96 if (exists $fetched_uri{$ebuild}) {
97 $uri = $fetched_uri{$ebuild};
99 my @cmd = ('ebuild', $ebuild, 'help', '--debug');
101 (undef, my $err) = capture {
102 $ret = system { $cmd[0] } @cmd;
105 if ($ret != 0 or $code == -1 or $code & 127 or $code >> 8) {
106 die "system(\"@cmd\") returned $ret and/or failed with status $code";
110 while ($err =~ /([a-zA-Z0-9_]+)=((['"]).*?\3|\S+)/gs) {
113 $val =~ s{^(['"])(.*?)\1$}{$2}s;
117 $uri = $map{SRC_URI};
118 unless (defined $uri) {
119 my $author = $map{MODULE_AUTHOR};
120 if (defined $author) {
121 my ($au, $a) = $author =~ /^((.).)/;
122 my $dist_version = $map{MODULE_VERSION};
123 $dist_version = $last->[1] unless defined $dist_version;
124 $uri = "mirror://cpan/$a/$au/$author/$pkg_name/$dist_version.tar.gz";
128 $fetched_uri{$ebuild} = $uri;
135 my ($fqn_dist, $path);
137 if ($uri =~ m{cpan.*?/id/(\S+)}) {
139 $path = "authors/id/$fqn_dist";
140 } elsif ($uri =~ m{mirror://cpan/(\S+)}) {
142 } elsif ($uri =~ m{/([^/\s]+)(?:\s|$)}) {
144 my ($top_level) = $archive =~ /^([^-]+)/;
145 $path = "modules/by-module/$top_level/$archive";
149 unless (defined $path) {
150 p(2, "doesn't seem to be fetching its tarball from a CPAN mirror\n");
151 p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
152 push @not_on_cpan, "$category/$pkg_name";
157 if (defined $fqn_dist) {
158 p(2, "is $fqn_dist indexed on the CPAN... ");
161 eval { $pcp->distribution($fqn_dist) }
163 print defined $dist ? "yes\n" : "no\n";
166 unless (defined $dist) {
167 p(2, "can $path be found on a CPAN mirror... ");
168 if (cpan_http_test($path)) {
170 $dist = CPAN::DistnameInfo->new($path);
176 my ($pseudo_dist, $latest_dist);
178 unless (defined $dist) {
179 $path =~ m{([^/\s]+)$} or die 'Could not get the last part of the path';
181 $pseudo_dist = CPAN::DistnameInfo->new($archive);
183 p(2, 'is ' . $pseudo_dist->dist . ' the name of a CPAN distribution... ');
186 eval { $pcp->latest_distribution($pseudo_dist->dist) };
189 unless (defined $latest_dist) {
191 (my $mod_name = $pkg_name) =~ s/-/::/g;
192 p(2, "is $mod_name indexed in another CPAN distribution... ");
196 my $module = $pcp->package($mod_name);
197 defined $module ? $module->distribution : undef;
200 if (defined $latest_dist) {
201 # Re-forge the pseudo dist so that it will pick up the correct dist
202 # name when looking for a mismatch.
203 $pseudo_dist = CPAN::DistnameInfo->new(
204 $latest_dist->dist . '-' . $pseudo_dist->version
205 . '.' . $pseudo_dist->extension
210 my ($latest_file, $latest_author);
211 if (defined $latest_dist) {
212 $latest_file = $latest_dist->filename;
213 $latest_author = $latest_dist->cpanid;
214 printf "yes, in %s by %s\n",
216 (defined $latest_author ? $latest_author : 'unknown');
221 if (defined $latest_author) {
222 my ($au, $a) = $latest_author =~ /^((.).)/ or die 'Author name too short';
223 p(2, "is $archive in that author\'s CPAN directory... ");
224 my $alternate_path = "authors/id/$a/$au/$latest_author/$archive";
225 if ($alternate_path eq $path) {
226 print "already checked\n";
227 } elsif (cpan_http_test($alternate_path)) {
228 $dist = CPAN::DistnameInfo->new($alternate_path);
233 unless (defined $dist) {
235 "$category/$pkg_name (latest is $latest_file by $latest_author)";
240 unless (defined $dist) {
241 if ($latest_dist or $is_on_cpan{$pkg_name}) {
242 $dist = $pseudo_dist;
243 p(2, "seems to be a CPAN distribution");
247 # Implies $is_on_cpan{$pkg_name}
249 push @unfindable, "$category/$pkg_name";
252 p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
253 push @not_on_cpan, "$category/$pkg_name";
258 my $dist_name = $dist->dist;
259 if ($dist_name ne $pkg_name) {
260 p(2, colored("$dist_name => $pkg_name", 'bright_yellow') . "\n");
261 $name_mismatch{$dist_name} = $pkg_name;
264 my $pkg_version = $atom->version . '';
265 $pkg_version =~ s/-r\d+$//;
266 my $dist_version = $dist->version;
267 my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
268 undef, # default conversion
271 if ($mapped_version ne $pkg_version) {
272 my $str = "$dist_version => $mapped_version != $pkg_version";
273 p(2, colored($str, 'bright_cyan') . "\n");
275 $version{$dist_name} = [ $dist_version => $pkg_version ];
280 my $already_parsed = 0;
283 my $state = Storable::retrieve(STATE_FILE);
284 if ($state->[0] == $timestamp) {
285 printf "State retrieved from %s\n", STATE_FILE;
286 @not_on_cpan = @{ $state->[1] };
287 @unfindable = @{ $state->[2] };
288 @missing = @{ $state->[3] };
289 %name_mismatch = %{ $state->[4] };
290 %version = %{ $state->[5] };
293 printf "Obsolete state file %s, regenerating\n", STATE_FILE;
294 1 while unlink STATE_FILE;
298 unless ($already_parsed) {
300 my $data = Storable::retrieve(DATA_FILE);
301 if ($data->[0] == $timestamp) {
302 printf "Data retrieved from %s\n", DATA_FILE;
303 %fetched_uri = %{ $data->[1] };
305 printf "Obsolete data file %s, regenerating\n", DATA_FILE;
306 1 while unlink DATA_FILE;
310 parse_portage_tree();
321 printf "State stored to %s\n", STATE_FILE;
327 p(1, "Not on the CPAN:\n");
328 p(2, "$_\n") for @not_on_cpan;
330 p(1, "Alleged to be on the CPAN, but unfindable:\n");
331 p(2, "$_\n") for @unfindable;
333 p(1, "Only a different version is on the CPAN:\n");
334 p(2, "$_\n") for @missing;
336 p(1, "Name mismatch:\n");
337 for my $dist_name (sort keys %name_mismatch) {
338 my $pkg_name = $name_mismatch{$dist_name};
339 my $mapped_name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($dist_name);
341 my $fixed = $mapped_name eq $pkg_name;
342 my $eq = $fixed ? '==' : '!=';
344 "$dist_name => $mapped_name $eq $pkg_name",
345 $fixed ? 'bright_green' : 'bright_red'
350 p(1, "Version mismatch:\n");
351 for (sort keys %version) {
352 my ($dist_version, $pkg_version) = @{$version{$_}};
353 my $default_mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
357 my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
361 if ($default_mapped_version ne $pkg_version) {
362 my $fixed = $mapped_version eq $pkg_version;
363 my $eq = $fixed ? '==' : '!=';
365 "$dist_version => $mapped_version $eq $pkg_version",
366 $fixed ? 'bright_green' : 'bright_red'
372 copy TARGET, BACKUP or die "copy failed: $!";
374 open my $src, '<', BACKUP;
375 open my $dst, '>', TARGET;
377 my $max = max map length, keys %name_mismatch;
379 SRC: while (<$src>) {
380 if (/^sub TIMESTAMP/) {
381 print $dst "sub TIMESTAMP () { $timestamp }\n";
382 } elsif (/^__DATA__$/) {
383 print $dst "__DATA__\n";
384 printf $dst "%s%s %s\n", $_, (' ' x ($max - length)), $name_mismatch{$_}
385 for sort keys %name_mismatch;
392 print "\n" . +(keys %name_mismatch) . " name mismatches found\n";