This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Extract the code the maps from an author/distribution to a
[perl5.git] / Porting / bump-perl-version
CommitLineData
ae1b7029
DM
1#!/usr/bin/perl
2#
3# bump-perl-version, DAPM 14 Jul 2009
4#
5# A utility to find, and optionally bump, references to the perl version
6# number in various files within the perl source
7#
8# It's designed to work in two phases. First, when run with -s (scan),
9# it searches all the files in MANIFEST looking for strings that appear to
10# match the current perl version (or which it knows are *supposed* to
11# contain the current version), and produces a list of them to stdout,
12# along with a suggested edit. For example:
13#
14# $ Porting/bump-perl-version -s 5.10.0 5.10.1 > /tmp/scan
15# $ cat /tmp/scan
16# Porting/config.sh
17#
18# 52: -archlib='/opt/perl/lib/5.10.0/i686-linux-64int'
19# +archlib='/opt/perl/lib/5.10.1/i686-linux-64int'
20# ....
21#
22# At this point there will be false positives. Edit the file to remove
23# those changes you don't want made. Then in the second phase, feed that
24# list in, and it will change those lines in the files:
25#
26# $ Porting/bump-perl-version -u < /tmp/scan
27#
28# (so line 52 of Porting/config.sh is now updated)
29
30# This utility 'knows' about certain files and formats, and so can spot
31# 'hidden' version numbers, like PERL_SUBVERSION=9.
32#
33# A third variant makes use of this knowledge to check that all the things
34# it knows about are at the current version:
35#
36# $ Porting/bump-perl-version -c 5.10.0
37#
38# XXX this script hasn't been tested against a major version bump yet,
39# eg 5.11.0 to 5.12.0; there may be things it missed - DAPM 14 Jul 09
40#
41# Note there are various files and directories that it skips; these are
42# ones that are unlikely to contain anything needing bumping, but which
43# will generate lots fo false positives (eg pod/*). These are listed on
44# STDERR as they are skipped.
45
46use strict;
47use warnings;
48use Getopt::Std;
49use ExtUtils::Manifest;
50
51
52sub usage { die <<EOF }
53
54@_
55
56usage: $0 -c <C.C.C>
57 -s <C.C.C> <N.N.N>
58 -u
59
60 -c check files and warn if any known string values (eg
61 PERL_SUBVERSION) don't match the specified version
62
63 -s scan files and produce list of possible change lines to stdout
64
65 -u read in the scan file from stdin, and change all the lines specified
66
67 C.C.C the current perl version, eg 5.10.0
68 N.N.N the new perl version, eg 5.10.1
69EOF
70
71my %opts;
72getopts('csu', \%opts) or usage;
73if ($opts{u}) {
47e01c32 74 @ARGV == 0 or usage('no version version numbers should be specified');
ae1b7029
DM
75 # fake to stop warnings when calculating $oldx etc
76 @ARGV = qw(99.99.99 99.99.99);
77}
78elsif ($opts{c}) {
79 @ARGV == 1 or usage('required one version number');
80 push @ARGV, $ARGV[0];
81}
82else {
83 @ARGV == 2 or usage('require two version numbers');
84}
85usage('only one of -c, -s and -u') if keys %opts > 1;
86
87my ($oldx, $oldy, $oldz) = $ARGV[0] =~ /^(\d+)\.(\d+)\.(\d+)$/
88 or usage("bad version: $ARGV[0]");
89my ($newx, $newy, $newz) = $ARGV[1] =~ /^(\d+)\.(\d+)\.(\d+)$/
90 or usage("bad version: $ARGV[1]");
91
92my $old_decimal = sprintf "%d.%03d%03d", $oldx, $oldy, $oldz; # 5.011001
93
94# each entry is
95# 0 a regexp that matches strings that might contain versions;
96# 1 a sub that returns two strings based on $1 etc values:
97# * string containing captured values (for -c)
98# * a string containing the replacement value
99# 2 what we expect the sub to return as its first arg; undef implies
100# don't match
101# 3 a regex restricting which files this applies to (undef is all files)
102#
103# Note that @maps entries are checks in order, and only the first to match
104# is used.
105
106my @maps = (
107 [
108 qr{^((?:api_)?version(?:=|\s+)'?) (\d+) ('?) (?!\.)}x,
109 sub { $2, "$1$newy$3" },
110 $oldy,
111 qr/config/,
112 ],
113 [
114 qr{^(subversion(?:=|\s+)'?) (\d+) ('?) (?!\.)}x,
115 sub { $2, "$1$newz$3" },
116 $oldz,
117 qr/config/,
118 ],
119 [
120 qr{^(api_subversion(?:=|\s+)'?) (\d+) ('?) (?!\.)}x,
544af516
FR
121 sub { $2, ($newy % 2) ? "$1$newz$3" : "${1}0$3" },
122 ($oldy % 2) ? $oldz : 0,
ae1b7029
DM
123 qr/config/,
124 ],
125 [
126 qr{^(api_versionstring(?:=|\s+)'?) ([\d\.]+) ('?) (?!\.)}x,
544af516
FR
127 sub { $2, ($newy % 2) ? "$1$newx.$newy.$newz$3": "$1$newx.$newy.0$3" },
128 ($oldy % 2) ? "$oldx.$oldy.$oldz" : "$oldx.$oldy.0",
ae1b7029
DM
129 qr/config/,
130 ],
131 [
132 qr{(version\s+'?) (\d+) ('?\s+subversion\s+'?) (\d+) ('?) (?!\.)}x,
133 sub { "$2-$4", "$1$newy$3$newz$5" },
134 "$oldy-$oldz",
135 qr/config/,
136 ],
137 [
138 qr{\b (PERL_(?:API_)?VERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x,
139 sub { $2, "$1$newy$3"},
140 $oldy,
141 ],
142 [
143 qr{\b (PERL_SUBVERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x,
144 sub { $2, "$1$newz$3"},
544af516 145 ($oldy % 2) ? $oldz : 0,
ae1b7029
DM
146 ],
147 [
148 qr{\b (PERL_API_SUBVERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x,
544af516
FR
149 sub { $2, ($newy % 2) ? "$1$newz$3" : "${1}0$3" },
150 $oldz,
ae1b7029
DM
151 ],
152 # these two formats are in README.vms
153 [
154 qr{\b perl-(\d+\^\.\d+\^\.\d+) \b}x,
155 sub { $1, "perl-$newx^.$newy^.$newz"},
156 undef,
157 ],
158 [
159 qr{\b ($oldx _ $oldy _$oldz) \b}x,
160 sub { $1, ($newx . '_' . $newy . '_' . $newz)},
161 undef,
162 ],
163 # 5.8.9
164 [
8b8cdb3a 165 qr{ $oldx\.$oldy\.$oldz \b}x,
ae1b7029
DM
166 sub {"", "$newx.$newy.$newz"},
167 undef,
168 ],
169
170 # 5.008009
171 [
8b8cdb3a 172 qr{ $old_decimal \b}x,
ae1b7029
DM
173 sub {"", sprintf "%d.%03d%03d", $newx, $newy, $newz },
174 undef,
175 ],
176
d4f05c0b 177 # perl511, perl511.dll, perl511.lib, perl511s.lib, libperl511.a
7dfca73b 178 [
d4f05c0b
VP
179 qr{\b ((?:lib)?) perl (\d\d\d) (s?) \b }x,
180 sub {$2, "$1perl$newx$newy$3" },
7dfca73b 181 "$oldx$oldy",
d4f05c0b 182 qr/makedef|win32|hints/, # makedef.pl, README.win32, win32/*, hints/*
7dfca73b
JD
183 ],
184
2e55877c
DL
185 # microperl locations should be bumped for major versions
186 [
187 qr{(/)(\d\.\d{2})(["'/])},
188 sub { $2, "$1$newx.$newy$3" },
189 "$oldx.$oldy",
190 qr/uconfig/,
191 ],
192
ae1b7029
DM
193);
194
195
196# files and dirs that we likely don't want to change version numbers on.
197
198my %SKIP_FILES = map { ($_ => 1) } qw(
199 Changes
200 MANIFEST
87f4ab41 201 Porting/epigraphs.pod
ae1b7029 202 Porting/how_to_write_a_perldelta.pod
5bd03515 203 Porting/release_managers_guide.pod
87f4ab41 204 Porting/release_schedule.pod
8b8cdb3a 205 Porting/bump-perl-version
ae1b7029 206 pod.lst
5bd03515 207 pp_ctl.c
ae1b7029
DM
208);
209my @SKIP_DIRS = qw(
210 ext
211 lib
212 pod
d634733c 213 cpan
ae1b7029
DM
214 t
215);
216
217my @mani_files = sort keys %{ExtUtils::Manifest::maniread('MANIFEST')};
218my %mani_files = map { ($_ => 1) } @mani_files;
219die "No entries found in MANIFEST; aborting\n" unless @mani_files;
220
221if ($opts{c} or $opts{s}) {
222 do_scan();
223}
224elsif ($opts{u}) {
225 do_update();
226}
227else {
47e01c32 228 usage('one of -c, -s or -u must be specified');
ae1b7029
DM
229}
230exit 0;
231
232
233
234
235sub do_scan {
236 for my $file (@mani_files) {
237 next if grep $file =~ m{$_/}, @SKIP_DIRS;
238 if ($SKIP_FILES{$file}) {
239 warn "(skipping $file)\n";
240 next;
241 }
242 open my $fh, '<', $file or die "Aborting: can't open $file: $!\n";
243 my $header = 0;
244
245 while (<$fh>) {
246 for my $map (@maps) {
247 my ($pat, $sub, $expected, $file_pat) = @$map;
248
249 next if defined $file_pat and $file !~ $file_pat;
250 next unless $_ =~ $pat;
251 my ($got, $replacement) = $sub->();
252
253 if ($opts{c}) {
254 # only report unexpected
255 next unless defined $expected and $got ne $expected;
256 }
257 my $newstr = $_;
258 $newstr =~ s/$pat/$replacement/
259 or die "Internal error: substitution failed: [$pat]\n";
260 if ($_ ne $newstr) {
261 print "\n$file\n" unless $header;
262 $header=1;
263 printf "\n%5d: -%s +%s", $., $_, $newstr;
264 }
265 last;
266 }
267 }
268 }
269 warn "(skipped $_/*)\n" for @SKIP_DIRS;
270}
271
272sub do_update {
273
274 my %changes;
275 my $file;
276 my $line;
277
278 # read in config
279
280 while (<STDIN>) {
281 next unless /\S/;
282 if (/^(\S+)$/) {
283 $file = $1;
284 die "No such file in MANIFEST: '$file'\n" unless $mani_files{$file};
285 die "file already seen; '$file'\n" if exists $changes{$file};
286 undef $line;
287 }
288 elsif (/^\s+(\d+): -(.*)/) {
289 my $old;
290 ($line, $old) = ($1,$2);
47e01c32 291 die "$.: old line without preceding filename\n"
ae1b7029
DM
292 unless defined $file;
293 die "Dup line number: $line\n" if exists $changes{$file}{$line};
294 $changes{$file}{$line}[0] = $old;
295 }
296 elsif (/^\s+\+(.*)/) {
297 my $new = $1;
298 die "$.: replacement line seen without old line\n" unless $line;
299 $changes{$file}{$line}[1] = $new;
300 undef $line;
301 }
302 else {
303 die "Unexpected line at ;line $.: $_\n";
304 }
305 }
306
307 # suck in file contents to memory, then update that in-memory copy
308
309 my %contents;
310 for my $file (sort keys %changes) {
311 open my $fh, '<', $file or die "open '$file': $!\n";
33c1015f 312 binmode $fh;
ae1b7029
DM
313 $contents{$file} = [ <$fh> ];
314 chomp @{$contents{$file}};
315 close $fh or die "close: '$file': $!\n";
316
317 my $entries = $changes{$file};
318 for my $line (keys %$entries) {
319 die "$file: no such line: $line\n"
320 unless defined $contents{$file}[$line-1];
321 if ($contents{$file}[$line-1] ne $entries->{$line}[0]) {
322 die "$file: line mismatch at line $line:\n"
323 . "File: [$contents{$file}[$line-1]]\n"
324 . "Config: [$entries->{$line}[0]]\n"
325 }
326 $contents{$file}[$line-1] = $entries->{$line}[1];
327 }
328 }
329
330 # check the temp files don't already exist
331
332 for my $file (sort keys %contents) {
333 my $nfile = "$file-new";
334 die "$nfile already exists in MANIFEST; aborting\n"
335 if $mani_files{$nfile};
336 }
337
338 # write out the new files
339
340 for my $file (sort keys %contents) {
341 my $nfile = "$file-new";
342 open my $fh, '>', $nfile or die "create '$nfile' failed: $!\n";
33c1015f 343 binmode $fh;
ae1b7029
DM
344 print $fh $_, "\n" for @{$contents{$file}};
345 close $fh or die "failed to close $nfile; aborting: $!\n";
346
347 my @stat = stat $file or die "Can't stat $file: $!\n";
348 my $mode = $stat[2];
349 die "stat $file fgailed to give a mode!\n" unless defined $mode;
350 chmod $mode & 0777, $nfile or die "chmod $nfile failed; aborting: $!\n";
351 }
352
353 # and rename them
354
355 for my $file (sort keys %contents) {
356 my $nfile = "$file-new";
357 warn "updating $file ...\n";
358 rename $nfile, $file or die "rename $nfile $file: $!\n";
359 }
360}
361