announce-gen

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