announce-gen   [plain text]

#!/usr/bin/perl -w
# Generate an announcement message.

# Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software Foundation,
# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.

use strict;

use Getopt::Long;
use Digest::MD5;
use Digest::SHA1;

(my $VERSION = '$Revision: 1.6 $ ') =~ tr/[0-9].//cd;
(my $ME = $0) =~ s|.*/||;

my %valid_release_types = map {$_ => 1} qw (alpha beta major);

END
{
  # Nobody ever checks the status of print()s.  That's okay, because
  # if any do fail, we're guaranteed to get an indicator when we close()
  # the filehandle.
  #
  # Close stdout now, and if there were no errors, return happy status.
  # If stdout has already been closed by the script, though, do nothing.
  defined fileno STDOUT
    or return;
  close STDOUT
    and return;

  # Errors closing stdout.  Indicate that, and hope stderr is OK.
  warn "$ME: closing standard output: $!\n";

  # Don't be so arrogant as to assume that we're the first END handler
  # defined, and thus the last one invoked.  There may be others yet
  # to come.  $? will be passed on to them, and to the final _exit().
  #
  # If it isn't already an error, make it one (and if it _is_ an error,
  # preserve the value: it might be important).
  $? ||= 1;
}

sub usage ($)
{
  my ($exit_code) = @_;
  my $STREAM = ($exit_code == 0 ? *STDOUT : *STDERR);
  if ($exit_code != 0)
    {
      print $STREAM "Try `$ME --help' for more information.\n";
    }
  else
    {
      my @types = sort keys %valid_release_types;
      print $STREAM <<EOF;
Usage: $ME [OPTIONS]

OPTIONS:

  Generate an announcement message.

  FIXME: describe the following

   --release-type=TYPE          TYPE must be one of @types
   --package-name=PACKAGE_NAME
   --previous-version=VER
   --current-version=VER
   --gpg-key-id=ID         The GnuPG ID of the key used to sign the tarballs
   --release-archive-directory=DIR
   --url-directory=URL_DIR
   --news=NEWS_FILE             optional

   --help             display this help and exit
   --version          output version information and exit

EOF
    }
  exit $exit_code;
}


=item C<%size> = C<sizes (@file)>

Compute the sizes of the C<@file> and return them as a hash.  Return
C<undef> if one of the computation failed.

=cut

sub sizes (@)
{
  my (@file) = @_;

  my $fail = 0;
  my %res;
  foreach my $f (@file)
    {
      my $cmd = "du --human $f";
      my $t = `$cmd`;
      # FIXME-someday: give a better diagnostic, a la $PROCESS_STATUS
      $@
	and (warn "$ME: command failed: `$cmd'\n"), $fail = 1;
      chomp $t;
      $t =~ s/^([\d.]+[MkK]).*/${1}B/;
      $res{$f} = $t;
    }
  return $fail ? undef : %res;
}

=item C<print_locations ($title, \@url, \%size, @file)

Print a section C<$title> dedicated to the list of <@file>, which
sizes are stored in C<%size>, and which are available from the C<@url>.

=cut

sub print_locations ($\@\%@)
{
  my ($title, $url, $size, @file) = @_;
  print "Here are the $title:\n";
  foreach my $url (@{$url})
    {
      for my $file (@file)
	{
	  print "  $url/$file";
	  print "   (", $$size{$file}, ")"
	    if exists $$size{$file};
	  print "\n";
	}
    }
  print "\n";
}

=item C<print_checksums (@file)

Print the MD5 and SHA1 signature section for each C<@file>.

=cut

sub print_checksums (@)
{
  my (@file) = @_;

  print "Here are the MD5 and SHA1 checksums:\n";
  print "\n";

  foreach my $meth (qw (md5 sha1))
    {
      foreach my $f (@file)
	{
	  open IN, '<', $f
	    or die "$ME: $f: cannot open for reading: $!\n";
	  binmode IN;
	  my $dig =
	    ($meth eq 'md5'
	     ? Digest::MD5->new->addfile(*IN)->hexdigest
	     : Digest::SHA1->new->addfile(*IN)->hexdigest);
	  close IN;
	  print "$dig  $f\n";
	}
    }


}

=item C<print_news_deltas ($news_file, $prev_version, $curr_version)

Print the section of the NEWS file C<$news_file> addressing changes
between versions C<$prev_version> and C<$curr_version>.

=cut

sub print_news_deltas ($$$)
{
  my ($news_file, $prev_version, $curr_version) = @_;

  print "\n$news_file\n\n";

  # Print all lines from $news_file, starting with the first one
  # that mentions $curr_version up to but not including
  # the first occurrence of $prev_version.
  my $in_items;

  open NEWS, '<', $news_file
    or die "$ME: $news_file: cannot open for reading: $!\n";
  while (defined (my $line = <NEWS>))
    {
      if ( ! $in_items)
	{
	  # Match lines like this one:
	  # * Major changes in release 5.0.1:
	  # but not any other line that starts with a space, *, or -.
	  $line =~ /^(\* Major changes.*|[^ *-].*)\Q$curr_version\E/o
	    or next;
	  $in_items = 1;
	  print $line;
	}
      else
	{
	  # Be careful that this regexp cannot match version numbers
	  # in NEWS items -- they might well say `introduced in 4.5.5',
	  # and we don't want that to match.
	  $line =~ /^(\* Major changes.*|[^ *-].*)\Q$prev_version\E/o
	    and last;
	  print $line;
	}
    }
  close NEWS;

  $in_items
    or die "$ME: $news_file: no matching lines for `$curr_version'\n";
}

sub print_changelog_deltas ($$)
{
  my ($package_name, $prev_version) = @_;

  # Print new ChangeLog entries.

  # First find all CVS-controlled ChangeLog files.
  use File::Find;
  my @changelog;
  find ({wanted => sub {$_ eq 'ChangeLog' && -d 'CVS'
			  and push @changelog, $File::Find::name}},
	'.');

  # If there are no ChangeLog files, we're done.
  @changelog
    or return;
  my %changelog = map {$_ => 1} @changelog;

  # Reorder the list of files so that if there are ChangeLog
  # files in the specified directories, they're listed first,
  # in this order:
  my @dir = qw ( . src lib m4 config doc );

  # A typical @changelog array might look like this:
  # ./ChangeLog
  # ./po/ChangeLog
  # ./m4/ChangeLog
  # ./lib/ChangeLog
  # ./doc/ChangeLog
  # ./config/ChangeLog
  my @reordered;
  foreach my $d (@dir)
    {
      my $dot_slash = $d eq '.' ? $d : "./$d";
      my $target = "$dot_slash/ChangeLog";
      delete $changelog{$target}
	and push @reordered, $target;
    }

  # Append any remaining ChangeLog files.
  push @reordered, sort keys %changelog;

  # Remove leading `./'.
  @reordered = map { s!^\./!!; $_ } @reordered;

  print "\nChangeLog entries:\n\n";
  # print join ("\n", @reordered), "\n";

  $prev_version =~ s/\./_/g;
  my $prev_cvs_tag = "\U$package_name\E-$prev_version";

  my $cmd = "cvs -n diff -u -r$prev_cvs_tag -rHEAD @reordered";
  open DIFF, '-|', $cmd
    or die "$ME: cannot run `$cmd': $!\n";
  # Print two types of lines, making minor changes:
  # Lines starting with `+++ ', e.g.,
  # +++ ChangeLog   22 Feb 2003 16:52:51 -0000      1.247
  # and those starting with `+'.
  # Don't print the others.
  my $prev_printed_line_empty = 1;
  while (defined (my $line = <DIFF>))
    {
      if ($line =~ /^\+\+\+ /)
	{
	  my $separator = "*"x70 ."\n";
	  $line =~ s///;
	  $line =~ s/\s.*//;
	  $prev_printed_line_empty
	    or print "\n";
	  print $separator, $line, $separator;
	}
      elsif ($line =~ /^\+/)
	{
	  $line =~ s///;
	  print $line;
	  $prev_printed_line_empty = ($line =~ /^$/);
	}
    }
  close DIFF;

  # The exit code should be 1.
  # Allow in case there are no modified ChangeLog entries.
  $? == 256 || $? == 128
    or warn "$ME: warning: `cmd' had unexpected exit code or signal ($?)\n";
}

{
  # Neutralize the locale, so that, for instance, "du" does not
  # issue "1,2" instead of "1.2", what confuses our regexps.
  $ENV{LC_ALL} = "C";

  my $release_type;
  my $package_name;
  my $prev_version;
  my $curr_version;
  my $release_archive_dir;
  my $gpg_key_id;
  my @url_dir_list;
  my @news_file;

  GetOptions
    (
     'release-type=s'     => \$release_type,
     'package-name=s'     => \$package_name,
     'previous-version=s' => \$prev_version,
     'current-version=s'  => \$curr_version,
     'gpg-key-id=s'       => \$gpg_key_id,
     'release-archive-directory=s' => \$release_archive_dir,
     'url-directory=s'    => \@url_dir_list,
     'news=s'             => \@news_file,

     help => sub { usage 0 },
     version => sub { print "$ME version $VERSION\n"; exit },
    ) or usage 1;

  my $fail = 0;
  # Ensure that sure each required option is specified.
  $release_type
    or (warn "$ME: release type not specified\n"), $fail = 1;
  $package_name
    or (warn "$ME: package name not specified\n"), $fail = 1;
  $prev_version
    or (warn "$ME: previous version string not specified\n"), $fail = 1;
  $curr_version
    or (warn "$ME: current version string not specified\n"), $fail = 1;
  $release_archive_dir
    or (warn "$ME: release directory name not specified\n"), $fail = 1;
  @url_dir_list
    or (warn "$ME: URL directory name(s) not specified\n"), $fail = 1;

  exists $valid_release_types{$release_type}
    or (warn "$ME: `$release_type': invalid release type\n"), $fail = 1;

  @ARGV
    and (warn "$ME: too many arguments\n"), $fail = 1;
  $fail
    and usage 1;

  my $my_distdir = "$package_name-$curr_version";
  my $tgz = "$my_distdir.tar.gz";
  my $tbz = "$my_distdir.tar.bz2";
  my $xd = "$package_name-$prev_version-$curr_version.xdelta";

  my %size = sizes ($tgz, $tbz, $xd);
  %size
    or exit 1;

  # The markup is escaped as <\# so that when this script is sent by
  # mail (or part of a diff), Gnus is not triggered.
  print <<EOF;

Subject: $my_distdir released

<\#secure method=pgpmime mode=sign>

FIXME: put comments here

EOF

  print_locations ("compressed sources", @url_dir_list, %size,
		   $tgz, $tbz);
  print_locations ("xdelta-style diffs", @url_dir_list, %size,
		   $xd);
  print_locations ("GPG detached signatures[*]", @url_dir_list, %size,
		   "$tgz.sig", "$tbz.sig");

  print_checksums ($tgz, $tbz, $xd);

  print <<EOF;

[*] You can use either of the above signature files to verify that
the corresponding file (without the .sig suffix) is intact.  First,
be sure to download both the .sig file and the corresponding tarball.
Then, run a command like this:

  gpg --verify $tgz.sig

If that command fails because you don't have the required public key,
then run this command to import it:

  gpg --keyserver wwwkeys.pgp.net --recv-keys $gpg_key_id

and rerun the \`gpg --verify' command.
EOF

  print_news_deltas ($_, $prev_version, $curr_version)
    foreach @news_file;

  $release_type eq 'major'
    or print_changelog_deltas ($package_name, $prev_version);

  exit 0;
}



### Setup "GNU" style for perl-mode and cperl-mode.
## Local Variables:
## perl-indent-level: 2
## perl-continued-statement-offset: 2
## perl-continued-brace-offset: 0
## perl-brace-offset: 0
## perl-brace-imaginary-offset: 0
## perl-label-offset: -2
## cperl-indent-level: 2
## cperl-brace-offset: 0
## cperl-continued-brace-offset: 0
## cperl-label-offset: -2
## cperl-extra-newline-before-brace: t
## cperl-merge-trailing-else: nil
## cperl-continued-statement-offset: 2
## End: