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