summaryrefslogtreecommitdiff
path: root/Porting/corelist.pl
blob: bb0cf92aecf7601a1539c3cc1a6ddc3819c5e126 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
#!perl
# Generates info for Module::CoreList from this perl tree
# run this from the root of a perl tree, using the perl built in that tree.
#
# Data is on STDOUT.
#
# With an optional arg specifying the root of a CPAN mirror, outputs the
# %upstream and %bug_tracker hashes too.

use 5.010001; # needs Parse::CPAN::Meta

use strict;
use warnings;
use File::Find;
use ExtUtils::MM_Unix;
use lib "Porting";
use Maintainers qw(%Modules files_to_modules);
use File::Spec;


my %lines;
my %module_to_file;
my %modlist;

die "usage: $0 [ cpan-mirror/ ]\n" unless @ARGV <= 1;
my $cpan = shift;

if (! -f 'MANIFEST') {
    die "Must be run from the root of a clean perl tree\n"
}

if ($cpan) {
    my $modlistfile
	= File::Spec->catfile($cpan, 'modules', '02packages.details.txt');
    open my $fh, '<', $modlistfile or die "Couldn't open $modlistfile: $!";

    {
	local $/ = "\n\n";
	die "Incompatible modlist format"
	    unless <$fh> =~ /^Columns: +package name, version, path/m;
    }

    # Converting the file to a hash is about 5 times faster than a regexp flat
    # lookup.
    while (<$fh>) {
	next unless /^([A-Za-z_:0-9]+) +[-0-9.undefHASHVERSIONvsetwhenloadingbogus]+ +(\S+)/;
	$modlist{$1} = $2;
    }
}

find(sub {
    /(\.pm|_pm\.PL)$/ or return;
    /PPPort\.pm$/ and return;
    my $module = $File::Find::name;
    $module =~ /\b(demo|t|private)\b/ and return; # demo or test modules
    my $version = MM->parse_version($_);
    defined $version or $version = 'undef';
    $version =~ /\d/ and $version = "'$version'";
    # some heuristics to figure out the module name from the file name
    $module =~ s{^(lib|(win32/|vms/|symbian/)?ext)/}{}
	and $1 ne 'lib'
	and ( $module =~ s{\b(\w+)/\1\b}{$1},
	      $module =~ s{^B/O}{O},
	      $module =~ s{^Devel-PPPort}{Devel},
	      $module =~ s{^Encode/encoding}{encoding},
	      $module =~ s{^IPC-SysV/}{IPC/},
	      $module =~ s{^MIME-Base64/QuotedPrint}{MIME/QuotedPrint},
	      $module =~ s{^(?:DynaLoader|Errno|Opcode)/}{},
	    );
    $module =~ s{/}{::}g;
    $module =~ s{-}{::}g;
    $module =~ s{^.*::lib::}{};
    $module =~ s/(\.pm|_pm\.PL)$//;
    $lines{$module} = $version;
    $module_to_file{$module} = $File::Find::name;
}, 'lib', 'ext', 'vms/ext', 'symbian/ext');

-e 'configpm' and $lines{Config} = 'undef';

if (open my $ucdv, "<", "lib/unicore/version") {
    chomp (my $ucd = <$ucdv>);
    $lines{Unicode} = "'$ucd'";
    close $ucdv;
    }

sub display_hash {
    my ($hash) = @_;
}

print "    $] => {\n";
printf "\t%-24s=> $lines{$_},\n", "'$_'" foreach sort keys %lines;
print "    },\n";

exit unless %modlist;

# We have to go through this two stage lookup, given how Maintainers.pl keys its
# data by "Module", which is really a dist.
my $file_to_M = files_to_modules(values %module_to_file);

my %module_to_upstream;
my %module_to_dist;
my %dist_to_meta_YAML;
while (my ($module, $file) = each %module_to_file) {
    my $M = $file_to_M->{$file};
    next unless $M;
    next if $Modules{$M}{MAINTAINER} eq 'p5p';
    $module_to_upstream{$module} = $Modules{$M}{UPSTREAM};
    next if defined $module_to_upstream{$module} &&
	$module_to_upstream{$module} =~ /^(?:blead|first-come)$/;
    my $dist = $modlist{$module};
    unless ($dist) {
	warn "Can't find a distribution for $module";
	next;
    }
    $module_to_dist{$module} = $dist;

    next if exists $dist_to_meta_YAML{$dist};

    $dist_to_meta_YAML{$dist} = undef;

    # Like it or lump it, this has to be Unix format.
    my $meta_YAML_path = "$cpan/authors/id/$dist";
    $meta_YAML_path =~ s/(?:tar\.gz|zip)$/meta/ or die "$meta_YAML_path";
    unless (-e $meta_YAML_path) {
	warn "$meta_YAML_path does not exist for $module";
	# I tried code to open the tarballs with Archive::Tar to find and
	# extract META.yml, but only Text-Tabs+Wrap-2006.1117.tar.gz had one,
	# so it's not worth including.
	next;
    }
    require Parse::CPAN::Meta;
    $dist_to_meta_YAML{$dist} = Parse::CPAN::Meta::LoadFile($meta_YAML_path);
}

print "\n%upstream = (\n";
foreach my $module (sort keys %module_to_upstream) {
    my $upstream = defined $module_to_upstream{$module}
	? "'$module_to_upstream{$module}'" : 'undef';
    printf "    %-24s=> $upstream,\n", "'$module'";
}
print ");\n";

print "\n%bug_tracker = (\n";
foreach my $module (sort keys %module_to_upstream) {
    my $upstream = defined $module_to_upstream{$module};
    next if defined $upstream
	and $upstream eq 'blead' || $upstream eq 'first-come';

    my $bug_tracker;

    my $dist = $module_to_dist{$module};
    $bug_tracker = $dist_to_meta_YAML{$dist}->{resources}{bugtracker}
	if $dist;

    $bug_tracker = defined $bug_tracker ? "'$bug_tracker'" : 'undef';
    next if $bug_tracker eq "'http://rt.perl.org/perlbug/'";
    printf "    %-24s=> $bug_tracker,\n", "'$module'";
}
print ");\n";