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     t
 214 );
 215
 216 my @mani_files = sort keys %{ExtUtils::Manifest::maniread('MANIFEST')};
 217 my %mani_files = map { ($_ => 1) } @mani_files;
 218 die "No entries found in MANIFEST; aborting\n" unless @mani_files;
 219
 220 if ($opts{c} or $opts{s}) {
 221     do_scan();
 222 }
 223 elsif ($opts{u}) {
 224     do_update();
 225 }
 226 else {
 227     usage('one of -c, -s or -u must be specified');
 228 }
 229 exit 0;
 230
 231
 232
 233
 234 sub do_scan {
 235     for my $file (@mani_files) {
 236         next if grep $file =~ m{$_/}, @SKIP_DIRS;
 237         if ($SKIP_FILES{$file}) {
 238             warn "(skipping $file)\n";
 239             next;
 240         }
 241         open my $fh, '<', $file or die "Aborting: can't open $file: $!\n";
 242         my $header = 0;
 243
 244         while (<$fh>) {
 245             for my $map (@maps) {
 246                 my ($pat, $sub, $expected, $file_pat) = @$map;
 247
 248                 next if defined $file_pat and $file !~ $file_pat;
 249                 next unless $_ =~ $pat;
 250                 my ($got, $replacement) = $sub->();
 251
 252                 if ($opts{c}) {
 253                     # only report unexpected
 254                     next unless defined $expected and $got ne $expected;
 255                 }
 256                 my $newstr = $_;
 257                 $newstr =~ s/$pat/$replacement/
 258                     or die "Internal error: substitution failed: [$pat]\n";
 259                 if ($_ ne $newstr) {
 260                     print "\n$file\n" unless $header;
 261                     $header=1;
 262                     printf "\n%5d: -%s       +%s", $., $_, $newstr;
 263                 }
 264                 last;
 265             }
 266         }
 267     }
 268     warn "(skipped  $_/*)\n" for @SKIP_DIRS;
 269 }
 270
 271 sub do_update {
 272
 273     my %changes;
 274     my $file;
 275     my $line;
 276
 277     # read in config
 278
 279     while (<STDIN>) {
 280         next unless /\S/;
 281         if (/^(\S+)$/) {
 282             $file = $1;
 283             die "No such file in MANIFEST: '$file'\n" unless $mani_files{$file};
 284             die "file already seen; '$file'\n" if exists $changes{$file};
 285             undef $line;
 286         }
 287         elsif (/^\s+(\d+): -(.*)/) {
 288             my $old;
 289             ($line, $old) = ($1,$2);
 290             die "$.: old line without preceding filename\n"
 291                             unless defined $file;
 292             die "Dup line number: $line\n" if exists $changes{$file}{$line};
 293             $changes{$file}{$line}[0] = $old;
 294         }
 295         elsif (/^\s+\+(.*)/) {
 296             my $new = $1;
 297             die "$.: replacement line seen without old line\n" unless $line;
 298             $changes{$file}{$line}[1] = $new;
 299             undef $line;
 300         }
 301         else {
 302             die "Unexpected line at ;line $.: $_\n";
 303         }
 304     }
 305
 306     # suck in file contents to memory, then update that in-memory copy
 307
 308     my %contents;
 309     for my $file (sort keys %changes) {
 310         open my $fh, '<', $file or die "open '$file': $!\n";
 311         binmode $fh;
 312         $contents{$file} = [ <$fh> ];
 313         chomp @{$contents{$file}};
 314         close $fh or die "close: '$file': $!\n";
 315
 316         my $entries = $changes{$file};
 317         for my $line (keys %$entries) {
 318             die "$file: no such line: $line\n"
 319                     unless defined $contents{$file}[$line-1];
 320             if ($contents{$file}[$line-1] ne $entries->{$line}[0]) {
 321                 die "$file: line mismatch at line $line:\n"
 322                         . "File:   [$contents{$file}[$line-1]]\n"
 323                         . "Config: [$entries->{$line}[0]]\n"
 324             }
 325             $contents{$file}[$line-1] = $entries->{$line}[1];
 326         }
 327     }
 328
 329     # check the temp files don't already exist
 330
 331     for my $file (sort keys %contents) {
 332         my $nfile = "$file-new";
 333         die "$nfile already exists in MANIFEST; aborting\n"
 334             if $mani_files{$nfile};
 335     }
 336
 337     # write out the new files
 338
 339     for my $file (sort keys %contents) {
 340         my $nfile = "$file-new";
 341         open my $fh, '>', $nfile or die "create '$nfile' failed: $!\n";
 342         binmode $fh;
 343         print $fh $_, "\n" for @{$contents{$file}};
 344         close $fh or die "failed to close $nfile; aborting: $!\n";
 345
 346         my @stat = stat $file or die "Can't stat $file: $!\n";
 347         my $mode = $stat[2];
 348         die "stat $file fgailed to give a mode!\n" unless defined $mode;
 349         chmod $mode & 0777, $nfile or die "chmod $nfile failed; aborting: $!\n";
 350     }
 351
 352     # and rename them
 353
 354     for my $file (sort keys %contents) {
 355         my $nfile = "$file-new";
 356         warn "updating $file ...\n";
 357         rename $nfile, $file or die "rename $nfile $file: $!\n";
 358     }
 359 }
 360