Commit | Line | Data |
---|---|---|
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) | |
5302eb95 JL |
29 | # |
30 | # The -i option can be used to combine these two steps (if you prefer to make | |
31 | # all of the changes at once and then edit the results via git). | |
ae1b7029 DM |
32 | |
33 | # This utility 'knows' about certain files and formats, and so can spot | |
34 | # 'hidden' version numbers, like PERL_SUBVERSION=9. | |
35 | # | |
36 | # A third variant makes use of this knowledge to check that all the things | |
37 | # it knows about are at the current version: | |
38 | # | |
39 | # $ Porting/bump-perl-version -c 5.10.0 | |
40 | # | |
41 | # XXX this script hasn't been tested against a major version bump yet, | |
42 | # eg 5.11.0 to 5.12.0; there may be things it missed - DAPM 14 Jul 09 | |
43 | # | |
44 | # Note there are various files and directories that it skips; these are | |
45 | # ones that are unlikely to contain anything needing bumping, but which | |
730ad6b9 | 46 | # will generate lots of false positives (eg pod/*). These are listed on |
ae1b7029 DM |
47 | # STDERR as they are skipped. |
48 | ||
49 | use strict; | |
50 | use warnings; | |
204fc54e | 51 | use autodie; |
ae1b7029 DM |
52 | use Getopt::Std; |
53 | use ExtUtils::Manifest; | |
54 | ||
55 | ||
56 | sub usage { die <<EOF } | |
57 | ||
58 | @_ | |
59 | ||
60 | usage: $0 -c <C.C.C> | |
61 | -s <C.C.C> <N.N.N> | |
62 | -u | |
dc40e497 | 63 | -i <C.C.C> <N.N.N> |
ae1b7029 DM |
64 | |
65 | -c check files and warn if any known string values (eg | |
66 | PERL_SUBVERSION) don't match the specified version | |
67 | ||
68 | -s scan files and produce list of possible change lines to stdout | |
69 | ||
70 | -u read in the scan file from stdin, and change all the lines specified | |
71 | ||
dc40e497 LB |
72 | -i scan files and make changes inplace |
73 | ||
ae1b7029 DM |
74 | C.C.C the current perl version, eg 5.10.0 |
75 | N.N.N the new perl version, eg 5.10.1 | |
76 | EOF | |
77 | ||
78 | my %opts; | |
dc40e497 | 79 | getopts('csui', \%opts) or usage; |
ae1b7029 | 80 | if ($opts{u}) { |
47e01c32 | 81 | @ARGV == 0 or usage('no version version numbers should be specified'); |
ae1b7029 DM |
82 | # fake to stop warnings when calculating $oldx etc |
83 | @ARGV = qw(99.99.99 99.99.99); | |
84 | } | |
85 | elsif ($opts{c}) { | |
86 | @ARGV == 1 or usage('required one version number'); | |
87 | push @ARGV, $ARGV[0]; | |
88 | } | |
89 | else { | |
90 | @ARGV == 2 or usage('require two version numbers'); | |
91 | } | |
dc40e497 | 92 | usage('only one of -c, -s, -u and -i') if keys %opts > 1; |
ae1b7029 DM |
93 | |
94 | my ($oldx, $oldy, $oldz) = $ARGV[0] =~ /^(\d+)\.(\d+)\.(\d+)$/ | |
95 | or usage("bad version: $ARGV[0]"); | |
96 | my ($newx, $newy, $newz) = $ARGV[1] =~ /^(\d+)\.(\d+)\.(\d+)$/ | |
97 | or usage("bad version: $ARGV[1]"); | |
98 | ||
99 | my $old_decimal = sprintf "%d.%03d%03d", $oldx, $oldy, $oldz; # 5.011001 | |
100 | ||
101 | # each entry is | |
102 | # 0 a regexp that matches strings that might contain versions; | |
103 | # 1 a sub that returns two strings based on $1 etc values: | |
104 | # * string containing captured values (for -c) | |
105 | # * a string containing the replacement value | |
106 | # 2 what we expect the sub to return as its first arg; undef implies | |
107 | # don't match | |
108 | # 3 a regex restricting which files this applies to (undef is all files) | |
109 | # | |
110 | # Note that @maps entries are checks in order, and only the first to match | |
111 | # is used. | |
112 | ||
113 | my @maps = ( | |
114 | [ | |
115 | qr{^((?:api_)?version(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, | |
116 | sub { $2, "$1$newy$3" }, | |
117 | $oldy, | |
118 | qr/config/, | |
119 | ], | |
120 | [ | |
121 | qr{^(subversion(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, | |
122 | sub { $2, "$1$newz$3" }, | |
123 | $oldz, | |
124 | qr/config/, | |
125 | ], | |
126 | [ | |
127 | qr{^(api_subversion(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, | |
544af516 FR |
128 | sub { $2, ($newy % 2) ? "$1$newz$3" : "${1}0$3" }, |
129 | ($oldy % 2) ? $oldz : 0, | |
ae1b7029 DM |
130 | qr/config/, |
131 | ], | |
132 | [ | |
133 | qr{^(api_versionstring(?:=|\s+)'?) ([\d\.]+) ('?) (?!\.)}x, | |
544af516 FR |
134 | sub { $2, ($newy % 2) ? "$1$newx.$newy.$newz$3": "$1$newx.$newy.0$3" }, |
135 | ($oldy % 2) ? "$oldx.$oldy.$oldz" : "$oldx.$oldy.0", | |
ae1b7029 DM |
136 | qr/config/, |
137 | ], | |
138 | [ | |
139 | qr{(version\s+'?) (\d+) ('?\s+subversion\s+'?) (\d+) ('?) (?!\.)}x, | |
140 | sub { "$2-$4", "$1$newy$3$newz$5" }, | |
141 | "$oldy-$oldz", | |
142 | qr/config/, | |
143 | ], | |
144 | [ | |
145 | qr{\b (PERL_(?:API_)?VERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, | |
146 | sub { $2, "$1$newy$3"}, | |
147 | $oldy, | |
148 | ], | |
149 | [ | |
150 | qr{\b (PERL_SUBVERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, | |
151 | sub { $2, "$1$newz$3"}, | |
544af516 | 152 | ($oldy % 2) ? $oldz : 0, |
ae1b7029 DM |
153 | ], |
154 | [ | |
155 | qr{\b (PERL_API_SUBVERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, | |
544af516 FR |
156 | sub { $2, ($newy % 2) ? "$1$newz$3" : "${1}0$3" }, |
157 | $oldz, | |
ae1b7029 DM |
158 | ], |
159 | # these two formats are in README.vms | |
160 | [ | |
161 | qr{\b perl-(\d+\^\.\d+\^\.\d+) \b}x, | |
162 | sub { $1, "perl-$newx^.$newy^.$newz"}, | |
163 | undef, | |
164 | ], | |
165 | [ | |
166 | qr{\b ($oldx _ $oldy _$oldz) \b}x, | |
167 | sub { $1, ($newx . '_' . $newy . '_' . $newz)}, | |
168 | undef, | |
169 | ], | |
170 | # 5.8.9 | |
171 | [ | |
8b8cdb3a | 172 | qr{ $oldx\.$oldy\.$oldz \b}x, |
ae1b7029 DM |
173 | sub {"", "$newx.$newy.$newz"}, |
174 | undef, | |
175 | ], | |
176 | ||
177 | # 5.008009 | |
178 | [ | |
8b8cdb3a | 179 | qr{ $old_decimal \b}x, |
ae1b7029 DM |
180 | sub {"", sprintf "%d.%03d%03d", $newx, $newy, $newz }, |
181 | undef, | |
182 | ], | |
183 | ||
d4f05c0b | 184 | # perl511, perl511.dll, perl511.lib, perl511s.lib, libperl511.a |
7dfca73b | 185 | [ |
d4f05c0b VP |
186 | qr{\b ((?:lib)?) perl (\d\d\d) (s?) \b }x, |
187 | sub {$2, "$1perl$newx$newy$3" }, | |
7dfca73b | 188 | "$oldx$oldy", |
d9f179d8 | 189 | qr/win32|hints/, # README.win32, win32/*, hints/* |
7dfca73b JD |
190 | ], |
191 | ||
2e55877c DL |
192 | # microperl locations should be bumped for major versions |
193 | [ | |
194 | qr{(/)(\d\.\d{2})(["'/])}, | |
195 | sub { $2, "$1$newx.$newy$3" }, | |
196 | "$oldx.$oldy", | |
197 | qr/uconfig/, | |
198 | ], | |
199 | ||
a24e4318 TC |
200 | # win32/Makefile.ce |
201 | [ | |
202 | qr/(PV\s*=\s*)(\d\d{2})\b$/, | |
203 | sub { $2, "$1$newx$newy" }, | |
204 | "$oldx$oldy", | |
205 | qr/Makefile\.ce/, | |
206 | ], | |
ae1b7029 DM |
207 | ); |
208 | ||
209 | ||
210 | # files and dirs that we likely don't want to change version numbers on. | |
211 | ||
212 | my %SKIP_FILES = map { ($_ => 1) } qw( | |
213 | Changes | |
fcb87af3 | 214 | intrpvar.h |
ae1b7029 | 215 | MANIFEST |
dac70e9b Z |
216 | Porting/Maintainers.pl |
217 | Porting/acknowledgements.pl | |
aa1602b3 | 218 | Porting/corelist-perldelta.pl |
87f4ab41 | 219 | Porting/epigraphs.pod |
ae1b7029 | 220 | Porting/how_to_write_a_perldelta.pod |
5bd03515 | 221 | Porting/release_managers_guide.pod |
87f4ab41 | 222 | Porting/release_schedule.pod |
8b8cdb3a | 223 | Porting/bump-perl-version |
5bd03515 | 224 | pp_ctl.c |
ae1b7029 DM |
225 | ); |
226 | my @SKIP_DIRS = qw( | |
e6dc1cfe | 227 | dist |
ae1b7029 DM |
228 | ext |
229 | lib | |
230 | pod | |
d634733c | 231 | cpan |
ae1b7029 DM |
232 | t |
233 | ); | |
234 | ||
235 | my @mani_files = sort keys %{ExtUtils::Manifest::maniread('MANIFEST')}; | |
236 | my %mani_files = map { ($_ => 1) } @mani_files; | |
237 | die "No entries found in MANIFEST; aborting\n" unless @mani_files; | |
238 | ||
dc40e497 | 239 | if ($opts{c} or $opts{s} or $opts{i}) { |
ae1b7029 DM |
240 | do_scan(); |
241 | } | |
242 | elsif ($opts{u}) { | |
243 | do_update(); | |
244 | } | |
245 | else { | |
47e01c32 | 246 | usage('one of -c, -s or -u must be specified'); |
ae1b7029 DM |
247 | } |
248 | exit 0; | |
249 | ||
250 | ||
251 | ||
252 | ||
253 | sub do_scan { | |
254 | for my $file (@mani_files) { | |
e6dc1cfe | 255 | next if grep $file =~ m{^$_/}, @SKIP_DIRS; |
ae1b7029 DM |
256 | if ($SKIP_FILES{$file}) { |
257 | warn "(skipping $file)\n"; | |
258 | next; | |
259 | } | |
204fc54e | 260 | open my $fh, '<', $file; |
ae1b7029 | 261 | my $header = 0; |
dc40e497 LB |
262 | my @stat = stat $file; |
263 | my $mode = $stat[2]; | |
264 | my $file_changed = 0; | |
265 | my $new_contents = ''; | |
ae1b7029 | 266 | |
582c9380 LB |
267 | while (my $line = <$fh>) { |
268 | my $oldline = $line; | |
cc56b22c | 269 | my $line_changed = 0; |
ae1b7029 DM |
270 | for my $map (@maps) { |
271 | my ($pat, $sub, $expected, $file_pat) = @$map; | |
272 | ||
273 | next if defined $file_pat and $file !~ $file_pat; | |
582c9380 | 274 | next unless $line =~ $pat; |
ae1b7029 DM |
275 | my ($got, $replacement) = $sub->(); |
276 | ||
277 | if ($opts{c}) { | |
278 | # only report unexpected | |
279 | next unless defined $expected and $got ne $expected; | |
280 | } | |
582c9380 | 281 | $line =~ s/$pat/$replacement/ |
ae1b7029 | 282 | or die "Internal error: substitution failed: [$pat]\n"; |
cc56b22c SH |
283 | if ($line ne $oldline) { |
284 | $line_changed = 1; | |
285 | last; | |
286 | } | |
582c9380 LB |
287 | } |
288 | $new_contents .= $line if $opts{i}; | |
cc56b22c | 289 | if ($line_changed) { |
582c9380 LB |
290 | $file_changed = 1; |
291 | if ($opts{s}) { | |
292 | print "\n$file\n" unless $header; | |
293 | $header=1; | |
294 | printf "\n%5d: -%s +%s", $., $oldline, $line; | |
ae1b7029 | 295 | } |
ae1b7029 | 296 | } |
dc40e497 LB |
297 | } |
298 | if ($opts{i} && $file_changed) { | |
299 | warn "Updating $file inplace\n"; | |
300 | open my $fh, '>', $file; | |
301 | binmode $fh; | |
302 | print $fh $new_contents; | |
303 | close $fh; | |
304 | chmod $mode & 0777, $file; | |
ae1b7029 DM |
305 | } |
306 | } | |
307 | warn "(skipped $_/*)\n" for @SKIP_DIRS; | |
308 | } | |
309 | ||
310 | sub do_update { | |
311 | ||
312 | my %changes; | |
313 | my $file; | |
314 | my $line; | |
315 | ||
316 | # read in config | |
317 | ||
318 | while (<STDIN>) { | |
319 | next unless /\S/; | |
320 | if (/^(\S+)$/) { | |
321 | $file = $1; | |
322 | die "No such file in MANIFEST: '$file'\n" unless $mani_files{$file}; | |
323 | die "file already seen; '$file'\n" if exists $changes{$file}; | |
324 | undef $line; | |
325 | } | |
326 | elsif (/^\s+(\d+): -(.*)/) { | |
327 | my $old; | |
328 | ($line, $old) = ($1,$2); | |
47e01c32 | 329 | die "$.: old line without preceding filename\n" |
ae1b7029 DM |
330 | unless defined $file; |
331 | die "Dup line number: $line\n" if exists $changes{$file}{$line}; | |
332 | $changes{$file}{$line}[0] = $old; | |
333 | } | |
334 | elsif (/^\s+\+(.*)/) { | |
335 | my $new = $1; | |
336 | die "$.: replacement line seen without old line\n" unless $line; | |
337 | $changes{$file}{$line}[1] = $new; | |
338 | undef $line; | |
339 | } | |
340 | else { | |
341 | die "Unexpected line at ;line $.: $_\n"; | |
342 | } | |
343 | } | |
344 | ||
345 | # suck in file contents to memory, then update that in-memory copy | |
346 | ||
347 | my %contents; | |
348 | for my $file (sort keys %changes) { | |
204fc54e | 349 | open my $fh, '<', $file; |
33c1015f | 350 | binmode $fh; |
ae1b7029 DM |
351 | $contents{$file} = [ <$fh> ]; |
352 | chomp @{$contents{$file}}; | |
204fc54e | 353 | close $fh; |
ae1b7029 DM |
354 | |
355 | my $entries = $changes{$file}; | |
356 | for my $line (keys %$entries) { | |
357 | die "$file: no such line: $line\n" | |
358 | unless defined $contents{$file}[$line-1]; | |
359 | if ($contents{$file}[$line-1] ne $entries->{$line}[0]) { | |
360 | die "$file: line mismatch at line $line:\n" | |
361 | . "File: [$contents{$file}[$line-1]]\n" | |
362 | . "Config: [$entries->{$line}[0]]\n" | |
363 | } | |
364 | $contents{$file}[$line-1] = $entries->{$line}[1]; | |
365 | } | |
366 | } | |
367 | ||
368 | # check the temp files don't already exist | |
369 | ||
370 | for my $file (sort keys %contents) { | |
371 | my $nfile = "$file-new"; | |
372 | die "$nfile already exists in MANIFEST; aborting\n" | |
373 | if $mani_files{$nfile}; | |
374 | } | |
375 | ||
376 | # write out the new files | |
377 | ||
378 | for my $file (sort keys %contents) { | |
379 | my $nfile = "$file-new"; | |
204fc54e | 380 | open my $fh, '>', $nfile; |
33c1015f | 381 | binmode $fh; |
ae1b7029 | 382 | print $fh $_, "\n" for @{$contents{$file}}; |
204fc54e | 383 | close $fh; |
ae1b7029 | 384 | |
204fc54e | 385 | my @stat = stat $file; |
ae1b7029 DM |
386 | my $mode = $stat[2]; |
387 | die "stat $file fgailed to give a mode!\n" unless defined $mode; | |
204fc54e | 388 | chmod $mode & 0777, $nfile; |
ae1b7029 DM |
389 | } |
390 | ||
391 | # and rename them | |
392 | ||
393 | for my $file (sort keys %contents) { | |
394 | my $nfile = "$file-new"; | |
395 | warn "updating $file ...\n"; | |
204fc54e | 396 | rename $nfile, $file; |
ae1b7029 DM |
397 | } |
398 | } | |
399 |