This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add Porting/bump-perl-version
[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}) {
74 @ARGV == 0 or usage('no version version numbers should be speciied');
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,
121 sub { $2, "${1}0$3" },
122 0,
123 qr/config/,
124 ],
125 [
126 qr{^(api_versionstring(?:=|\s+)'?) ([\d\.]+) ('?) (?!\.)}x,
127 sub { $2, "$1$newx.$newy.0$3" },
128 "$oldx.$oldy.0",
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"},
145 $oldz,
146 ],
147 [
148 qr{\b (PERL_API_SUBVERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x,
149 sub { $2, "${1}0$3"},
150 0,
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 [
165 qr{\b $oldx\.$oldy\.$oldz \b}x,
166 sub {"", "$newx.$newy.$newz"},
167 undef,
168 ],
169
170 # 5.008009
171 [
172 qr{\b $old_decimal \b}x,
173 sub {"", sprintf "%d.%03d%03d", $newx, $newy, $newz },
174 undef,
175 ],
176
177);
178
179
180# files and dirs that we likely don't want to change version numbers on.
181
182my %SKIP_FILES = map { ($_ => 1) } qw(
183 Changes
184 MANIFEST
185 Porting/how_to_write_a_perldelta.pod
186 Porting/mergelog
187 Porting/mergelog-tool
188 pod.lst
189);
190my @SKIP_DIRS = qw(
191 ext
192 lib
193 pod
194 t
195);
196
197my @mani_files = sort keys %{ExtUtils::Manifest::maniread('MANIFEST')};
198my %mani_files = map { ($_ => 1) } @mani_files;
199die "No entries found in MANIFEST; aborting\n" unless @mani_files;
200
201if ($opts{c} or $opts{s}) {
202 do_scan();
203}
204elsif ($opts{u}) {
205 do_update();
206}
207else {
208 usage('one of -c, -s or -u must be specifcied');
209}
210exit 0;
211
212
213
214
215sub do_scan {
216 for my $file (@mani_files) {
217 next if grep $file =~ m{$_/}, @SKIP_DIRS;
218 if ($SKIP_FILES{$file}) {
219 warn "(skipping $file)\n";
220 next;
221 }
222 open my $fh, '<', $file or die "Aborting: can't open $file: $!\n";
223 my $header = 0;
224
225 while (<$fh>) {
226 for my $map (@maps) {
227 my ($pat, $sub, $expected, $file_pat) = @$map;
228
229 next if defined $file_pat and $file !~ $file_pat;
230 next unless $_ =~ $pat;
231 my ($got, $replacement) = $sub->();
232
233 if ($opts{c}) {
234 # only report unexpected
235 next unless defined $expected and $got ne $expected;
236 }
237 my $newstr = $_;
238 $newstr =~ s/$pat/$replacement/
239 or die "Internal error: substitution failed: [$pat]\n";
240 if ($_ ne $newstr) {
241 print "\n$file\n" unless $header;
242 $header=1;
243 printf "\n%5d: -%s +%s", $., $_, $newstr;
244 }
245 last;
246 }
247 }
248 }
249 warn "(skipped $_/*)\n" for @SKIP_DIRS;
250}
251
252sub do_update {
253
254 my %changes;
255 my $file;
256 my $line;
257
258 # read in config
259
260 while (<STDIN>) {
261 next unless /\S/;
262 if (/^(\S+)$/) {
263 $file = $1;
264 die "No such file in MANIFEST: '$file'\n" unless $mani_files{$file};
265 die "file already seen; '$file'\n" if exists $changes{$file};
266 undef $line;
267 }
268 elsif (/^\s+(\d+): -(.*)/) {
269 my $old;
270 ($line, $old) = ($1,$2);
271 die "$.: old line without preceeding filename\n"
272 unless defined $file;
273 die "Dup line number: $line\n" if exists $changes{$file}{$line};
274 $changes{$file}{$line}[0] = $old;
275 }
276 elsif (/^\s+\+(.*)/) {
277 my $new = $1;
278 die "$.: replacement line seen without old line\n" unless $line;
279 $changes{$file}{$line}[1] = $new;
280 undef $line;
281 }
282 else {
283 die "Unexpected line at ;line $.: $_\n";
284 }
285 }
286
287 # suck in file contents to memory, then update that in-memory copy
288
289 my %contents;
290 for my $file (sort keys %changes) {
291 open my $fh, '<', $file or die "open '$file': $!\n";
292 $contents{$file} = [ <$fh> ];
293 chomp @{$contents{$file}};
294 close $fh or die "close: '$file': $!\n";
295
296 my $entries = $changes{$file};
297 for my $line (keys %$entries) {
298 die "$file: no such line: $line\n"
299 unless defined $contents{$file}[$line-1];
300 if ($contents{$file}[$line-1] ne $entries->{$line}[0]) {
301 die "$file: line mismatch at line $line:\n"
302 . "File: [$contents{$file}[$line-1]]\n"
303 . "Config: [$entries->{$line}[0]]\n"
304 }
305 $contents{$file}[$line-1] = $entries->{$line}[1];
306 }
307 }
308
309 # check the temp files don't already exist
310
311 for my $file (sort keys %contents) {
312 my $nfile = "$file-new";
313 die "$nfile already exists in MANIFEST; aborting\n"
314 if $mani_files{$nfile};
315 }
316
317 # write out the new files
318
319 for my $file (sort keys %contents) {
320 my $nfile = "$file-new";
321 open my $fh, '>', $nfile or die "create '$nfile' failed: $!\n";
322 print $fh $_, "\n" for @{$contents{$file}};
323 close $fh or die "failed to close $nfile; aborting: $!\n";
324
325 my @stat = stat $file or die "Can't stat $file: $!\n";
326 my $mode = $stat[2];
327 die "stat $file fgailed to give a mode!\n" unless defined $mode;
328 chmod $mode & 0777, $nfile or die "chmod $nfile failed; aborting: $!\n";
329 }
330
331 # and rename them
332
333 for my $file (sort keys %contents) {
334 my $nfile = "$file-new";
335 warn "updating $file ...\n";
336 rename $nfile, $file or die "rename $nfile $file: $!\n";
337 }
338}
339