Porting/corelist.pl

   1 #!perl
   2 # Generates info for Module::CoreList from this perl tree
   3 # run this from the root of a clean perl tree
   4
   5 use strict;
   6 use warnings;
   7 use File::Find;
   8 use ExtUtils::MM_Unix;
   9 use lib "Porting";
  10 use Maintainers qw(%Modules files_to_modules);
  11 use File::Spec;
  12
  13 my %lines;
  14 my %module_to_file;
  15 my %modlist;
  16 my $cpan = shift;
  17
  18 if ($cpan) {
  19     my $modlistfile
  20         = File::Spec->catfile($cpan, 'modules', '02packages.details.txt');
  21     open my $fh, '<', $modlistfile or die "Couldn't open $modlistfile: $!";
  22
  23     {
  24         local $/ = "\n\n";
  25         die "Incompatible modlist format"
  26             unless <$fh> =~ /^Columns: +package name, version, path/m;
  27     }
  28
  29     # Converting the file to a hash is about 5 times faster than a regexp flat
  30     # lookup.
  31     while (<$fh>) {
  32         next unless /^([A-Za-z_:0-9]+) +[-0-9.undefHASHVERSIONvsetwhenloadingbogus]+ +(\S+)/;
  33         $modlist{$1} = $2;
  34     }
  35 }
  36
  37 find(sub {
  38     /(\.pm|_pm\.PL)$/ or return;
  39     /PPPort\.pm$/ and return;
  40     my $module = $File::Find::name;
  41     $module =~ /\b(demo|t|private)\b/ and return; # demo or test modules
  42     my $version = MM->parse_version($_);
  43     defined $version or $version = 'undef';
  44     $version =~ /\d/ and $version = "'$version'";
  45     # some heuristics to figure out the module name from the file name
  46     $module =~ s{^(lib|(win32/|vms/|symbian/)?ext)/}{}
  47         and $1 ne 'lib'
  48         and ( $module =~ s{\b(\w+)/\1\b}{$1},
  49               $module =~ s{^B/O}{O},
  50               $module =~ s{^Devel-PPPort}{Devel},
  51               $module =~ s{^Encode/encoding}{encoding},
  52               $module =~ s{^IPC-SysV/}{IPC/},
  53               $module =~ s{^MIME-Base64/QuotedPrint}{MIME/QuotedPrint},
  54               $module =~ s{^(?:DynaLoader|Errno|Opcode)/}{},
  55             );
  56     $module =~ s{/}{::}g;
  57     $module =~ s{-}{::}g;
  58     $module =~ s{^.*::lib::}{};
  59     $module =~ s/(\.pm|_pm\.PL)$//;
  60     $lines{$module} = $version;
  61     $module_to_file{$module} = $File::Find::name;
  62 }, 'lib', 'ext', 'vms/ext', 'symbian/ext');
  63
  64 -e 'configpm' and $lines{Config} = 'undef';
  65
  66 if (open my $ucdv, "<", "lib/unicore/version") {
  67     chomp (my $ucd = <$ucdv>);
  68     $lines{Unicode} = "'$ucd'";
  69     close $ucdv;
  70     }
  71
  72 sub display_hash {
  73     my ($hash) = @_;
  74 }
  75
  76 print "    $] => {\n";
  77 printf "\t%-24s=> $lines{$_},\n", "'$_'" foreach sort keys %lines;
  78 print "    },\n";
  79
  80 exit unless %modlist;
  81
  82 # We have to go through this two stage lookup, given how Maintainers.pl keys its
  83 # data by "Module", which is really a dist.
  84 my $file_to_M = files_to_modules(values %module_to_file);
  85
  86 my %module_to_upstream;
  87 my %module_to_dist;
  88 my %dist_to_meta_YAML;
  89 while (my ($module, $file) = each %module_to_file) {
  90     my $M = $file_to_M->{$file};
  91     next unless $M;
  92     next if $Modules{$M}{MAINTAINER} eq 'p5p';
  93     $module_to_upstream{$module} = $Modules{$M}{UPSTREAM};
  94     next if defined $module_to_upstream{$module} &&
  95         $module_to_upstream{$module} =~ /^(?:blead|first-come)$/;
  96     my $dist = $modlist{$module};
  97     unless ($dist) {
  98         warn "Can't find a distribution for $module";
  99         next;
 100     }
 101     $module_to_dist{$module} = $dist;
 102
 103     next if exists $dist_to_meta_YAML{$dist};
 104
 105     $dist_to_meta_YAML{$dist} = undef;
 106
 107     # Like it or lump it, this has to be Unix format.
 108     my $meta_YAML_path = "$cpan/authors/id/$dist";
 109     $meta_YAML_path =~ s/(?:tar\.gz|zip)$/meta/ or die "$meta_YAML_path";
 110     unless (-e $meta_YAML_path) {
 111         warn "$meta_YAML_path does not exist for $module";
 112         # I tried code to open the tarballs with Archive::Tar to find and
 113         # extract META.yml, but only Text-Tabs+Wrap-2006.1117.tar.gz had one,
 114         # so it's not worth including.
 115         next;
 116     }
 117     require Parse::CPAN::Meta;
 118     $dist_to_meta_YAML{$dist} = Parse::CPAN::Meta::LoadFile($meta_YAML_path);
 119 }
 120
 121 print "\n%upstream = (\n";
 122 foreach my $module (sort keys %module_to_upstream) {
 123     my $upstream = defined $module_to_upstream{$module}
 124         ? "'$module_to_upstream{$module}'" : 'undef';
 125     printf "    %-24s=> $upstream,\n", "'$module'";
 126 }
 127 print ");\n";
 128
 129 print "\n%bug_tracker = (\n";
 130 foreach my $module (sort keys %module_to_upstream) {
 131     my $upstream = defined $module_to_upstream{$module};
 132     next if defined $upstream
 133         and $upstream eq 'blead' || $upstream eq 'first-come';
 134
 135     my $bug_tracker;
 136
 137     my $dist = $module_to_dist{$module};
 138     $bug_tracker = $dist_to_meta_YAML{$dist}->{resources}{bugtracker}
 139         if $dist;
 140
 141     $bug_tracker = defined $bug_tracker ? "'$bug_tracker'" : 'undef';
 142     next if $bug_tracker eq "'http://rt.perl.org/perlbug/'";
 143     printf "    %-24s=> $bug_tracker,\n", "'$module'";
 144 }
 145 print ");\n";