]> git.vpit.fr Git - perl/modules/CPANPLUS-Dist-Gentoo.git/blob - samples/gengentooisms
Stop bundling author tests
[perl/modules/CPANPLUS-Dist-Gentoo.git] / 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 0.11;
14
15 use Capture::Tiny qw<capture>;
16 use LWP::UserAgent;
17 use Parse::CPAN::Packages::Fast;
18
19 use lib 'lib';
20 use CPANPLUS::Dist::Gentoo::Atom;
21 use CPANPLUS::Dist::Gentoo::Maps;
22
23 use constant PACKAGES    => File::Spec->catdir(
24  $ENV{HOME}, '.cpanplus', '02packages.details.txt.gz'
25 );
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';
32
33 my %is_on_cpan = (
34  'Audio-CD-disc-cover' => 0,
35  'Video-Frequencies'   => 0,
36  'Sphinx-Search'       => 1,
37  'WattsUp-Daemon'      => 1,
38 );
39
40 sub p {
41  my ($indent, $fmt, @args) = @_;
42  $fmt = (' ' x ($indent * 3)) . $fmt;
43  printf $fmt, @args;
44 }
45
46 my $timestamp = CPANPLUS::Dist::Gentoo::Maps::get_portage_timestamp(PORTAGE);
47 die 'Could not read the timestamp from the portage tree ' . PORTAGE . "\n"
48                                                       unless defined $timestamp;
49
50 {
51  my $ua;
52
53  sub cpan_http_test {
54   my ($path) = @_;
55
56   unless (defined $ua) {
57    $ua = LWP::UserAgent->new;
58    $ua->agent('CPANPLUS::Dist::Gentoo gentooisms generator/1.0');
59   }
60
61   my $r = $ua->head(CPAN_MIRROR . $path);
62
63   return $r && $r->code == 200;
64  }
65 }
66
67 my %fetched_uri;
68 my (@not_on_cpan, @unfindable, @missing, %name_mismatch, %version);
69
70 sub parse_portage_tree {
71  my $pcp = Parse::CPAN::Packages::Fast->new(PACKAGES);
72
73  for my $category (qw<perl-core dev-perl>) {
74   p(0, "Browsing the $category category.\n");
75
76   my $cat_dir = File::Spec->catdir(PORTAGE, $category);
77
78   for my $pkg_dir (glob File::Spec->catdir($cat_dir, '*')) {
79    next unless -d $pkg_dir;
80
81    my $pkg_name = (File::Spec->splitdir($pkg_dir))[-1];
82
83    my $last = reduce { $a->[1] > $b->[1] ? $a : $b }
84                grep $_->[1] != 9999,
85                 map [ $_, CPANPLUS::Dist::Gentoo::Atom->new_from_ebuild($_) ],
86                  glob File::Spec->catfile($pkg_dir, "$pkg_name-*");
87    my ($ebuild, $atom) = @$last;
88    p(1, "%s/%s-%s\n", map $atom->$_, qw<category name version>);
89
90    if (exists $is_on_cpan{$pkg_name} and not $is_on_cpan{$pkg_name}) {
91     p(2, colored("$pkg_name is not a CPAN distribution (forced)", 'bright_red')
92          . "\n");
93     push @not_on_cpan, "$category/$pkg_name";
94     next;
95    }
96
97    my $uri;
98    if (exists $fetched_uri{$ebuild}) {
99     $uri = $fetched_uri{$ebuild};
100    } else {
101     my @cmd = ('ebuild', $ebuild, 'help', '--debug');
102     my ($ret, $code);
103     (undef, my $err) = capture {
104      $ret  = system { $cmd[0] } @cmd;
105      $code = $?;
106     };
107     if ($ret != 0 or $code == -1 or $code & 127 or $code >> 8) {
108      die "system(\"@cmd\") returned $ret and/or failed with status $code";
109     }
110
111     my %map;
112     while ($err =~ /([a-zA-Z0-9_]+)=((['"]).*?\3|\S+)/gs) {
113      my $key = $1;
114      my $val = $2;
115      $val =~ s{^(['"])(.*?)\1$}{$2}s;
116      $map{$key} = $val;
117     }
118
119     $uri = $map{SRC_URI};
120     unless (defined $uri) {
121      my $author = $map{MODULE_AUTHOR};
122      if (defined $author) {
123       my ($au, $a)     = $author =~ /^((.).)/;
124       my $dist_version = $map{MODULE_VERSION};
125       $dist_version    = $last->[1] unless defined $dist_version;
126       $uri = "mirror://cpan/$a/$au/$author/$pkg_name/$dist_version.tar.gz";
127      }
128     }
129
130     $fetched_uri{$ebuild} = $uri;
131     Storable::store([
132      $timestamp,
133      \%fetched_uri,
134     ] => DATA_FILE);
135    }
136
137    my ($fqn_dist, $path);
138    if (defined $uri) {
139     if ($uri =~ m{cpan.*?/id/(\S+)}) {
140      $fqn_dist       = $1;
141      $path           = "authors/id/$fqn_dist";
142     } elsif ($uri =~ m{mirror://cpan/(\S+)}) {
143      $path           = $1;
144     } elsif ($uri =~ m{/([^/\s]+)(?:\s|$)}) {
145      my $archive     = $1;
146      my ($top_level) = $archive =~ /^([^-]+)/;
147      $path           = "modules/by-module/$top_level/$archive";
148     }
149    }
150
151    unless (defined $path) {
152     p(2, "doesn't seem to be fetching its tarball from a CPAN mirror\n");
153     p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
154     push @not_on_cpan, "$category/$pkg_name";
155     next;
156    }
157
158    my $dist;
159    if (defined $fqn_dist) {
160     p(2, "is $fqn_dist indexed on the CPAN... ");
161     $dist = do {
162      local $@;
163      eval { $pcp->distribution($fqn_dist) }
164     };
165     print defined $dist ? "yes\n" : "no\n";
166    }
167
168    unless (defined $dist) {
169     p(2, "can $path be found on a CPAN mirror... ");
170     if (cpan_http_test($path)) {
171      print "yes\n";
172      $dist = CPAN::DistnameInfo->new($path);
173     } else {
174      print "no\n";
175     }
176    }
177
178    my ($pseudo_dist, $latest_dist);
179
180    unless (defined $dist) {
181     $path =~ m{([^/\s]+)$} or die 'Could not get the last part of the path';
182     my $archive  = $1;
183     $pseudo_dist = CPAN::DistnameInfo->new($archive);
184
185     p(2, 'is ' . $pseudo_dist->dist . ' the name of a CPAN distribution... ');
186     $latest_dist = do {
187      local $@;
188      eval { $pcp->latest_distribution($pseudo_dist->dist) };
189     };
190
191     unless (defined $latest_dist) {
192      print "no\n";
193      (my $mod_name = $pkg_name) =~ s/-/::/g;
194      p(2, "is $mod_name indexed in another CPAN distribution... ");
195      $latest_dist = do {
196       local $@;
197       eval {
198        my $module = $pcp->package($mod_name);
199        defined $module ? $module->distribution : undef;
200       };
201      };
202      if (defined $latest_dist) {
203       # Re-forge the pseudo dist so that it will pick up the correct dist
204       # name when looking for a mismatch.
205       $pseudo_dist = CPAN::DistnameInfo->new(
206        $latest_dist->dist . '-' . $pseudo_dist->version
207                           . '.' . $pseudo_dist->extension
208       );
209      }
210     }
211
212     my ($latest_file, $latest_author);
213     if (defined $latest_dist) {
214      $latest_file   = $latest_dist->filename;
215      $latest_author = $latest_dist->cpanid;
216      printf "yes, in %s by %s\n",
217             $latest_file,
218             (defined $latest_author ? $latest_author : 'unknown');
219     } else {
220      print "no\n";
221     }
222
223     if (defined $latest_author) {
224      my ($au, $a) = $latest_author =~ /^((.).)/ or die 'Author name too short';
225      p(2, "is $archive in that author\'s CPAN directory... ");
226      my $alternate_path = "authors/id/$a/$au/$latest_author/$archive";
227      if ($alternate_path eq $path) {
228       print "already checked\n";
229      } elsif (cpan_http_test($alternate_path)) {
230       $dist = CPAN::DistnameInfo->new($alternate_path);
231       print "yes\n";
232      } else {
233       print "no\n";
234      }
235      unless (defined $dist) {
236       push @missing,
237            "$category/$pkg_name (latest is $latest_file by $latest_author)";
238      }
239     }
240    }
241
242    unless (defined $dist) {
243     if ($latest_dist or $is_on_cpan{$pkg_name}) {
244      $dist = $pseudo_dist;
245      p(2, "seems to be a CPAN distribution");
246      if ($latest_dist) {
247       print "\n";
248      } else {
249       # Implies $is_on_cpan{$pkg_name}
250       print " (forced)\n";
251       push @unfindable, "$category/$pkg_name";
252      }
253     } else {
254      p(2, colored("$pkg_name is not a CPAN distribution", 'bright_red') . "\n");
255      push @not_on_cpan, "$category/$pkg_name";
256      next;
257     }
258    }
259
260    my $dist_name = $dist->dist;
261    if ($dist_name ne $pkg_name) {
262     p(2, colored("$dist_name => $pkg_name", 'bright_yellow') . "\n");
263     $name_mismatch{$dist_name} = $pkg_name;
264    }
265
266    my $pkg_version = $atom->version . '';
267    $pkg_version =~ s/-r\d+$//;
268    my $dist_version = $dist->version;
269    my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
270     undef, # default conversion
271     $dist_version,
272    );
273    if ($mapped_version ne $pkg_version) {
274     my $str = "$dist_version => $mapped_version != $pkg_version";
275     p(2, colored($str, 'bright_cyan') . "\n");
276    }
277    $version{$dist_name} = [ $dist_version => $pkg_version ];
278   }
279  }
280 }
281
282 my $already_parsed = 0;
283
284 if (-e STATE_FILE) {
285  my $state = Storable::retrieve(STATE_FILE);
286  if ($state->[0] == $timestamp) {
287   printf "State retrieved from %s\n", STATE_FILE;
288   @not_on_cpan   = @{ $state->[1] };
289   @unfindable    = @{ $state->[2] };
290   @missing       = @{ $state->[3] };
291   %name_mismatch = %{ $state->[4] };
292   %version       = %{ $state->[5] };
293   $already_parsed = 1;
294  } else {
295   printf "Obsolete state file %s, regenerating\n", STATE_FILE;
296   1 while unlink STATE_FILE;
297  }
298 }
299
300 unless ($already_parsed) {
301  if (-e DATA_FILE) {
302   my $data = Storable::retrieve(DATA_FILE);
303   if ($data->[0] == $timestamp) {
304    printf "Data retrieved from %s\n", DATA_FILE;
305    %fetched_uri = %{ $data->[1] };
306   } else {
307    printf "Obsolete data file %s, regenerating\n", DATA_FILE;
308    1 while unlink DATA_FILE;
309   }
310  }
311
312  parse_portage_tree();
313  print  "\n";
314
315  Storable::store([
316   $timestamp,
317   \@not_on_cpan,
318   \@unfindable,
319   \@missing,
320   \%name_mismatch,
321   \%version,
322  ] => STATE_FILE);
323  printf "State stored to %s\n", STATE_FILE;
324 }
325
326 print "\n";
327 p(0, "Summary\n");
328
329 p(1, "Not on the CPAN:\n");
330 p(2, "$_\n") for @not_on_cpan;
331
332 p(1, "Alleged to be on the CPAN, but unfindable:\n");
333 p(2, "$_\n") for @unfindable;
334
335 p(1, "Only a different version is on the CPAN:\n");
336 p(2, "$_\n") for @missing;
337
338 p(1, "Name mismatch:\n");
339 for my $dist_name (sort keys %name_mismatch) {
340  my $pkg_name    = $name_mismatch{$dist_name};
341  my $mapped_name = CPANPLUS::Dist::Gentoo::Maps::name_c2g($dist_name);
342
343  my $fixed = $mapped_name eq $pkg_name;
344  my $eq    = $fixed ? '==' : '!=';
345  my $str   = colored(
346   "$dist_name => $mapped_name $eq $pkg_name",
347   $fixed ? 'bright_green' : 'bright_red'
348  );
349  p(2, "$str\n");
350 }
351
352 p(1, "Version mismatch:\n");
353 for (sort keys %version) {
354  my ($dist_version, $pkg_version) = @{$version{$_}};
355  my $default_mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
356   undef,
357   $dist_version,
358  );
359  my $mapped_version = CPANPLUS::Dist::Gentoo::Maps::version_c2g(
360   $_,
361   $dist_version,
362  );
363  if ($default_mapped_version ne $pkg_version) {
364   my $fixed = $mapped_version eq $pkg_version;
365   my $eq    = $fixed ? '==' : '!=';
366   my $str   = colored(
367    "$dist_version => $mapped_version $eq $pkg_version",
368    $fixed ? 'bright_green' : 'bright_red'
369   );
370   p(2, "$_: $str\n");
371  }
372 }
373
374 copy TARGET, BACKUP or die "copy failed: $!";
375
376 open my $src, '<', BACKUP;
377 open my $dst, '>', TARGET;
378
379 my $max = max map length, keys %name_mismatch;
380
381 SRC: while (<$src>) {
382  if (/^sub TIMESTAMP/) {
383   print  $dst "sub TIMESTAMP () { $timestamp }\n";
384  } elsif (/^__DATA__$/) {
385   print  $dst "__DATA__\n";
386   printf $dst "%s%s %s\n", $_, (' ' x ($max - length)), $name_mismatch{$_}
387                                                    for sort keys %name_mismatch;
388   last SRC;
389  } else {
390   print $dst $_;
391  }
392 }
393
394 print "\n" . +(keys %name_mismatch) . " name mismatches found\n";