This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
We shouldn't be changing perl version numbers in blead-isn't-upstream
[perl5.git] / Porting / bump-perl-version
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 specified');
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,
121         sub { $2, ($newy % 2) ? "$1$newz$3" : "${1}0$3" },
122         ($oldy % 2) ? $oldz : 0,
123         qr/config/,
124     ],
125     [
126         qr{^(api_versionstring(?:=|\s+)'?) ([\d\.]+) ('?) (?!\.)}x,
127         sub { $2, ($newy % 2) ? "$1$newx.$newy.$newz$3": "$1$newx.$newy.0$3" },
128         ($oldy % 2) ? "$oldx.$oldy.$oldz" : "$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         ($oldy % 2) ? $oldz : 0,
146     ],
147     [
148         qr{\b (PERL_API_SUBVERSION(?:=|\s+)'?) (\d+) ('?)  (?!\.)}x,
149         sub { $2, ($newy % 2) ? "$1$newz$3" : "${1}0$3" },
150         $oldz,
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{ $oldx\.$oldy\.$oldz \b}x,
166         sub {"", "$newx.$newy.$newz"},
167         undef,
168     ],
169
170     # 5.008009
171     [
172         qr{ $old_decimal \b}x,
173         sub {"", sprintf "%d.%03d%03d", $newx, $newy, $newz },
174         undef,
175     ],
176
177     # perl511, perl511.dll, perl511.lib, perl511s.lib, libperl511.a
178     [
179         qr{\b ((?:lib)?) perl (\d\d\d) (s?) \b }x,
180         sub {$2, "$1perl$newx$newy$3" },
181         "$oldx$oldy",
182         qr/makedef|win32|hints/,      # makedef.pl, README.win32, win32/*, hints/*
183     ],
184
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
193 );
194
195
196 # files and dirs that we likely don't want to change version numbers on.
197
198 my %SKIP_FILES = map { ($_ => 1) } qw(
199     Changes
200     MANIFEST
201     Porting/epigraphs.pod
202     Porting/how_to_write_a_perldelta.pod
203     Porting/release_managers_guide.pod
204     Porting/release_schedule.pod
205     Porting/bump-perl-version
206     pod.lst
207     pp_ctl.c
208 );
209 my @SKIP_DIRS = qw(
210     ext
211     lib
212     pod
213     cpan
214     t
215 );
216
217 my @mani_files = sort keys %{ExtUtils::Manifest::maniread('MANIFEST')};
218 my %mani_files = map { ($_ => 1) } @mani_files;
219 die "No entries found in MANIFEST; aborting\n" unless @mani_files;
220
221 if ($opts{c} or $opts{s}) {
222     do_scan();
223 }
224 elsif ($opts{u}) {
225     do_update();
226 }
227 else {
228     usage('one of -c, -s or -u must be specified');
229 }
230 exit 0;
231
232
233
234
235 sub 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
272 sub 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);
291             die "$.: old line without preceding filename\n"
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";
312         binmode $fh;
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";
343         binmode $fh;
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