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 20use strict; 21 22use Getopt::Long; 23use Digest::MD5; 24use Digest::SHA1; 25 26(my $VERSION = '$Revision: 1.6 $ ') =~ tr/[0-9].//cd; 27(my $ME = $0) =~ s|.*/||; 28 29my %valid_release_types = map {$_ => 1} qw (alpha beta major); 30 31END 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 56sub 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; 68Usage: $ME [OPTIONS] 69 70OPTIONS: 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 88EOF 89 } 90 exit $exit_code; 91} 92 93 94=item C<%size> = C<sizes (@file)> 95 96Compute the sizes of the C<@file> and return them as a hash. Return 97C<undef> if one of the computation failed. 98 99=cut 100 101sub 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 123Print a section C<$title> dedicated to the list of <@file>, which 124sizes are stored in C<%size>, and which are available from the C<@url>. 125 126=cut 127 128sub 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 147Print the MD5 and SHA1 signature section for each C<@file>. 148 149=cut 150 151sub 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 179Print the section of the NEWS file C<$news_file> addressing changes 180between versions C<$prev_version> and C<$curr_version>. 181 182=cut 183 184sub 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 225sub 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 376Subject: $my_distdir released 377 378<\#secure method=pgpmime mode=sign> 379 380FIXME: put comments here 381 382EOF 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 396the corresponding file (without the .sig suffix) is intact. First, 397be sure to download both the .sig file and the corresponding tarball. 398Then, run a command like this: 399 400 gpg --verify $tgz.sig 401 402If that command fails because you don't have the required public key, 403then run this command to import it: 404 405 gpg --keyserver wwwkeys.pgp.net --recv-keys $gpg_key_id 406 407and rerun the \`gpg --verify' command. 408EOF 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: 437