This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Module::CoreList, implemented is_deprecated() and added tests for it.
[perl5.git] / Porting / corelist.pl
CommitLineData
4a656c5e
RGS
1#!perl
2# Generates info for Module::CoreList from this perl tree
dc2f75c0 3# run this from the root of a perl tree
e1018a69
DM
4#
5# Data is on STDOUT.
6#
7# With an optional arg specifying the root of a CPAN mirror, outputs the
8# %upstream and %bug_tracker hashes too.
9
4a656c5e
RGS
10use strict;
11use warnings;
12use File::Find;
13use ExtUtils::MM_Unix;
dc2f75c0 14use version;
fb237dfd
NC
15use lib "Porting";
16use Maintainers qw(%Modules files_to_modules);
17use File::Spec;
dc2f75c0 18use Parse::CPAN::Meta;
4a656c5e 19
1f809cd9 20my $corelist_file = 'dist/Module-CoreList/lib/Module/CoreList.pm';
e1018a69 21
59189dd7 22my %lines;
fb237dfd
NC
23my %module_to_file;
24my %modlist;
e1018a69 25
dc2f75c0
JV
26die "usage: $0 [ cpan-mirror/ ] [ 5.x.y] \n" unless @ARGV <= 2;
27my $cpan = shift;
28my $raw_version = shift || $];
29my $perl_version = version->parse("$raw_version");
30my $perl_vnum = $perl_version->numify;
31my $perl_vstring = $perl_version->normal; # how do we get version.pm to not give us leading v?
32$perl_vstring =~ s/^v//;
fb237dfd 33
dc2f75c0
JV
34if ( !-f 'MANIFEST' ) {
35 die "Must be run from the root of a clean perl tree\n";
e1018a69
DM
36}
37
dc2f75c0
JV
38open( my $corelist_fh, '<', $corelist_file ) || die "Could not open $corelist_file: $!";
39my $corelist = join( '', <$corelist_fh> );
40
fb237dfd 41if ($cpan) {
dc2f75c0
JV
42 my $modlistfile = File::Spec->catfile( $cpan, 'modules', '02packages.details.txt' );
43 my $content;
44
45 my $fh;
46 if ( -e $modlistfile ) {
47 warn "Reading the module list from $modlistfile";
48 open $fh, '<', $modlistfile or die "Couldn't open $modlistfile: $!";
49 } elsif ( -e $modlistfile . ".gz" ) {
50 warn "Reading the module list from $modlistfile.gz";
51 open $fh, '-|', "gzcat $modlistfile.gz" or die "Couldn't zcat $modlistfile.gz: $!";
52 } else {
53 warn "About to fetch 02packages from ftp.funet.fi. This may take a few minutes\n";
54 $content = fetch_url('http://ftp.funet.fi/pub/CPAN/modules/02packages.details.txt');
55 unless ($content) {
56 die "Unable to read 02packages.details.txt from either your CPAN mirror or ftp.funet.fi";
57 }
58 }
59
60 if ( $fh and !$content ) {
61 local $/ = "\n";
62 $content = join( '', <$fh> );
fb237dfd
NC
63 }
64
dc2f75c0
JV
65 die "Incompatible modlist format"
66 unless $content =~ /^Columns: +package name, version, path/m;
67
fb237dfd
NC
68 # Converting the file to a hash is about 5 times faster than a regexp flat
69 # lookup.
dc2f75c0
JV
70 for ( split( qr/\n/, $content ) ) {
71 next unless /^([A-Za-z_:0-9]+) +[-0-9.undefHASHVERSIONvsetwhenloadingbogus]+ +(\S+)/;
72 $modlist{$1} = $2;
fb237dfd
NC
73 }
74}
75
dc2f75c0
JV
76find(
77 sub {
78 /(\.pm|_pm\.PL)$/ or return;
79 /PPPort\.pm$/ and return;
80 my $module = $File::Find::name;
81 $module =~ /\b(demo|t|private)\b/ and return; # demo or test modules
82 my $version = MM->parse_version($_);
83 defined $version or $version = 'undef';
84 $version =~ /\d/ and $version = "'$version'";
85
86 # some heuristics to figure out the module name from the file name
71c80a8f 87 $module =~ s{^(lib|cpan|dist|(?:vms/|symbian/)?ext)/}{}
3eae08df 88 and $1 ne 'lib'
dc2f75c0
JV
89 and (
90 $module =~ s{\b(\w+)/\1\b}{$1},
91 $module =~ s{^B/O}{O},
92 $module =~ s{^Devel-PPPort}{Devel},
3eae08df 93 $module =~ s{^libnet/}{},
dc2f75c0
JV
94 $module =~ s{^Encode/encoding}{encoding},
95 $module =~ s{^IPC-SysV/}{IPC/},
96 $module =~ s{^MIME-Base64/QuotedPrint}{MIME/QuotedPrint},
97 $module =~ s{^(?:DynaLoader|Errno|Opcode)/}{},
98 );
71c80a8f 99 $module =~ s{^lib/}{}g;
dc2f75c0
JV
100 $module =~ s{/}{::}g;
101 $module =~ s{-}{::}g;
71c80a8f 102 $module =~ s{^.*::lib::}{}; # turns Foo/lib/Foo.pm into Foo.pm
dc2f75c0
JV
103 $module =~ s/(\.pm|_pm\.PL)$//;
104 $lines{$module} = $version;
105 $module_to_file{$module} = $File::Find::name;
106 },
71c80a8f
JV
107 'vms/ext',
108 'symbian/ext',
dc2f75c0
JV
109 'lib',
110 'ext',
3eae08df 111 'cpan',
71c80a8f 112 'dist'
dc2f75c0 113);
59189dd7 114
0fdd9e5c 115-e 'configpm' and $lines{Config} = 'undef';
cc8432b2 116
dc2f75c0
JV
117if ( open my $ucdv, "<", "lib/unicore/version" ) {
118 chomp( my $ucd = <$ucdv> );
0fdd9e5c 119 $lines{Unicode} = "'$ucd'";
59189dd7 120 close $ucdv;
dc2f75c0 121}
fb237dfd 122
dc2f75c0
JV
123my $versions_in_release = " " . $perl_vnum . " => {\n";
124foreach my $key ( sort keys %lines ) {
125 $versions_in_release .= sprintf "\t%-24s=> %s,\n", "'$key'", $lines{$key};
0fdd9e5c 126}
dc2f75c0 127$versions_in_release .= " },\n";
fb237dfd 128
dc2f75c0 129$corelist =~ s/^(%version\s*=\s*.*?)(^\);)$/$1$versions_in_release$2/xism;
fb237dfd
NC
130
131exit unless %modlist;
132
133# We have to go through this two stage lookup, given how Maintainers.pl keys its
134# data by "Module", which is really a dist.
dc2f75c0 135my $file_to_M = files_to_modules( values %module_to_file );
fb237dfd
NC
136
137my %module_to_upstream;
138my %module_to_dist;
139my %dist_to_meta_YAML;
dc2f75c0 140while ( my ( $module, $file ) = each %module_to_file ) {
fb237dfd
NC
141 my $M = $file_to_M->{$file};
142 next unless $M;
143 next if $Modules{$M}{MAINTAINER} eq 'p5p';
144 $module_to_upstream{$module} = $Modules{$M}{UPSTREAM};
dc2f75c0
JV
145 next
146 if defined $module_to_upstream{$module}
147 && $module_to_upstream{$module} =~ /^(?:blead|first-come)$/;
fb237dfd
NC
148 my $dist = $modlist{$module};
149 unless ($dist) {
dc2f75c0
JV
150 warn "Can't find a distribution for $module\n";
151 next;
fb237dfd
NC
152 }
153 $module_to_dist{$module} = $dist;
154
155 next if exists $dist_to_meta_YAML{$dist};
156
157 $dist_to_meta_YAML{$dist} = undef;
158
159 # Like it or lump it, this has to be Unix format.
dc2f75c0 160 my $meta_YAML_path = "authors/id/$dist";
fb237dfd 161 $meta_YAML_path =~ s/(?:tar\.gz|zip)$/meta/ or die "$meta_YAML_path";
dc2f75c0
JV
162 my $meta_YAML_url = 'http://ftp.funet.fi/pub/CPAN/' . $meta_YAML_path;
163
164 if ( -e "$cpan/$meta_YAML_path" ) {
165 $dist_to_meta_YAML{$dist} = Parse::CPAN::Meta::LoadFile( $cpan . "/" . $meta_YAML_path );
166 } elsif ( my $content = fetch_url($meta_YAML_url) ) {
167 unless ($content) {
168 warn "Failed to fetch $meta_YAML_url\n";
169 next;
170 }
171 eval { $dist_to_meta_YAML{$dist} = Parse::CPAN::Meta::Load($content); };
172 if ( my $err = $@ ) {
173 warn "$meta_YAML_path: ".$err;
174 next;
175 }
176 } else {
177 warn "$meta_YAML_path does not exist for $module\n";
178
179 # I tried code to open the tarballs with Archive::Tar to find and
180 # extract META.yml, but only Text-Tabs+Wrap-2006.1117.tar.gz had one,
181 # so it's not worth including.
182 next;
fb237dfd 183 }
fb237dfd
NC
184}
185
dc2f75c0
JV
186my $upstream_stanza = "%upstream = (\n";
187foreach my $module ( sort keys %module_to_upstream ) {
188 my $upstream = defined $module_to_upstream{$module} ? "'$module_to_upstream{$module}'" : 'undef';
189 $upstream_stanza .= sprintf " %-24s=> %s,\n", "'$module'", $upstream;
fb237dfd 190}
dc2f75c0
JV
191$upstream_stanza .= ");";
192
193$corelist =~ s/^%upstream .*? ;$/$upstream_stanza/ismx;
fb237dfd 194
dc2f75c0
JV
195my $tracker = "%bug_tracker = (\n";
196foreach my $module ( sort keys %module_to_upstream ) {
fb237dfd 197 my $upstream = defined $module_to_upstream{$module};
dc2f75c0
JV
198 next
199 if defined $upstream
200 and $upstream eq 'blead' || $upstream eq 'first-come';
fb237dfd
NC
201
202 my $bug_tracker;
203
204 my $dist = $module_to_dist{$module};
205 $bug_tracker = $dist_to_meta_YAML{$dist}->{resources}{bugtracker}
dc2f75c0 206 if $dist;
fb237dfd
NC
207
208 $bug_tracker = defined $bug_tracker ? "'$bug_tracker'" : 'undef';
71c80a8f 209 next if $bug_tracker eq "'http://rt.perl.org/perlbug/'";
dc2f75c0
JV
210 $tracker .= sprintf " %-24s=> %s,\n", "'$module'", $bug_tracker;
211}
212$tracker .= ");";
213
214$corelist =~ s/^%bug_tracker .*? ;/$tracker/eismx;
215
216unless ( $corelist =~ /and $perl_vstring releases of perl/ ) {
217 warn "Adding $perl_vstring to the list of perl versions covered by Module::CoreList\n";
218 $corelist =~ s/\s*and (.*?) releases of perl/, $1 and $perl_vstring releases of perl/ism;
219}
220
221unless (
222 $corelist =~ /^%released \s* = \s* \(
223 .*?
224 $perl_vnum => .*?
225 \);/ismx
226 )
227{
228 warn "Adding $perl_vnum to the list of released perl versions. Please consider adding a release date.\n";
229 $corelist =~ s/^(%released \s* = \s* .*?) ( \) )
230 /$1 $perl_vnum => '????-??-??',\n $2/ismx;
231}
232
233write_corelist($corelist);
234
2ce7d676 235warn "All done. Please check over $corelist_file carefully before committing. Thanks!\n";
dc2f75c0
JV
236
237
238sub write_corelist {
239 my $content = shift;
2ce7d676 240 open (my $clfh, ">", $corelist_file) || die "Failed to open $corelist_file for writing: $!";
dc2f75c0
JV
241 print $clfh $content || die "Failed to write the new CoreList.pm: $!";
242 close($clfh);
243}
244
245sub fetch_url {
246 my $url = shift;
247 eval { require LWP::Simple };
248 if ( LWP::Simple->can('get') ) {
249 return LWP::Simple->get($url);
250 } elsif (`which curl`) {
251 return `curl -s $url`;
252 } elsif (`which wget`) {
253 return `wget -q -O - $url`;
254 }
fb237dfd 255}