config/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 3 of the License, or
   9 # (at your option) 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, see <http://www.gnu.org/licenses/>.
  18
  19 use strict;
  20
  21 use Getopt::Long;
  22 use Digest::MD5;
  23 use Digest::SHA1;
  24
  25 (my $VERSION = '$Revision$ ') =~ tr/[0-9].//cd;
  26 (my $ME = $0) =~ s|.*/||;
  27
  28 my %valid_release_types = map {$_ => 1} qw (alpha beta major);
  29
  30 END
  31 {
  32   # Nobody ever checks the status of print()s.  That's okay, because
  33   # if any do fail, we're guaranteed to get an indicator when we close()
  34   # the filehandle.
  35   #
  36   # Close stdout now, and if there were no errors, return happy status.
  37   # If stdout has already been closed by the script, though, do nothing.
  38   defined fileno STDOUT
  39     or return;
  40   close STDOUT
  41     and return;
  42
  43   # Errors closing stdout.  Indicate that, and hope stderr is OK.
  44   warn "$ME: closing standard output: $!\n";
  45
  46   # Don't be so arrogant as to assume that we're the first END handler
  47   # defined, and thus the last one invoked.  There may be others yet
  48   # to come.  $? will be passed on to them, and to the final _exit().
  49   #
  50   # If it isn't already an error, make it one (and if it _is_ an error,
  51   # preserve the value: it might be important).
  52   $? ||= 1;
  53 }
  54
  55 sub usage ($)
  56 {
  57   my ($exit_code) = @_;
  58   my $STREAM = ($exit_code == 0 ? *STDOUT : *STDERR);
  59   if ($exit_code != 0)
  60     {
  61       print $STREAM "Try `$ME --help' for more information.\n";
  62     }
  63   else
  64     {
  65       my @types = sort keys %valid_release_types;
  66       print $STREAM <<EOF;
  67 Usage: $ME [OPTIONS]
  68
  69 OPTIONS:
  70
  71   Generate an announcement message.
  72
  73   FIXME: describe the following
  74
  75    --release-type=TYPE          TYPE must be one of @types
  76    --package-name=PACKAGE_NAME
  77    --previous-version=VER
  78    --current-version=VER
  79    --gpg-key-id=ID         The GnuPG ID of the key used to sign the tarballs
  80    --release-archive-directory=DIR
  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   open NEWS, '<', $news_file
 195     or die "$ME: $news_file: cannot open for reading: $!\n";
 196   while (defined (my $line = <NEWS>))
 197     {
 198       if ( ! $in_items)
 199         {
 200           # Match lines like this one:
 201           # * Major changes in release 5.0.1:
 202           # but not any other line that starts with a space, *, or -.
 203           $line =~ /^(\* Major changes.*|[^ *-].*)\Q$curr_version\E/o
 204             or next;
 205           $in_items = 1;
 206           print $line;
 207         }
 208       else
 209         {
 210           # Be careful that this regexp cannot match version numbers
 211           # in NEWS items -- they might well say `introduced in 4.5.5',
 212           # and we don't want that to match.
 213           $line =~ /^(\* Major changes.*|[^ *-].*)\Q$prev_version\E/o
 214             and last;
 215           print $line;
 216         }
 217     }
 218   close NEWS;
 219
 220   $in_items
 221     or die "$ME: $news_file: no matching lines for `$curr_version'\n";
 222 }
 223
 224 sub print_changelog_deltas ($$)
 225 {
 226   my ($package_name, $prev_version) = @_;
 227
 228   # Print new ChangeLog entries.
 229
 230   # First find all CVS-controlled ChangeLog files.
 231   use File::Find;
 232   my @changelog;
 233   find ({wanted => sub {$_ eq 'ChangeLog' && -d 'CVS'
 234                           and push @changelog, $File::Find::name}},
 235         '.');
 236
 237   # If there are no ChangeLog files, we're done.
 238   @changelog
 239     or return;
 240   my %changelog = map {$_ => 1} @changelog;
 241
 242   # Reorder the list of files so that if there are ChangeLog
 243   # files in the specified directories, they're listed first,
 244   # in this order:
 245   my @dir = qw ( . src lib m4 config doc );
 246
 247   # A typical @changelog array might look like this:
 248   # ./ChangeLog
 249   # ./po/ChangeLog
 250   # ./m4/ChangeLog
 251   # ./lib/ChangeLog
 252   # ./doc/ChangeLog
 253   # ./config/ChangeLog
 254   my @reordered;
 255   foreach my $d (@dir)
 256     {
 257       my $dot_slash = $d eq '.' ? $d : "./$d";
 258       my $target = "$dot_slash/ChangeLog";
 259       delete $changelog{$target}
 260         and push @reordered, $target;
 261     }
 262
 263   # Append any remaining ChangeLog files.
 264   push @reordered, sort keys %changelog;
 265
 266   # Remove leading `./'.
 267   @reordered = map { s!^\./!!; $_ } @reordered;
 268
 269   print "\nChangeLog entries:\n\n";
 270   # print join ("\n", @reordered), "\n";
 271
 272   $prev_version =~ s/\./_/g;
 273   my $prev_cvs_tag = "\U$package_name\E-$prev_version";
 274
 275   my $cmd = "cvs -n diff -u -r$prev_cvs_tag -rHEAD @reordered";
 276   open DIFF, '-|', $cmd
 277     or die "$ME: cannot run `$cmd': $!\n";
 278   # Print two types of lines, making minor changes:
 279   # Lines starting with `+++ ', e.g.,
 280   # +++ ChangeLog   22 Feb 2003 16:52:51 -0000      1.247
 281   # and those starting with `+'.
 282   # Don't print the others.
 283   my $prev_printed_line_empty = 1;
 284   while (defined (my $line = <DIFF>))
 285     {
 286       if ($line =~ /^\+\+\+ /)
 287         {
 288           my $separator = "*"x70 ."\n";
 289           $line =~ s///;
 290           $line =~ s/\s.*//;
 291           $prev_printed_line_empty
 292             or print "\n";
 293           print $separator, $line, $separator;
 294         }
 295       elsif ($line =~ /^\+/)
 296         {
 297           $line =~ s///;
 298           print $line;
 299           $prev_printed_line_empty = ($line =~ /^$/);
 300         }
 301     }
 302   close DIFF;
 303
 304   # The exit code should be 1.
 305   # Allow in case there are no modified ChangeLog entries.
 306   $? == 256 || $? == 128
 307     or warn "$ME: warning: `cmd' had unexpected exit code or signal ($?)\n";
 308 }
 309
 310 {
 311   # Neutralize the locale, so that, for instance, "du" does not
 312   # issue "1,2" instead of "1.2", what confuses our regexps.
 313   $ENV{LC_ALL} = "C";
 314
 315   my $release_type;
 316   my $package_name;
 317   my $prev_version;
 318   my $curr_version;
 319   my $release_archive_dir;
 320   my $gpg_key_id;
 321   my @url_dir_list;
 322   my @news_file;
 323
 324   GetOptions
 325     (
 326      'release-type=s'     => \$release_type,
 327      'package-name=s'     => \$package_name,
 328      'previous-version=s' => \$prev_version,
 329      'current-version=s'  => \$curr_version,
 330      'gpg-key-id=s'       => \$gpg_key_id,
 331      'release-archive-directory=s' => \$release_archive_dir,
 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   $release_archive_dir
 350     or (warn "$ME: release directory name 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: