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) | |
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 | ||
46 | use strict; | |
47 | use warnings; | |
48 | use Getopt::Std; | |
49 | use ExtUtils::Manifest; | |
50 | ||
51 | ||
52 | sub usage { die <<EOF } | |
53 | ||
54 | @_ | |
55 | ||
56 | usage: $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 | |
69 | EOF | |
70 | ||
71 | my %opts; | |
72 | getopts('csu', \%opts) or usage; | |
73 | if ($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 | } | |
78 | elsif ($opts{c}) { | |
79 | @ARGV == 1 or usage('required one version number'); | |
80 | push @ARGV, $ARGV[0]; | |
81 | } | |
82 | else { | |
83 | @ARGV == 2 or usage('require two version numbers'); | |
84 | } | |
85 | usage('only one of -c, -s and -u') if keys %opts > 1; | |
86 | ||
87 | my ($oldx, $oldy, $oldz) = $ARGV[0] =~ /^(\d+)\.(\d+)\.(\d+)$/ | |
88 | or usage("bad version: $ARGV[0]"); | |
89 | my ($newx, $newy, $newz) = $ARGV[1] =~ /^(\d+)\.(\d+)\.(\d+)$/ | |
90 | or usage("bad version: $ARGV[1]"); | |
91 | ||
92 | my $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 | ||
106 | my @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 | ||
ae1b7029 DM |
185 | ); |
186 | ||
187 | ||
188 | # files and dirs that we likely don't want to change version numbers on. | |
189 | ||
190 | my %SKIP_FILES = map { ($_ => 1) } qw( | |
191 | Changes | |
192 | MANIFEST | |
87f4ab41 | 193 | Porting/epigraphs.pod |
ae1b7029 | 194 | Porting/how_to_write_a_perldelta.pod |
5bd03515 | 195 | Porting/release_managers_guide.pod |
87f4ab41 | 196 | Porting/release_schedule.pod |
8b8cdb3a | 197 | Porting/bump-perl-version |
ae1b7029 | 198 | pod.lst |
5bd03515 | 199 | pp_ctl.c |
ae1b7029 DM |
200 | ); |
201 | my @SKIP_DIRS = qw( | |
202 | ext | |
203 | lib | |
204 | pod | |
205 | t | |
206 | ); | |
207 | ||
208 | my @mani_files = sort keys %{ExtUtils::Manifest::maniread('MANIFEST')}; | |
209 | my %mani_files = map { ($_ => 1) } @mani_files; | |
210 | die "No entries found in MANIFEST; aborting\n" unless @mani_files; | |
211 | ||
212 | if ($opts{c} or $opts{s}) { | |
213 | do_scan(); | |
214 | } | |
215 | elsif ($opts{u}) { | |
216 | do_update(); | |
217 | } | |
218 | else { | |
219 | usage('one of -c, -s or -u must be specifcied'); | |
220 | } | |
221 | exit 0; | |
222 | ||
223 | ||
224 | ||
225 | ||
226 | sub do_scan { | |
227 | for my $file (@mani_files) { | |
228 | next if grep $file =~ m{$_/}, @SKIP_DIRS; | |
229 | if ($SKIP_FILES{$file}) { | |
230 | warn "(skipping $file)\n"; | |
231 | next; | |
232 | } | |
233 | open my $fh, '<', $file or die "Aborting: can't open $file: $!\n"; | |
234 | my $header = 0; | |
235 | ||
236 | while (<$fh>) { | |
237 | for my $map (@maps) { | |
238 | my ($pat, $sub, $expected, $file_pat) = @$map; | |
239 | ||
240 | next if defined $file_pat and $file !~ $file_pat; | |
241 | next unless $_ =~ $pat; | |
242 | my ($got, $replacement) = $sub->(); | |
243 | ||
244 | if ($opts{c}) { | |
245 | # only report unexpected | |
246 | next unless defined $expected and $got ne $expected; | |
247 | } | |
248 | my $newstr = $_; | |
249 | $newstr =~ s/$pat/$replacement/ | |
250 | or die "Internal error: substitution failed: [$pat]\n"; | |
251 | if ($_ ne $newstr) { | |
252 | print "\n$file\n" unless $header; | |
253 | $header=1; | |
254 | printf "\n%5d: -%s +%s", $., $_, $newstr; | |
255 | } | |
256 | last; | |
257 | } | |
258 | } | |
259 | } | |
260 | warn "(skipped $_/*)\n" for @SKIP_DIRS; | |
261 | } | |
262 | ||
263 | sub do_update { | |
264 | ||
265 | my %changes; | |
266 | my $file; | |
267 | my $line; | |
268 | ||
269 | # read in config | |
270 | ||
271 | while (<STDIN>) { | |
272 | next unless /\S/; | |
273 | if (/^(\S+)$/) { | |
274 | $file = $1; | |
275 | die "No such file in MANIFEST: '$file'\n" unless $mani_files{$file}; | |
276 | die "file already seen; '$file'\n" if exists $changes{$file}; | |
277 | undef $line; | |
278 | } | |
279 | elsif (/^\s+(\d+): -(.*)/) { | |
280 | my $old; | |
281 | ($line, $old) = ($1,$2); | |
282 | die "$.: old line without preceeding filename\n" | |
283 | unless defined $file; | |
284 | die "Dup line number: $line\n" if exists $changes{$file}{$line}; | |
285 | $changes{$file}{$line}[0] = $old; | |
286 | } | |
287 | elsif (/^\s+\+(.*)/) { | |
288 | my $new = $1; | |
289 | die "$.: replacement line seen without old line\n" unless $line; | |
290 | $changes{$file}{$line}[1] = $new; | |
291 | undef $line; | |
292 | } | |
293 | else { | |
294 | die "Unexpected line at ;line $.: $_\n"; | |
295 | } | |
296 | } | |
297 | ||
298 | # suck in file contents to memory, then update that in-memory copy | |
299 | ||
300 | my %contents; | |
301 | for my $file (sort keys %changes) { | |
302 | open my $fh, '<', $file or die "open '$file': $!\n"; | |
33c1015f | 303 | binmode $fh; |
ae1b7029 DM |
304 | $contents{$file} = [ <$fh> ]; |
305 | chomp @{$contents{$file}}; | |
306 | close $fh or die "close: '$file': $!\n"; | |
307 | ||
308 | my $entries = $changes{$file}; | |
309 | for my $line (keys %$entries) { | |
310 | die "$file: no such line: $line\n" | |
311 | unless defined $contents{$file}[$line-1]; | |
312 | if ($contents{$file}[$line-1] ne $entries->{$line}[0]) { | |
313 | die "$file: line mismatch at line $line:\n" | |
314 | . "File: [$contents{$file}[$line-1]]\n" | |
315 | . "Config: [$entries->{$line}[0]]\n" | |
316 | } | |
317 | $contents{$file}[$line-1] = $entries->{$line}[1]; | |
318 | } | |
319 | } | |
320 | ||
321 | # check the temp files don't already exist | |
322 | ||
323 | for my $file (sort keys %contents) { | |
324 | my $nfile = "$file-new"; | |
325 | die "$nfile already exists in MANIFEST; aborting\n" | |
326 | if $mani_files{$nfile}; | |
327 | } | |
328 | ||
329 | # write out the new files | |
330 | ||
331 | for my $file (sort keys %contents) { | |
332 | my $nfile = "$file-new"; | |
333 | open my $fh, '>', $nfile or die "create '$nfile' failed: $!\n"; | |
33c1015f | 334 | binmode $fh; |
ae1b7029 DM |
335 | print $fh $_, "\n" for @{$contents{$file}}; |
336 | close $fh or die "failed to close $nfile; aborting: $!\n"; | |
337 | ||
338 | my @stat = stat $file or die "Can't stat $file: $!\n"; | |
339 | my $mode = $stat[2]; | |
340 | die "stat $file fgailed to give a mode!\n" unless defined $mode; | |
341 | chmod $mode & 0777, $nfile or die "chmod $nfile failed; aborting: $!\n"; | |
342 | } | |
343 | ||
344 | # and rename them | |
345 | ||
346 | for my $file (sort keys %contents) { | |
347 | my $nfile = "$file-new"; | |
348 | warn "updating $file ...\n"; | |
349 | rename $nfile, $file or die "rename $nfile $file: $!\n"; | |
350 | } | |
351 | } | |
352 |