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