samples/gengentooisms

   1 #!/usr/bin/env perl
   2
   3 # This scrit is meant to guess gentooisms by looking into the portage tree.
   4 # A really good one would use the CPANPLUS API to check if the dist name
   5 # candidates are really on CPAN.
   6
   7 use strict;
   8 use warnings;
   9
  10 use Fatal;
  11 use Cwd qw/cwd/;
  12 use List::Util qw/max/;
  13 use File::Copy qw/copy/;
  14
  15 use constant PORTAGE => '/usr/portage';
  16 use constant TARGET  => 'lib/CPANPLUS/Dist/Gentoo/Maps.pm';
  17 use constant BACKUP  => TARGET . '.bak';
  18
  19 my %gentooism;
  20
  21 my %where = (
  22  'Audio-CD-disc-cover' => 1,
  23  'aww'                 => 0,
  24  'frontier-rpc'        => 1,
  25  'gimp-perl'           => 1,
  26  'gnome2-wnck'         => 1,
  27  'HTML-Object'         => 0,
  28  'JKFlow'              => 0,
  29  'PDF-Create'          => 0,
  30 );
  31
  32 my $cwd = cwd();
  33
  34 for my $category (qw/perl-core dev-perl/) {
  35  my $dir = PORTAGE . '/' . $category;
  36  chdir $dir;
  37  for my $name (<*>) {
  38   next unless -d $name;
  39   my $eb = (sort glob "$dir/$name/$name-*")[-1];
  40   open my $fh, '<', $eb;
  41   my ($pn, $on_cpan);
  42   $on_cpan = $where{$name} if exists $where{$name};
  43   while (<$fh>) {
  44    $on_cpan = 1 if  not defined $on_cpan
  45                 and /(?:MODULE_AUTHOR|SRC_URI=.*?(?i:cpan))/;
  46    if (not defined $pn and /_PN?=(.*)/) {
  47     $pn = $1;
  48     if ($pn =~ /^\s*["']?\s*\$\{PN?\}/) {
  49      undef $pn;
  50      next;
  51     }
  52     $pn =~ s!\$[{(][^/]*?[})]!!g;
  53     $pn =~ s!\$\{P?V.*?\}!!g;
  54     $pn =~ s/^\s*["']?\s*-*\s*//;
  55     $pn =~ s/\s*-*\s*["']?\s*$//;
  56     $pn =~ s/-\d+\..*//;
  57     if ($pn =~ m!\$\{PN?(/.*?/(?:.*/?)?)\}!) {
  58      my $s = $1;
  59      $s .= '/' if $s =~ tr!/!! <= 2;
  60      eval "(\$pn = \$name) =~ s$s";
  61     }
  62    }
  63   }
  64   if ($pn and $pn ne $name) {
  65    if ($on_cpan) {
  66     $gentooism{$pn} = $name;
  67    } elsif (not defined $on_cpan) {
  68     print STDERR "'$pn' => '$name' may not be on CPAN\n";
  69    }
  70   }
  71  }
  72 }
  73
  74 chdir $cwd;
  75
  76 copy TARGET, BACKUP or die "copy failed: $!";
  77
  78 open my $src, '<', BACKUP;
  79 open my $dst, '>', TARGET;
  80
  81 my $max = max map length, keys %gentooism;
  82
  83 SRC: while (<$src>) {
  84  print $dst $_;
  85  if (/^__DATA__$/) {
  86   printf $dst "%s%s %s\n", $_, (' ' x ($max - length)), $gentooism{$_}
  87                                                        for sort keys %gentooism;
  88   last SRC;
  89  }
  90 }
  91
  92 print STDERR +(keys %gentooism) . " gentooisms found\n";
  93