announce-gen

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