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 46use strict; 47use warnings; 48use autodie; 49use Getopt::Std; 50use ExtUtils::Manifest; 51 52 53sub usage { die <<EOF } 54 55@_ 56 57usage: $0 -c <C.C.C> 58 -s <C.C.C> <N.N.N> 59 -u 60 -i <C.C.C> <N.N.N> 61 62 -c check files and warn if any known string values (eg 63 PERL_SUBVERSION) don't match the specified version 64 65 -s scan files and produce list of possible change lines to stdout 66 67 -u read in the scan file from stdin, and change all the lines specified 68 69 -i scan files and make changes inplace 70 71 C.C.C the current perl version, eg 5.10.0 72 N.N.N the new perl version, eg 5.10.1 73EOF 74 75my %opts; 76getopts('csui', \%opts) or usage; 77if ($opts{u}) { 78 @ARGV == 0 or usage('no version version numbers should be specified'); 79 # fake to stop warnings when calculating $oldx etc 80 @ARGV = qw(99.99.99 99.99.99); 81} 82elsif ($opts{c}) { 83 @ARGV == 1 or usage('required one version number'); 84 push @ARGV, $ARGV[0]; 85} 86else { 87 @ARGV == 2 or usage('require two version numbers'); 88} 89usage('only one of -c, -s, -u and -i') if keys %opts > 1; 90 91my ($oldx, $oldy, $oldz) = $ARGV[0] =~ /^(\d+)\.(\d+)\.(\d+)$/ 92 or usage("bad version: $ARGV[0]"); 93my ($newx, $newy, $newz) = $ARGV[1] =~ /^(\d+)\.(\d+)\.(\d+)$/ 94 or usage("bad version: $ARGV[1]"); 95 96my $old_decimal = sprintf "%d.%03d%03d", $oldx, $oldy, $oldz; # 5.011001 97 98# each entry is 99# 0 a regexp that matches strings that might contain versions; 100# 1 a sub that returns two strings based on $1 etc values: 101# * string containing captured values (for -c) 102# * a string containing the replacement value 103# 2 what we expect the sub to return as its first arg; undef implies 104# don't match 105# 3 a regex restricting which files this applies to (undef is all files) 106# 107# Note that @maps entries are checks in order, and only the first to match 108# is used. 109 110my @maps = ( 111 [ 112 qr{^((?:api_)?version(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, 113 sub { $2, "$1$newy$3" }, 114 $oldy, 115 qr/config/, 116 ], 117 [ 118 qr{^(subversion(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, 119 sub { $2, "$1$newz$3" }, 120 $oldz, 121 qr/config/, 122 ], 123 [ 124 qr{^(api_subversion(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, 125 sub { $2, ($newy % 2) ? "$1$newz$3" : "${1}0$3" }, 126 ($oldy % 2) ? $oldz : 0, 127 qr/config/, 128 ], 129 [ 130 qr{^(api_versionstring(?:=|\s+)'?) ([\d\.]+) ('?) (?!\.)}x, 131 sub { $2, ($newy % 2) ? "$1$newx.$newy.$newz$3": "$1$newx.$newy.0$3" }, 132 ($oldy % 2) ? "$oldx.$oldy.$oldz" : "$oldx.$oldy.0", 133 qr/config/, 134 ], 135 [ 136 qr{(version\s+'?) (\d+) ('?\s+subversion\s+'?) (\d+) ('?) (?!\.)}x, 137 sub { "$2-$4", "$1$newy$3$newz$5" }, 138 "$oldy-$oldz", 139 qr/config/, 140 ], 141 [ 142 qr{\b (PERL_(?:API_)?VERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, 143 sub { $2, "$1$newy$3"}, 144 $oldy, 145 ], 146 [ 147 qr{\b (PERL_SUBVERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, 148 sub { $2, "$1$newz$3"}, 149 ($oldy % 2) ? $oldz : 0, 150 ], 151 [ 152 qr{\b (PERL_API_SUBVERSION(?:=|\s+)'?) (\d+) ('?) (?!\.)}x, 153 sub { $2, ($newy % 2) ? "$1$newz$3" : "${1}0$3" }, 154 $oldz, 155 ], 156 # these two formats are in README.vms 157 [ 158 qr{\b perl-(\d+\^\.\d+\^\.\d+) \b}x, 159 sub { $1, "perl-$newx^.$newy^.$newz"}, 160 undef, 161 ], 162 [ 163 qr{\b ($oldx _ $oldy _$oldz) \b}x, 164 sub { $1, ($newx . '_' . $newy . '_' . $newz)}, 165 undef, 166 ], 167 # 5.8.9 168 [ 169 qr{ $oldx\.$oldy\.$oldz \b}x, 170 sub {"", "$newx.$newy.$newz"}, 171 undef, 172 ], 173 174 # 5.008009 175 [ 176 qr{ $old_decimal \b}x, 177 sub {"", sprintf "%d.%03d%03d", $newx, $newy, $newz }, 178 undef, 179 ], 180 181 # perl511, perl511.dll, perl511.lib, perl511s.lib, libperl511.a 182 [ 183 qr{\b ((?:lib)?) perl (\d\d\d) (s?) \b }x, 184 sub {$2, "$1perl$newx$newy$3" }, 185 "$oldx$oldy", 186 qr/win32|hints/, # README.win32, win32/*, hints/* 187 ], 188 189 # microperl locations should be bumped for major versions 190 [ 191 qr{(/)(\d\.\d{2})(["'/])}, 192 sub { $2, "$1$newx.$newy$3" }, 193 "$oldx.$oldy", 194 qr/uconfig/, 195 ], 196 197 # rename perl-5^.15^.1.dirperl-5_15_1.dir in README.vms 198 [ 199 qr{\sperl-(\d+)_(\d+)_(\d+)\.dir}x, 200 sub { " perl-${1}_${2}_${3}.dir", " perl-${newx}_${newy}_${newz}.dir" }, 201 " perl-${oldx}_${oldy}_{$oldz}.dir", 202 qr/README.vms/, 203 ], 204 205); 206 207 208# files and dirs that we likely don't want to change version numbers on. 209 210my %SKIP_FILES = map { ($_ => 1) } qw( 211 Changes 212 MANIFEST 213 Porting/Maintainers.pl 214 Porting/acknowledgements.pl 215 Porting/epigraphs.pod 216 Porting/how_to_write_a_perldelta.pod 217 Porting/release_managers_guide.pod 218 Porting/release_schedule.pod 219 Porting/bump-perl-version 220 pp_ctl.c 221); 222my @SKIP_DIRS = qw( 223 ext 224 lib 225 pod 226 cpan 227 t 228); 229 230my @mani_files = sort keys %{ExtUtils::Manifest::maniread('MANIFEST')}; 231my %mani_files = map { ($_ => 1) } @mani_files; 232die "No entries found in MANIFEST; aborting\n" unless @mani_files; 233 234if ($opts{c} or $opts{s} or $opts{i}) { 235 do_scan(); 236} 237elsif ($opts{u}) { 238 do_update(); 239} 240else { 241 usage('one of -c, -s or -u must be specified'); 242} 243exit 0; 244 245 246 247 248sub do_scan { 249 for my $file (@mani_files) { 250 next if grep $file =~ m{$_/}, @SKIP_DIRS; 251 if ($SKIP_FILES{$file}) { 252 warn "(skipping $file)\n"; 253 next; 254 } 255 open my $fh, '<', $file; 256 my $header = 0; 257 my @stat = stat $file; 258 my $mode = $stat[2]; 259 my $file_changed = 0; 260 my $new_contents = ''; 261 262 while (my $line = <$fh>) { 263 my $oldline = $line; 264 for my $map (@maps) { 265 my ($pat, $sub, $expected, $file_pat) = @$map; 266 267 next if defined $file_pat and $file !~ $file_pat; 268 next unless $line =~ $pat; 269 my ($got, $replacement) = $sub->(); 270 271 if ($opts{c}) { 272 # only report unexpected 273 next unless defined $expected and $got ne $expected; 274 } 275 $line =~ s/$pat/$replacement/ 276 or die "Internal error: substitution failed: [$pat]\n"; 277 } 278 $new_contents .= $line if $opts{i}; 279 if ($line ne $oldline) { 280 $file_changed = 1; 281 if ($opts{s}) { 282 print "\n$file\n" unless $header; 283 $header=1; 284 printf "\n%5d: -%s +%s", $., $oldline, $line; 285 } 286 } 287 } 288 if ($opts{i} && $file_changed) { 289 warn "Updating $file inplace\n"; 290 open my $fh, '>', $file; 291 binmode $fh; 292 print $fh $new_contents; 293 close $fh; 294 chmod $mode & 0777, $file; 295 } 296 } 297 warn "(skipped $_/*)\n" for @SKIP_DIRS; 298} 299 300sub do_update { 301 302 my %changes; 303 my $file; 304 my $line; 305 306 # read in config 307 308 while (<STDIN>) { 309 next unless /\S/; 310 if (/^(\S+)$/) { 311 $file = $1; 312 die "No such file in MANIFEST: '$file'\n" unless $mani_files{$file}; 313 die "file already seen; '$file'\n" if exists $changes{$file}; 314 undef $line; 315 } 316 elsif (/^\s+(\d+): -(.*)/) { 317 my $old; 318 ($line, $old) = ($1,$2); 319 die "$.: old line without preceding filename\n" 320 unless defined $file; 321 die "Dup line number: $line\n" if exists $changes{$file}{$line}; 322 $changes{$file}{$line}[0] = $old; 323 } 324 elsif (/^\s+\+(.*)/) { 325 my $new = $1; 326 die "$.: replacement line seen without old line\n" unless $line; 327 $changes{$file}{$line}[1] = $new; 328 undef $line; 329 } 330 else { 331 die "Unexpected line at ;line $.: $_\n"; 332 } 333 } 334 335 # suck in file contents to memory, then update that in-memory copy 336 337 my %contents; 338 for my $file (sort keys %changes) { 339 open my $fh, '<', $file; 340 binmode $fh; 341 $contents{$file} = [ <$fh> ]; 342 chomp @{$contents{$file}}; 343 close $fh; 344 345 my $entries = $changes{$file}; 346 for my $line (keys %$entries) { 347 die "$file: no such line: $line\n" 348 unless defined $contents{$file}[$line-1]; 349 if ($contents{$file}[$line-1] ne $entries->{$line}[0]) { 350 die "$file: line mismatch at line $line:\n" 351 . "File: [$contents{$file}[$line-1]]\n" 352 . "Config: [$entries->{$line}[0]]\n" 353 } 354 $contents{$file}[$line-1] = $entries->{$line}[1]; 355 } 356 } 357 358 # check the temp files don't already exist 359 360 for my $file (sort keys %contents) { 361 my $nfile = "$file-new"; 362 die "$nfile already exists in MANIFEST; aborting\n" 363 if $mani_files{$nfile}; 364 } 365 366 # write out the new files 367 368 for my $file (sort keys %contents) { 369 my $nfile = "$file-new"; 370 open my $fh, '>', $nfile; 371 binmode $fh; 372 print $fh $_, "\n" for @{$contents{$file}}; 373 close $fh; 374 375 my @stat = stat $file; 376 my $mode = $stat[2]; 377 die "stat $file fgailed to give a mode!\n" unless defined $mode; 378 chmod $mode & 0777, $nfile; 379 } 380 381 # and rename them 382 383 for my $file (sort keys %contents) { 384 my $nfile = "$file-new"; 385 warn "updating $file ...\n"; 386 rename $nfile, $file; 387 } 388} 389 390