build-aux/announce-gen

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