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# 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). 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 46# will generate lots of false positives (eg pod/*). These are listed on 47# STDERR as they are skipped. 48 49use strict; 50use warnings; 51use autodie; 52use Getopt::Std; 53use ExtUtils::Manifest; 54 55 56sub usage { die <<EOF } 57 58@_ 59 60usage: $0 -c <C.C.C> 61 -s <C.C.C> <N.N.N> 62 -u 63 -i <C.C.C> <N.N.N> 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 72 -i scan files and make changes inplace 73 74 C.C.C the current perl version, eg 5.10.0 75 N.N.N the new perl version, eg 5.10.1 76EOF 77 78my %opts; 79getopts('csui', \%opts) or usage; 80if ($opts{u}) { 81 @ARGV == 0 or usage('no version version numbers should be specified'); 82 # fake to stop warnings when calculating $oldx etc 83 @ARGV = qw(99.99.99 99.99.99); 84} 85elsif ($opts{c}) { 86 @ARGV == 1 or usage('required one version number'); 87 push @ARGV, $ARGV[0]; 88} 89else { 90 @ARGV == 2 or usage('require two version numbers'); 91} 92usage('only one of -c, -s, -u and -i') if keys %opts > 1; 93 94my ($oldx, $oldy, $oldz) = $ARGV[0] =~ /^(\d+)\.(\d+)\.(\d+)$/ 95 or usage("bad version: $ARGV[0]"); 96my ($newx, $newy, $newz) = $ARGV[1] =~ /^(\d+)\.(\d+)\.(\d+)$/ 97 or usage("bad version: $ARGV[1]"); 98 99my $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 113my @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, 128 sub { $2, ($newy % 2) ? "$1$newz$3" : "${1}0$3" }, 129 ($oldy % 2) ? $oldz : 0, 130 qr/config/, 131 ], 132 [ 133 qr{^(api_versionstring(?:=|\s+)'?) ([\d\.]+) ('?) (?!\.)}x, 134 sub { $2, ($newy % 2) ? "$1$newx.$newy.$newz$3": "$1$newx.$newy.0$3" }, 135 ($oldy % 2) ? "$oldx.$oldy.$oldz" : "$oldx.$oldy.0", 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"}, 152 ($oldy % 2) ? $oldz : 0, 153 ], 154 [ 155 qr{\b (PERL_API_SUBVERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, 156 sub { $2, ($newy % 2) ? "$1$newz$3" : "${1}0$3" }, 157 $oldz, 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 [ 172 qr{ $oldx\.$oldy\.$oldz \b}x, 173 sub {"", "$newx.$newy.$newz"}, 174 undef, 175 ], 176 177 # 5.008009 178 [ 179 qr{ $old_decimal \b}x, 180 sub {"", sprintf "%d.%03d%03d", $newx, $newy, $newz }, 181 undef, 182 ], 183 184 # perl511, perl511.dll, perl511.lib, perl511s.lib, libperl511.a 185 [ 186 qr{\b ((?:lib)?) perl (\d\d\d) (s?) \b }x, 187 sub {$2, "$1perl$newx$newy$3" }, 188 "$oldx$oldy", 189 qr/win32|hints/, # README.win32, win32/*, hints/* 190 ], 191 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 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 ], 207); 208 209 210# files and dirs that we likely don't want to change version numbers on. 211 212my %SKIP_FILES = map { ($_ => 1) } qw( 213 Changes 214 MANIFEST 215 Porting/Maintainers.pl 216 Porting/acknowledgements.pl 217 Porting/corelist-perldelta.pl 218 Porting/epigraphs.pod 219 Porting/how_to_write_a_perldelta.pod 220 Porting/release_managers_guide.pod 221 Porting/release_schedule.pod 222 Porting/bump-perl-version 223 pp_ctl.c 224); 225my @SKIP_DIRS = qw( 226 ext 227 lib 228 pod 229 cpan 230 t 231); 232 233my @mani_files = sort keys %{ExtUtils::Manifest::maniread('MANIFEST')}; 234my %mani_files = map { ($_ => 1) } @mani_files; 235die "No entries found in MANIFEST; aborting\n" unless @mani_files; 236 237if ($opts{c} or $opts{s} or $opts{i}) { 238 do_scan(); 239} 240elsif ($opts{u}) { 241 do_update(); 242} 243else { 244 usage('one of -c, -s or -u must be specified'); 245} 246exit 0; 247 248 249 250 251sub do_scan { 252 for my $file (@mani_files) { 253 next if grep $file =~ m{$_/}, @SKIP_DIRS; 254 if ($SKIP_FILES{$file}) { 255 warn "(skipping $file)\n"; 256 next; 257 } 258 open my $fh, '<', $file; 259 my $header = 0; 260 my @stat = stat $file; 261 my $mode = $stat[2]; 262 my $file_changed = 0; 263 my $new_contents = ''; 264 265 while (my $line = <$fh>) { 266 my $oldline = $line; 267 for my $map (@maps) { 268 my ($pat, $sub, $expected, $file_pat) = @$map; 269 270 next if defined $file_pat and $file !~ $file_pat; 271 next unless $line =~ $pat; 272 my ($got, $replacement) = $sub->(); 273 274 if ($opts{c}) { 275 # only report unexpected 276 next unless defined $expected and $got ne $expected; 277 } 278 $line =~ s/$pat/$replacement/ 279 or die "Internal error: substitution failed: [$pat]\n"; 280 } 281 $new_contents .= $line if $opts{i}; 282 if ($line ne $oldline) { 283 $file_changed = 1; 284 if ($opts{s}) { 285 print "\n$file\n" unless $header; 286 $header=1; 287 printf "\n%5d: -%s +%s", $., $oldline, $line; 288 } 289 } 290 } 291 if ($opts{i} && $file_changed) { 292 warn "Updating $file inplace\n"; 293 open my $fh, '>', $file; 294 binmode $fh; 295 print $fh $new_contents; 296 close $fh; 297 chmod $mode & 0777, $file; 298 } 299 } 300 warn "(skipped $_/*)\n" for @SKIP_DIRS; 301} 302 303sub do_update { 304 305 my %changes; 306 my $file; 307 my $line; 308 309 # read in config 310 311 while (<STDIN>) { 312 next unless /\S/; 313 if (/^(\S+)$/) { 314 $file = $1; 315 die "No such file in MANIFEST: '$file'\n" unless $mani_files{$file}; 316 die "file already seen; '$file'\n" if exists $changes{$file}; 317 undef $line; 318 } 319 elsif (/^\s+(\d+): -(.*)/) { 320 my $old; 321 ($line, $old) = ($1,$2); 322 die "$.: old line without preceding filename\n" 323 unless defined $file; 324 die "Dup line number: $line\n" if exists $changes{$file}{$line}; 325 $changes{$file}{$line}[0] = $old; 326 } 327 elsif (/^\s+\+(.*)/) { 328 my $new = $1; 329 die "$.: replacement line seen without old line\n" unless $line; 330 $changes{$file}{$line}[1] = $new; 331 undef $line; 332 } 333 else { 334 die "Unexpected line at ;line $.: $_\n"; 335 } 336 } 337 338 # suck in file contents to memory, then update that in-memory copy 339 340 my %contents; 341 for my $file (sort keys %changes) { 342 open my $fh, '<', $file; 343 binmode $fh; 344 $contents{$file} = [ <$fh> ]; 345 chomp @{$contents{$file}}; 346 close $fh; 347 348 my $entries = $changes{$file}; 349 for my $line (keys %$entries) { 350 die "$file: no such line: $line\n" 351 unless defined $contents{$file}[$line-1]; 352 if ($contents{$file}[$line-1] ne $entries->{$line}[0]) { 353 die "$file: line mismatch at line $line:\n" 354 . "File: [$contents{$file}[$line-1]]\n" 355 . "Config: [$entries->{$line}[0]]\n" 356 } 357 $contents{$file}[$line-1] = $entries->{$line}[1]; 358 } 359 } 360 361 # check the temp files don't already exist 362 363 for my $file (sort keys %contents) { 364 my $nfile = "$file-new"; 365 die "$nfile already exists in MANIFEST; aborting\n" 366 if $mani_files{$nfile}; 367 } 368 369 # write out the new files 370 371 for my $file (sort keys %contents) { 372 my $nfile = "$file-new"; 373 open my $fh, '>', $nfile; 374 binmode $fh; 375 print $fh $_, "\n" for @{$contents{$file}}; 376 close $fh; 377 378 my @stat = stat $file; 379 my $mode = $stat[2]; 380 die "stat $file fgailed to give a mode!\n" unless defined $mode; 381 chmod $mode & 0777, $nfile; 382 } 383 384 # and rename them 385 386 for my $file (sort keys %contents) { 387 my $nfile = "$file-new"; 388 warn "updating $file ...\n"; 389 rename $nfile, $file; 390 } 391} 392 393