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 List::Util qw/max/;
  12
  13 use constant PORTAGE => '/usr/portage';
  14
  15 my %gentooism;
  16
  17 my %where = (
  18  'Audio-CD-disc-cover' => 1,
  19  'aww'                 => 0,
  20  'frontier-rpc'        => 1,
  21  'gimp-perl'           => 1,
  22  'gnome2-wnck'         => 1,
  23  'HTML-Object'         => 0,
  24  'JKFlow'              => 0,
  25  'PDF-Create'          => 0,
  26 );
  27
  28 for my $category (qw/perl-core dev-perl/) {
  29  my $dir = PORTAGE . '/' . $category;
  30  chdir $dir;
  31  for my $name (<*>) {
  32   next unless -d $name;
  33   my $eb = (sort glob "$dir/$name/$name-*")[-1];
  34   open my $fh, '<', $eb;
  35   my ($pn, $on_cpan);
  36   $on_cpan = $where{$name} if exists $where{$name};
  37   while (<$fh>) {
  38    $on_cpan = 1 if  not defined $on_cpan
  39                 and /(?:MODULE_AUTHOR|SRC_URI=.*?(?i:cpan))/;
  40    if (not defined $pn and /_PN?=(.*)/) {
  41     $pn = $1;
  42     if ($pn =~ /^\s*["']?\s*\$\{PN?\}/) {
  43      undef $pn;
  44      next;
  45     }
  46     $pn =~ s!\$[{(][^/]*?[})]!!g;
  47     $pn =~ s!\$\{P?V.*?\}!!g;
  48     $pn =~ s/^\s*["']?\s*-*\s*//;
  49     $pn =~ s/\s*-*\s*["']?\s*$//;
  50     $pn =~ s/-\d+\..*//;
  51     if ($pn =~ m!\$\{PN?(/.*?/(?:.*/?)?)\}!) {
  52      my $s = $1;
  53      $s .= '/' if $s =~ tr!/!! <= 2;
  54      eval "(\$pn = \$name) =~ s$s";
  55     }
  56    }
  57   }
  58   if ($pn and $pn ne $name) {
  59    if ($on_cpan) {
  60     $gentooism{$pn} = $name;
  61    } elsif (not defined $on_cpan) {
  62     print STDERR "'$pn' => '$name' may not be on CPAN\n";
  63    }
  64   }
  65  }
  66 }
  67
  68 my $max = max map length, keys %gentooism;
  69
  70 print STDERR +(keys %gentooism) . " gentooisms found\n";
  71
  72 print  "our %gentooism = (\n";
  73 printf " '%s'%s => '%s',\n", $_, (' ' x ($max - length)), $gentooism{$_}
  74                                                        for sort keys %gentooism;
  75 print  ");\n";