build-aux/announce-gen

   1 #!/usr/bin/perl -w
   2 # Generate a release announcement message.
   3
   4 my $VERSION = '2008-01-12 07:47'; # UTC
   5 # The definition above must lie within the first 8 lines in order
   6 # for the Emacs time-stamp write hook (at end) to update it.
   7 # If you change this file with Emacs, please let the write hook
   8 # do its job.  Otherwise, update this string manually.
   9
  10 # Copyright (C) 2002-2008 Free Software Foundation, Inc.
  11
  12 # This program is free software: you can redistribute it and/or modify
  13 # it under the terms of the GNU General Public License as published by
  14 # the Free Software Foundation, either version 3 of the License, or
  15 # (at your option) any later version.
  16
  17 # This program is distributed in the hope that it will be useful,
  18 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 # GNU General Public License for more details.
  21
  22 # You should have received a copy of the GNU General Public License
  23 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 # Written by Jim Meyering
  26
  27 use strict;
  28
  29 use Getopt::Long;
  30 use Digest::MD5;
  31 use Digest::SHA1;
  32 use POSIX qw(strftime);
  33
  34 (my $ME = $0) =~ s|.*/||;
  35
  36 my %valid_release_types = map {$_ => 1} qw (alpha beta major);
  37
  38 END
  39 {
  40   # Nobody ever checks the status of print()s.  That's okay, because
  41   # if any do fail, we're guaranteed to get an indicator when we close()
  42   # the filehandle.
  43   #
  44   # Close stdout now, and if there were no errors, return happy status.
  45   # If stdout has already been closed by the script, though, do nothing.
  46   defined fileno STDOUT
  47     or return;
  48   close STDOUT
  49     and return;
  50
  51   # Errors closing stdout.  Indicate that, and hope stderr is OK.
  52   warn "$ME: closing standard output: $!\n";
  53
  54   # Don't be so arrogant as to assume that we're the first END handler
  55   # defined, and thus the last one invoked.  There may be others yet
  56   # to come.  $? will be passed on to them, and to the final _exit().
  57   #
  58   # If it isn't already an error, make it one (and if it _is_ an error,
  59   # preserve the value: it might be important).
  60   $? ||= 1;
  61 }
  62
  63 sub usage ($)
  64 {
  65   my ($exit_code) = @_;
  66   my $STREAM = ($exit_code == 0 ? *STDOUT : *STDERR);
  67   if ($exit_code != 0)
  68     {
  69       print $STREAM "Try `$ME --help' for more information.\n";
  70     }
  71   else
  72     {
  73       my @types = sort keys %valid_release_types;
  74       print $STREAM <<EOF;
  75 Usage: $ME [OPTIONS]
  76
  77 OPTIONS:
  78
  79   Generate an announcement message.
  80
  81 These options must be specified:
  82
  83    --release-type=TYPE          TYPE must be one of @types
  84    --package-name=PACKAGE_NAME
  85    --previous-version=VER
  86    --current-version=VER
  87    --gpg-key-id=ID         The GnuPG ID of the key used to sign the tarballs
  88    --url-directory=URL_DIR
  89
  90 The following are optional:
  91
  92    --news=NEWS_FILE
  93    --bootstrap-tools=TOOL_LIST  a comma-separated list of tools, e.g.,
  94                                 autoconf,automake,bison,gnulib
  95    --gnulib-snapshot-date=DATE  if gnulib is in the bootstrap tool list,
  96                                 then report this as the snapshot date.
  97                                 If not specified, use the current date/time.
  98                                 If you specify a date here, be sure it is UTC.
  99
 100    --help             display this help and exit
 101    --version          output version information and exit
 102
 103 EOF
 104     }
 105   exit $exit_code;
 106 }
 107
 108
 109 =item C<%size> = C<sizes (@file)>
 110
 111 Compute the sizes of the C<@file> and return them as a hash.  Return
 112 C<undef> if one of the computation failed.
 113
 114 =cut
 115
 116 sub sizes (@)
 117 {
 118   my (@file) = @_;
 119
 120   my $fail = 0;
 121   my %res;
 122   foreach my $f (@file)
 123     {
 124       my $cmd = "du --human $f";
 125       my $t = `$cmd`;
 126       # FIXME-someday: give a better diagnostic, a la $PROCESS_STATUS
 127       $@
 128         and (warn "$ME: command failed: `$cmd'\n"), $fail = 1;
 129       chomp $t;
 130       $t =~ s/^([\d.]+[MkK]).*/${1}B/;
 131       $res{$f} = $t;
 132     }
 133   return $fail ? undef : %res;
 134 }
 135
 136 =item C<print_locations ($title, \@url, \%size, @file)
 137
 138 Print a section C<$title> dedicated to the list of <@file>, which
 139 sizes are stored in C<%size>, and which are available from the C<@url>.
 140
 141 =cut
 142
 143 sub print_locations ($\@\%@)
 144 {
 145   my ($title, $url, $size, @file) = @_;
 146   print "Here are the $title:\n";
 147   foreach my $url (@{$url})
 148     {
 149       for my $file (@file)
 150         {
 151           print "  $url/$file";
 152           print "   (", $$size{$file}, ")"
 153             if exists $$size{$file};
 154           print "\n";
 155         }
 156     }
 157   print "\n";
 158 }
 159
 160 =item C<print_checksums (@file)
 161
 162 Print the MD5 and SHA1 signature section for each C<@file>.
 163
 164 =cut
 165
 166 sub print_checksums (@)
 167 {
 168   my (@file) = @_;
 169
 170   print "Here are the MD5 and SHA1 checksums:\n";
 171   print "\n";
 172
 173   foreach my $meth (qw (md5 sha1))
 174     {
 175       foreach my $f (@file)
 176         {
 177           open IN, '<', $f
 178             or die "$ME: $f: cannot open for reading: $!\n";
 179           binmode IN;
 180           my $dig =
 181             ($meth eq 'md5'
 182              ? Digest::MD5->new->addfile(*IN)->hexdigest
 183              : Digest::SHA1->new->addfile(*IN)->hexdigest);
 184           close IN;
 185           print "$dig  $f\n";
 186         }
 187     }
 188
 189
 190 }
 191
 192 =item C<print_news_deltas ($news_file, $prev_version, $curr_version)
 193
 194 Print the section of the NEWS file C<$news_file> addressing changes
 195 between versions C<$prev_version> and C<$curr_version>.
 196
 197 =cut
 198
 199 sub print_news_deltas ($$$)
 200 {
 201   my ($news_file, $prev_version, $curr_version) = @_;
 202
 203   print "\n$news_file\n\n";
 204
 205   # Print all lines from $news_file, starting with the first one
 206   # that mentions $curr_version up to but not including
 207   # the first occurrence of $prev_version.
 208   my $in_items;
 209
 210   my $re_prefix = qr/\* (?:Noteworthy|Major) change/;
 211
 212   open NEWS, '<', $news_file
 213     or die "$ME: $news_file: cannot open for reading: $!\n";
 214   while (defined (my $line = <NEWS>))
 215     {
 216       if ( ! $in_items)
 217         {
 218           # Match lines like these:
 219           # * Major changes in release 5.0.1:
 220           # * Noteworthy changes in release 6.6 (2006-11-22) [stable]
 221           $line =~ /^$re_prefix.*(?:[^\d.]|$)\Q$curr_version\E(?:[^\d.]|$)/o
 222             or next;
 223           $in_items = 1;
 224           print $line;
 225         }
 226       else
 227         {
 228           # This regexp must not match version numbers in NEWS items.
 229           # For example, they might well say `introduced in 4.5.5',
 230           # and we don't want that to match.
 231           $line =~ /^$re_prefix.*(?:[^\d.]|$)\Q$prev_version\E(?:[^\d.]|$)/o
 232             and last;
 233           print $line;
 234         }
 235     }
 236   close NEWS;
 237
 238   $in_items
 239     or die "$ME: $news_file: no matching lines for `$curr_version'\n";
 240 }
 241
 242 sub print_changelog_deltas ($$)
 243 {
 244   my ($package_name, $prev_version) = @_;
 245
 246   # Print new ChangeLog entries.
 247
 248   # First find all CVS-controlled ChangeLog files.
 249   use File::Find;
 250   my @changelog;
 251   find ({wanted => sub {$_ eq 'ChangeLog' && -d 'CVS'
 252                           and push @changelog, $File::Find::name}},
 253         '.');
 254
 255   # If there are no ChangeLog files, we're done.
 256   @changelog
 257     or return;
 258   my %changelog = map {$_ => 1} @changelog;
 259
 260   # Reorder the list of files so that if there are ChangeLog
 261   # files in the specified directories, they're listed first,
 262   # in this order:
 263   my @dir = qw ( . src lib m4 config doc );
 264
 265   # A typical @changelog array might look like this:
 266   # ./ChangeLog
 267   # ./po/ChangeLog
 268   # ./m4/ChangeLog
 269   # ./lib/ChangeLog
 270   # ./doc/ChangeLog
 271   # ./config/ChangeLog
 272   my @reordered;
 273   foreach my $d (@dir)
 274     {
 275       my $dot_slash = $d eq '.' ? $d : "./$d";
 276       my $target = "$dot_slash/ChangeLog";
 277       delete $changelog{$target}
 278         and push @reordered, $target;
 279     }
 280
 281   # Append any remaining ChangeLog files.
 282   push @reordered, sort keys %changelog;
 283
 284   # Remove leading `./'.
 285   @reordered = map { s!^\./!!; $_ } @reordered;
 286
 287   print "\nChangeLog entries:\n\n";
 288   # print join ("\n", @reordered), "\n";
 289
 290   $prev_version =~ s/\./_/g;
 291   my $prev_cvs_tag = "\U$package_name\E-$prev_version";
 292
 293   my $cmd = "cvs -n diff -u -r$prev_cvs_tag -rHEAD @reordered";
 294   open DIFF, '-|', $cmd
 295     or die "$ME: cannot run `$cmd': $!\n";
 296   # Print two types of lines, making minor changes:
 297   # Lines starting with `+++ ', e.g.,
 298   # +++ ChangeLog   22 Feb 2003 16:52:51 -0000      1.247
 299   # and those starting with `+'.
 300   # Don't print the others.
 301   my $prev_printed_line_empty = 1;
 302   while (defined (my $line = <DIFF>))
 303     {
 304       if ($line =~ /^\+\+\+ /)
 305         {
 306           my $separator = "*"x70 ."\n";
 307           $line =~ s///;
 308           $line =~ s/\s.*//;
 309           $prev_printed_line_empty
 310             or print "\n";
 311           print $separator, $line, $separator;
 312         }
 313       elsif ($line =~ /^\+/)
 314         {
 315           $line =~ s///;
 316           print $line;
 317           $prev_printed_line_empty = ($line =~ /^$/);
 318         }
 319     }
 320   close DIFF;
 321
 322   # The exit code should be 1.
 323   # Allow in case there are no modified ChangeLog entries.
 324   $? == 256 || $? == 128
 325     or warn "$ME: warning: `cmd' had unexpected exit code or signal ($?)\n";
 326 }
 327
 328 sub get_tool_versions ($$)
 329 {
 330   my ($bootstrap_tools, $gnulib_snapshot_timestamp) = @_;
 331   defined $bootstrap_tools
 332     or return ();
 333
 334   defined $gnulib_snapshot_timestamp
 335     or $gnulib_snapshot_timestamp = strftime '%Y-%m-%d %T UTC', gmtime;
 336
 337   my $fail;
 338   my @tool_list = split ',', $bootstrap_tools;
 339   my @tool_version_pair;
 340   foreach my $t (@tool_list)
 341     {
 342       if ($t eq 'gnulib')
 343         {
 344           push @tool_version_pair,
 345             "CVS Gnulib sources from $gnulib_snapshot_timestamp";
 346           next;
 347         }
 348       # Assume that the last "word" on the first line of
 349       # `tool --version` output is the version string.
 350       my ($first_line, undef) = split ("\n", `$t --version`);
 351       if ($first_line =~ /.* (\d[\w.-]+)$/)
 352         {
 353           $t = ucfirst $t;
 354           push @tool_version_pair, "$t $1";
 355         }
 356       else
 357         {
 358           defined $first_line
 359             and $first_line = '';
 360           warn "$ME: $t: unexpected --version output\n:$first_line";
 361           $fail = 1;
 362         }
 363     }
 364
 365   $fail
 366     and exit 1;
 367
 368   return @tool_version_pair;
 369 }
 370
 371 {
 372   # Neutralize the locale, so that, for instance, "du" does not
 373   # issue "1,2" instead of "1.2", what confuses our regexps.
 374   $ENV{LC_ALL} = "C";
 375
 376   my $release_type;
 377   my $package_name;
 378   my $prev_version;
 379   my $curr_version;
 380   my $gpg_key_id;
 381   my @url_dir_list;
 382   my @news_file;
 383   my $bootstrap_tools;
 384   my $gnulib_snapshot_timestamp;
 385
 386   GetOptions
 387     (
 388      'release-type=s'     => \$release_type,
 389      'package-name=s'     => \$package_name,
 390      'previous-version=s' => \$prev_version,
 391      'current-version=s'  => \$curr_version,
 392      'gpg-key-id=s'       => \$gpg_key_id,
 393      'url-directory=s'    => \@url_dir_list,
 394      'news=s'             => \@news_file,
 395      'bootstrap-tools=s'  => \$bootstrap_tools,
 396      'gnulib-snapshot-time-stamp=s' => \$gnulib_snapshot_timestamp,
 397
 398      help => sub { usage 0 },
 399      version => sub { print "$ME version $VERSION\n"; exit },
 400     ) or usage 1;
 401
 402   my $fail = 0;
 403   # Ensure that sure each required option is specified.
 404   $release_type
 405     or (warn "$ME: release type not specified\n"), $fail = 1;
 406   $package_name
 407     or (warn "$ME: package name not specified\n"), $fail = 1;
 408   $prev_version
 409     or (warn "$ME: previous version string not specified\n"), $fail = 1;
 410   $curr_version
 411     or (warn "$ME: current version string not specified\n"), $fail = 1;
 412   $gpg_key_id
 413     or (warn "$ME: GnuPG key ID not specified\n"), $fail = 1;
 414   @url_dir_list
 415     or (warn "$ME: URL directory name(s) not specified\n"), $fail = 1;
 416
 417   exists $valid_release_types{$release_type}
 418     or (warn "$ME: `$release_type': invalid release type\n"), $fail = 1;
 419
 420   @ARGV
 421     and (warn "$ME: too many arguments:\n", join ("\n", @ARGV), "\n"),
 422       $fail = 1;
 423   $fail
 424     and usage 1;
 425
 426   my $my_distdir = "$package_name-$curr_version";
 427   my $tgz = "$my_distdir.tar.gz";
 428   my $tbz = "$my_distdir.tar.bz2";
 429   my $lzma = "$my_distdir.tar.lzma";
 430   my $xd = "$package_name-$prev_version-$curr_version.xdelta";
 431
 432   my @tarballs = grep {-f $_} ($tgz, $tbz, $lzma);
 433   my @sizable = @tarballs;
 434   -f $xd
 435     and push @sizable, $xd;
 436   my %size = sizes (@sizable);
 437   %size
 438     or exit 1;
 439
 440   # The markup is escaped as <\# so that when this script is sent by
 441   # mail (or part of a diff), Gnus is not triggered.
 442   print <<EOF;
 443
 444 Subject: $my_distdir released
 445
 446 <\#secure method=pgpmime mode=sign>
 447
 448 FIXME: put comments here
 449
 450 EOF
 451
 452   print_locations ("compressed sources", @url_dir_list, %size, @tarballs);
 453   -f $xd
 454     and print_locations ("xdelta-style diffs", @url_dir_list, %size, $xd);
 455   my @sig_files = map { "$_.sig" } @tarballs;
 456   print_locations ("GPG detached signatures[*]", @url_dir_list, %size,
 457                    @sig_files);
 458
 459   print_checksums (@sizable);
 460
 461   print <<EOF;
 462
 463 [*] You can use either of the above signature files to verify that
 464 the corresponding file (without the .sig suffix) is intact.  First,
 465 be sure to download both the .sig file and the corresponding tarball.
 466 Then, run a command like this:
 467
 468   gpg --verify $tgz.sig
 469
 470 If that command fails because you don't have the required public key,
 471 then run this command to import it:
 472
 473   gpg --keyserver wwwkeys.pgp.net --recv-keys $gpg_key_id
 474
 475 and rerun the \`gpg --verify' command.
 476 EOF
 477
 478   my @tool_versions = get_tool_versions ($bootstrap_tools,
 479                                          $gnulib_snapshot_timestamp);
 480   @tool_versions
 481     and print "\nThis release was bootstrapped with the following tools:",
 482       join ('', map {"\n  $_"} @tool_versions), "\n";
 483
 484   print_news_deltas ($_, $prev_version, $curr_version)
 485     foreach @news_file;
 486
 487   $release_type eq 'major'
 488     or print_changelog_deltas ($package_name, $prev_version);
 489
 490   exit 0;
 491 }
 492
 493 ### Setup "GNU" style for perl-mode and cperl-mode.
 494 ## Local Variables:
 495 ## perl-indent-level: 2
 496 ## perl-continued-statement-offset: 2
 497 ## perl-continued-brace-offset: 0
 498 ## perl-brace-offset: 0
 499 ## perl-brace-imaginary-offset: 0
 500 ## perl-label-offset: -2
 501 ## cperl-indent-level: 2
 502 ## cperl-brace-offset: 0
 503 ## cperl-continued-brace-offset: 0
 504 ## cperl-label-offset: -2
 505 ## cperl-extra-newline-before-brace: t
 506 ## cperl-merge-trailing-else: nil
 507 ## cperl-continued-statement-offset: 2
 508 ## eval: (add-hook 'write-file-hooks 'time-stamp)
 509 ## time-stamp-start: "my $VERSION = '"
 510 ## time-stamp-format: "%:y-%02m-%02d %02H:%02M"
 511 ## time-stamp-time-zone: "UTC"
 512 ## time-stamp-end: "'; # UTC"
 513 ## End: