File: bump-perl-version

package info (click to toggle)
perl 5.24.1-3+deb9u5
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 103,716 kB
  • sloc: perl: 559,611; ansic: 293,886; sh: 67,316; pascal: 7,632; cpp: 3,895; makefile: 2,436; xml: 2,410; yacc: 989; sed: 6; lisp: 1
file content (399 lines) | stat: -rw-r--r-- 10,295 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
#!/usr/bin/perl
#
# bump-perl-version, DAPM 14 Jul 2009
#
# A utility to find, and optionally bump, references to the perl version
# number in various files within the perl source
#
# It's designed to work in two phases. First, when run with -s (scan),
# it searches all the files in MANIFEST looking for strings that appear to
# match the current perl version (or which it knows are *supposed* to
# contain the current version), and produces a list of them to stdout,
# along with a suggested edit. For example:
#
#     $ Porting/bump-perl-version -s 5.10.0 5.10.1 > /tmp/scan
#     $ cat /tmp/scan
#     Porting/config.sh
#     
#     52: -archlib='/opt/perl/lib/5.10.0/i686-linux-64int'
#         +archlib='/opt/perl/lib/5.10.1/i686-linux-64int'
#     ....
#
# At this point there will be false positives. Edit the file to remove
# those changes you don't want made. Then in the second phase, feed that
# list in, and it will change those lines in the files:
#
#     $ Porting/bump-perl-version -u < /tmp/scan
#
# (so line 52 of Porting/config.sh is now updated)
#
# The -i option can be used to combine these two steps (if you prefer to make
# all of the changes at once and then edit the results via git).

# This utility 'knows' about certain files and formats, and so can spot
# 'hidden' version numbers, like PERL_SUBVERSION=9.
#
# A third variant makes use of this knowledge to check that all the things
# it knows about are at the current version:
#
#    $ Porting/bump-perl-version -c 5.10.0
#
# XXX this script hasn't been tested against a major version bump yet,
# eg 5.11.0 to 5.12.0; there may be things it missed - DAPM 14 Jul 09
#
# Note there are various files and directories that it skips; these are
# ones that are unlikely to contain anything needing bumping, but which
# will generate lots of false positives (eg pod/*). These are listed on
# STDERR as they are skipped.

use strict;
use warnings;
use autodie;
use Getopt::Std;
use ExtUtils::Manifest;


sub usage { die <<EOF }

@_

usage: $0 -c <C.C.C>
          -s <C.C.C> <N.N.N>
	  -u
	  -i <C.C.C> <N.N.N>

    -c check files and warn if any known string values (eg
	PERL_SUBVERSION) don't match the specified version

    -s scan files and produce list of possible change lines to stdout

    -u read in the scan file from stdin, and change all the lines specified

    -i scan files and make changes inplace

    C.C.C the current perl version, eg 5.10.0
    N.N.N the new     perl version, eg 5.10.1
EOF

my %opts;
getopts('csui', \%opts) or usage;
if ($opts{u}) {
    @ARGV == 0 or usage('no version version numbers should be specified');
    # fake to stop warnings when calculating $oldx etc
    @ARGV = qw(99.99.99 99.99.99);
}
elsif ($opts{c}) {
    @ARGV == 1 or usage('required one version number');
    push @ARGV, $ARGV[0];
}
else {
    @ARGV == 2 or usage('require two version numbers');
}
usage('only one of -c, -s, -u and -i') if keys %opts > 1;

my ($oldx, $oldy, $oldz) = $ARGV[0] =~ /^(\d+)\.(\d+)\.(\d+)$/
	or usage("bad version: $ARGV[0]");
my ($newx, $newy, $newz) = $ARGV[1] =~ /^(\d+)\.(\d+)\.(\d+)$/
	or usage("bad version: $ARGV[1]");

my $old_decimal = sprintf "%d.%03d%03d", $oldx, $oldy, $oldz; # 5.011001

# each entry is
#   0 a regexp that matches strings that might contain versions;
#   1 a sub that returns two strings based on $1 etc values:
#     * string containing captured values (for -c)
#     * a string containing the replacement value
#   2 what we expect the sub to return as its first arg; undef implies
#     don't match
#   3 a regex restricting which files this applies to (undef is all files)
#
# Note that @maps entries are checks in order, and only the first to match
# is used.

my @maps =  (
    [
	qr{^((?:api_)?version(?:=|\s+)'?) (\d+) ('?) (?!\.)}x,
	sub { $2, "$1$newy$3" },
	$oldy,
	qr/config/,
    ],
    [
	qr{^(subversion(?:=|\s+)'?) (\d+) ('?)  (?!\.)}x,
	sub { $2, "$1$newz$3" },
	$oldz,
	qr/config/,
    ],
    [
	qr{^(api_subversion(?:=|\s+)'?) (\d+) ('?)  (?!\.)}x,
	sub { $2, ($newy % 2) ? "$1$newz$3" : "${1}0$3" },
	($oldy % 2) ? $oldz : 0,
	qr/config/,
    ],
    [
	qr{^(api_versionstring(?:=|\s+)'?) ([\d\.]+) ('?) (?!\.)}x,
	sub { $2, ($newy % 2) ? "$1$newx.$newy.$newz$3": "$1$newx.$newy.0$3" },
	($oldy % 2) ? "$oldx.$oldy.$oldz" : "$oldx.$oldy.0",
	qr/config/,
    ],
    [
	qr{(version\s+'?) (\d+) ('?\s+subversion\s+'?) (\d+) ('?)  (?!\.)}x,
	sub { "$2-$4", "$1$newy$3$newz$5" },
	"$oldy-$oldz",
	qr/config/,
    ],
    [
	qr{\b (PERL_(?:API_)?VERSION(?:=|\s+)'?) (\d+) ('?)  (?!\.)}x,
	sub { $2, "$1$newy$3"},
	$oldy,
    ],
    [
	qr{\b (PERL_SUBVERSION(?:=|\s+)'?) (\d+) ('?)  (?!\.)}x,
	sub { $2, "$1$newz$3"},
	($oldy % 2) ? $oldz : 0,
    ],
    [
	qr{\b (PERL_API_SUBVERSION(?:=|\s+)'?) (\d+) ('?)  (?!\.)}x,
	sub { $2, ($newy % 2) ? "$1$newz$3" : "${1}0$3" },
	$oldz,
    ],
    # these two formats are in README.vms
    [
	qr{\b perl-(\d+\^\.\d+\^\.\d+) \b}x,
	sub { $1, "perl-$newx^.$newy^.$newz"},
	undef,
    ],
    [
	qr{\b ($oldx _ $oldy _$oldz) \b}x,
	sub { $1, ($newx . '_' . $newy . '_' . $newz)},
	undef,
    ],
    # 5.8.9
    [
	qr{ $oldx\.$oldy\.$oldz \b}x,
	sub {"", "$newx.$newy.$newz"},
	undef,
    ],

    # 5.008009
    [
	qr{ $old_decimal \b}x,
	sub {"", sprintf "%d.%03d%03d", $newx, $newy, $newz },
	undef,
    ],

    # perl511, perl511.dll, perl511.lib, perl511s.lib, libperl511.a
    [
	qr{\b ((?:lib)?) perl (\d\d\d) (s?) \b }x,
	sub {$2, "$1perl$newx$newy$3" },
	"$oldx$oldy",
	qr/win32|hints/,      # README.win32, win32/*, hints/*
    ],

    # microperl locations should be bumped for major versions
    [
        qr{(/)(\d\.\d{2})(["'/])},
        sub { $2, "$1$newx.$newy$3" },
        "$oldx.$oldy",
        qr/uconfig/,
    ],

    # win32/Makefile.ce
    [
        qr/(PV\s*=\s*)(\d\d{2})\b$/,
        sub { $2, "$1$newx$newy" },
        "$oldx$oldy",
        qr/Makefile\.ce/,
    ],
);


# files and dirs that we likely don't want to change version numbers on.

my %SKIP_FILES = map { ($_ => 1) } qw(
    Changes
    intrpvar.h
    MANIFEST
    Porting/Maintainers.pl
    Porting/acknowledgements.pl
    Porting/corelist-perldelta.pl
    Porting/epigraphs.pod
    Porting/how_to_write_a_perldelta.pod
    Porting/release_managers_guide.pod
    Porting/release_schedule.pod
    Porting/bump-perl-version
    pp_ctl.c
);
my @SKIP_DIRS = qw(
    dist
    ext
    lib
    pod
    cpan
    t
);

my @mani_files = sort keys %{ExtUtils::Manifest::maniread('MANIFEST')};
my %mani_files = map { ($_ => 1) } @mani_files;
die "No entries found in MANIFEST; aborting\n" unless @mani_files;

if ($opts{c} or $opts{s} or $opts{i}) {
    do_scan();
}
elsif ($opts{u}) {
    do_update();
}
else {
    usage('one of -c, -s or -u must be specified');
}
exit 0;




sub do_scan {
    for my $file (@mani_files) {
	next if grep $file =~ m{^$_/}, @SKIP_DIRS;
	if ($SKIP_FILES{$file}) {
	    warn "(skipping $file)\n";
	    next;
	}
	open my $fh, '<', $file;
	my $header = 0;
	my @stat = stat $file;
	my $mode = $stat[2];
	my $file_changed = 0;
	my $new_contents = '';

	while (my $line = <$fh>) {
	    my $oldline = $line;
	    my $line_changed = 0;
	    for my $map (@maps) {
		my ($pat, $sub, $expected, $file_pat) = @$map;

		next if defined $file_pat and $file !~ $file_pat;
		next unless $line =~ $pat;
		my ($got, $replacement) = $sub->();

		if ($opts{c}) {
		    # only report unexpected 
		    next unless defined $expected and $got ne $expected;
		}
		$line =~ s/$pat/$replacement/
		    or die "Internal error: substitution failed: [$pat]\n";
		if ($line ne $oldline) {
	            $line_changed = 1;
		    last;
		}
	    }
	    $new_contents .= $line if $opts{i};
	    if ($line_changed) {
		$file_changed = 1;
		if ($opts{s}) {
		    print "\n$file\n" unless $header;
		    $header=1;
		    printf "\n%5d: -%s       +%s", $., $oldline, $line;
		}
	    }
	}
	if ($opts{i} && $file_changed) {
	    warn "Updating $file inplace\n";
	    open my $fh, '>', $file;
	    binmode $fh;
	    print $fh $new_contents;
	    close $fh;
	    chmod $mode & 0777, $file;
	}
    }
    warn "(skipped  $_/*)\n" for @SKIP_DIRS;
}

sub do_update {

    my %changes;
    my $file;
    my $line;

    # read in config

    while (<STDIN>) {
	next unless /\S/;
	if (/^(\S+)$/) {
	    $file = $1;
	    die "No such file in MANIFEST: '$file'\n" unless $mani_files{$file};
	    die "file already seen; '$file'\n" if exists $changes{$file};
	    undef $line;
	}
	elsif (/^\s+(\d+): -(.*)/) {
	    my $old;
	    ($line, $old) = ($1,$2);
	    die "$.: old line without preceding filename\n"
			    unless defined $file;
	    die "Dup line number: $line\n" if exists $changes{$file}{$line};
	    $changes{$file}{$line}[0] = $old;
	}
	elsif (/^\s+\+(.*)/) {
	    my $new = $1;
	    die "$.: replacement line seen without old line\n" unless $line;
	    $changes{$file}{$line}[1] = $new;
	    undef $line;
	}
	else {
	    die "Unexpected line at ;line $.: $_\n";
	}
    }

    # suck in file contents to memory, then update that in-memory copy

    my %contents;
    for my $file (sort keys %changes) {
	open my $fh, '<', $file;
	binmode $fh;
	$contents{$file} = [ <$fh> ];
	chomp @{$contents{$file}};
	close $fh;

	my $entries = $changes{$file};
	for my $line (keys %$entries) {
	    die "$file: no such line: $line\n"
		    unless defined $contents{$file}[$line-1];
	    if ($contents{$file}[$line-1] ne $entries->{$line}[0]) {
		die "$file: line mismatch at line $line:\n"
			. "File:   [$contents{$file}[$line-1]]\n"
			. "Config: [$entries->{$line}[0]]\n"
	    }
	    $contents{$file}[$line-1] = $entries->{$line}[1];
	}
    }

    # check the temp files don't already exist

    for my $file (sort keys %contents) {
	my $nfile = "$file-new";
	die "$nfile already exists in MANIFEST; aborting\n"
	    if $mani_files{$nfile};
    }

    # write out the new files

    for my $file (sort keys %contents) {
	my $nfile = "$file-new";
	open my $fh, '>', $nfile;
	binmode $fh;
	print $fh $_, "\n" for @{$contents{$file}};
	close $fh;

	my @stat = stat $file;
	my $mode = $stat[2];
	die "stat $file fgailed to give a mode!\n" unless defined $mode;
	chmod $mode & 0777, $nfile;
    }

    # and rename them

    for my $file (sort keys %contents) {
	my $nfile = "$file-new";
	warn "updating $file ...\n";
	rename $nfile, $file;
    }
}