announce-gen

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