Commit | Line | Data |
---|---|---|
603f1cfd AD |
1 | #!/usr/bin/perl -w |
2 | # Generate an announcement message. | |
3 | use strict; | |
4 | ||
5 | use Getopt::Long; | |
6 | use Digest::MD5; | |
7 | use Digest::SHA1; | |
8 | ||
9 | (my $VERSION = '$Revision$ ') =~ tr/[0-9].//cd; | |
10 | (my $ME = $0) =~ s|.*/||; | |
11 | ||
12 | my %valid_release_types = map {$_ => 1} qw (alpha beta major); | |
13 | ||
14 | END | |
15 | { | |
16 | # Nobody ever checks the status of print()s. That's okay, because | |
17 | # if any do fail, we're guaranteed to get an indicator when we close() | |
18 | # the filehandle. | |
19 | # | |
20 | # Close stdout now, and if there were no errors, return happy status. | |
21 | # If stdout has already been closed by the script, though, do nothing. | |
22 | defined fileno STDOUT | |
23 | or return; | |
24 | close STDOUT | |
25 | and return; | |
26 | ||
27 | # Errors closing stdout. Indicate that, and hope stderr is OK. | |
28 | warn "$ME: closing standard output: $!\n"; | |
29 | ||
30 | # Don't be so arrogant as to assume that we're the first END handler | |
31 | # defined, and thus the last one invoked. There may be others yet | |
32 | # to come. $? will be passed on to them, and to the final _exit(). | |
33 | # | |
34 | # If it isn't already an error, make it one (and if it _is_ an error, | |
35 | # preserve the value: it might be important). | |
36 | $? ||= 1; | |
37 | } | |
38 | ||
39 | sub usage ($) | |
40 | { | |
41 | my ($exit_code) = @_; | |
42 | my $STREAM = ($exit_code == 0 ? *STDOUT : *STDERR); | |
43 | if ($exit_code != 0) | |
44 | { | |
45 | print $STREAM "Try `$ME --help' for more information.\n"; | |
46 | } | |
47 | else | |
48 | { | |
49 | my @types = sort keys %valid_release_types; | |
50 | print $STREAM <<EOF; | |
51 | Usage: $ME [OPTIONS] | |
52 | ||
53 | OPTIONS: | |
54 | ||
55 | Generate an announcement message. | |
56 | ||
57 | FIXME: describe the following | |
58 | ||
59 | --release-type=TYPE TYPE must be one of @types | |
60 | --package-name=PACKAGE_NAME | |
61 | --previous-version=VER | |
62 | --current-version=VER | |
63 | --release-archive-directory=DIR | |
64 | --url-directory=URL_DIR | |
65 | --news=NEWS_FILE optional | |
66 | ||
67 | --help display this help and exit | |
68 | --version output version information and exit | |
69 | ||
70 | EOF | |
71 | } | |
72 | exit $exit_code; | |
73 | } | |
74 | ||
75 | sub print_changelog_deltas ($$) | |
76 | { | |
77 | my ($package_name, $prev_version) = @_; | |
78 | ||
79 | # Print new ChangeLog entries. | |
80 | ||
81 | # First find all CVS-controlled ChangeLog files. | |
82 | use File::Find; | |
83 | my @changelog; | |
84 | find ({wanted => sub {$_ eq 'ChangeLog' && -d 'CVS' | |
85 | and push @changelog, $File::Find::name}}, | |
86 | '.'); | |
87 | ||
88 | # If there are no ChangeLog files, we're done. | |
89 | @changelog | |
90 | or return; | |
91 | my %changelog = map {$_ => 1} @changelog; | |
92 | ||
93 | # Reorder the list of files so that if there are ChangeLog | |
94 | # files in the specified directories, they're listed first, | |
95 | # in this order: | |
96 | my @dir = qw ( . src lib m4 config doc ); | |
97 | ||
98 | # A typical @changelog array might look like this: | |
99 | # ./ChangeLog | |
100 | # ./po/ChangeLog | |
101 | # ./m4/ChangeLog | |
102 | # ./lib/ChangeLog | |
103 | # ./doc/ChangeLog | |
104 | # ./config/ChangeLog | |
105 | my @reordered; | |
106 | foreach my $d (@dir) | |
107 | { | |
108 | my $dot_slash = $d eq '.' ? $d : "./$d"; | |
109 | my $target = "$dot_slash/ChangeLog"; | |
110 | delete $changelog{$target} | |
111 | and push @reordered, $target; | |
112 | } | |
113 | ||
114 | # Append any remaining ChangeLog files. | |
115 | push @reordered, sort keys %changelog; | |
116 | ||
117 | # Remove leading `./'. | |
118 | @reordered = map { s!^\./!!; $_ } @reordered; | |
119 | ||
120 | print "\nChangeLog entries:\n\n"; | |
121 | # print join ("\n", @reordered), "\n"; | |
122 | ||
123 | $prev_version =~ s/\./_/g; | |
124 | my $prev_cvs_tag = "\U$package_name\E-$prev_version"; | |
125 | ||
126 | my $cmd = "cvs -n diff -u -r$prev_cvs_tag -rHEAD @reordered"; | |
127 | open DIFF, '-|', $cmd | |
128 | or die "$ME: cannot run `$cmd': $!\n"; | |
129 | # Print two types of lines, making minor changes: | |
130 | # Lines starting with `+++ ', e.g., | |
131 | # +++ ChangeLog 22 Feb 2003 16:52:51 -0000 1.247 | |
132 | # and those starting with `+'. | |
133 | # Don't print the others. | |
134 | my $prev_printed_line_empty = 1; | |
135 | while (defined (my $line = <DIFF>)) | |
136 | { | |
137 | if ($line =~ /^\+\+\+ /) | |
138 | { | |
139 | my $separator = "*"x70 ."\n"; | |
140 | $line =~ s///; | |
141 | $line =~ s/\s.*//; | |
142 | $prev_printed_line_empty | |
143 | or print "\n"; | |
144 | print $separator, $line, $separator; | |
145 | } | |
146 | elsif ($line =~ /^\+/) | |
147 | { | |
148 | $line =~ s///; | |
149 | print $line; | |
150 | $prev_printed_line_empty = ($line =~ /^$/); | |
151 | } | |
152 | } | |
153 | close DIFF; | |
154 | ||
155 | # The exit code should be 1. | |
156 | # Allow in case there are no modified ChangeLog entries. | |
157 | $? == 256 || $? == 128 | |
158 | or warn "$ME: warning: `cmd' had unexpected exit code or signal ($?)\n"; | |
159 | } | |
160 | ||
161 | { | |
162 | my $release_type; | |
163 | my $package_name; | |
164 | my $prev_version; | |
165 | my $curr_version; | |
166 | my $release_archive_dir; | |
167 | my @url_dir_list; | |
168 | my $news_file; | |
169 | ||
170 | GetOptions | |
171 | ( | |
172 | 'release-type=s' => \$release_type, | |
173 | 'package-name=s' => \$package_name, | |
174 | 'previous-version=s' => \$prev_version, | |
175 | 'current-version=s' => \$curr_version, | |
176 | 'release-archive-directory=s' => \$release_archive_dir, | |
177 | 'url-directory=s@' => \@url_dir_list, | |
178 | 'news=s@' => \$news_file, | |
179 | ||
180 | help => sub { usage 0 }, | |
181 | version => sub { print "$ME version $VERSION\n"; exit }, | |
182 | ) or usage 1; | |
183 | ||
184 | my $fail = 0; | |
185 | # Ensure that sure each required option is specified. | |
186 | $release_type | |
187 | or (warn "$ME: release type not specified\n"), $fail = 1; | |
188 | $package_name | |
189 | or (warn "$ME: package name not specified\n"), $fail = 1; | |
190 | $prev_version | |
191 | or (warn "$ME: previous version string not specified\n"), $fail = 1; | |
192 | $curr_version | |
193 | or (warn "$ME: current version string not specified\n"), $fail = 1; | |
194 | $release_archive_dir | |
195 | or (warn "$ME: release directory name not specified\n"), $fail = 1; | |
196 | @url_dir_list | |
197 | or (warn "$ME: URL directory name(s) not specified\n"), $fail = 1; | |
198 | ||
199 | exists $valid_release_types{$release_type} | |
200 | or (warn "$ME: `$release_type': invalid release type\n"), $fail = 1; | |
201 | ||
202 | @ARGV | |
203 | and (warn "$ME: too many arguments\n"), $fail = 1; | |
204 | $fail | |
205 | and usage 1; | |
206 | ||
207 | my $my_distdir = "$package_name-$curr_version"; | |
208 | my $tgz = "$my_distdir.tar.gz"; | |
209 | my $tbz = "$my_distdir.tar.bz2"; | |
210 | my $xd = "$package_name-$prev_version-$curr_version.xdelta"; | |
211 | ||
212 | my %size; | |
213 | ||
214 | foreach my $f (($tgz, $tbz, $xd)) | |
215 | { | |
216 | my $cmd = "du --human $f"; | |
217 | my $t = `$cmd`; | |
218 | # FIXME-someday: give a better diagnostic, a la $PROCESS_STATUS | |
219 | $@ | |
220 | and (warn "$ME: command failed: `$cmd'\n"), $fail = 1; | |
221 | chomp $t; | |
222 | $t =~ s/^([\d.]+[MkK]).*/${1}B/; | |
223 | $size{$f} = $t; | |
224 | } | |
225 | ||
226 | $fail | |
227 | and exit 1; | |
228 | ||
89e1cc61 AD |
229 | # The markup is escaped as <\# so that when this script is sent by |
230 | # mail (or part of a diff), Gnus is not triggered. | |
603f1cfd AD |
231 | print <<EOF; |
232 | ||
233 | Subject: $my_distdir released | |
234 | ||
89e1cc61 | 235 | <\#secure method=pgpmime mode=sign> |
603f1cfd AD |
236 | |
237 | FIXME: put comments here | |
238 | ||
239 | EOF | |
240 | ||
241 | print "Here are the compressed sources:\n"; | |
242 | foreach my $url (@url_dir_list) | |
243 | { | |
244 | print " $url/$tgz ($size{$tgz})\n"; | |
245 | print " $url/$tbz ($size{$tbz})\n"; | |
246 | } | |
247 | ||
248 | print "\nAnd here are xdelta-style diffs:\n"; | |
249 | foreach my $url (@url_dir_list) | |
250 | { | |
251 | print " $url/$xd ($size{$xd})\n"; | |
252 | } | |
253 | ||
254 | print "\nHere are GPG detached signatures:\n"; | |
255 | foreach my $url (@url_dir_list) | |
256 | { | |
257 | print " $url/$tgz.asc\n"; | |
258 | print " $url/$tbz.asc\n"; | |
259 | } | |
260 | ||
261 | # FIXME: clean up upon interrupt or die | |
262 | my $tmpdir = $ENV{TMPDIR} || '/tmp'; | |
263 | my $tmp = "$tmpdir/$ME-$$"; | |
264 | unlink $tmp; # ignore failure | |
265 | ||
266 | print "\nHere are the MD5 and SHA1 signatures:\n"; | |
267 | print "\n"; | |
89e1cc61 AD |
268 | # The markup is escaped as <\# so that when this script is sent by |
269 | # mail (or part of a diff), Gnus is not triggered. | |
270 | print "<\#part type=text/plain filename=\"$tmp\" disposition=inline>\n" | |
271 | . "<\#/part>\n"; | |
603f1cfd AD |
272 | |
273 | open OUT, '>', $tmp | |
274 | or die "$ME: $tmp: cannot open for writing: $!\n"; | |
275 | ||
276 | foreach my $meth (qw (md5 sha1)) | |
277 | { | |
278 | foreach my $f (($tgz, $tbz, $xd)) | |
279 | { | |
280 | open IN, '<', $f | |
281 | or die "$ME: $f: cannot open for reading: $!\n"; | |
282 | binmode IN; | |
283 | my $dig = | |
284 | ($meth eq 'md5' | |
285 | ? Digest::MD5->new->addfile(*IN)->hexdigest | |
286 | : Digest::SHA1->new->addfile(*IN)->hexdigest); | |
287 | close IN; | |
288 | print OUT "$dig $f\n"; | |
289 | } | |
290 | } | |
291 | ||
292 | close OUT | |
293 | or die "$ME: $tmp: while writing: $!\n"; | |
294 | chmod 0400, $tmp; # ignore failure | |
295 | ||
296 | if ($news_file) | |
297 | { | |
298 | print "\nNEWS\n\n"; | |
299 | ||
300 | # Print all lines from $news_file, starting with the first one | |
301 | # that mentions $curr_version up to but not including | |
302 | # the first occurrence of $prev_version. | |
303 | my $in_items; | |
304 | open NEWS, '<', $news_file | |
305 | or die "$ME: $news_file: cannot open for reading: $!\n"; | |
306 | while (defined (my $line = <NEWS>)) | |
307 | { | |
308 | if ( ! $in_items) | |
309 | { | |
310 | # Match lines like this one: | |
311 | # * Major changes in release 5.0.1: | |
312 | # but not any other line that starts with a space, *, or -. | |
313 | $line =~ /^(\* Major changes.*|[^ *-].*)\Q$curr_version\E/o | |
314 | or next; | |
315 | $in_items = 1; | |
316 | print $line; | |
317 | } | |
318 | else | |
319 | { | |
320 | # Be careful that this regexp cannot match version numbers | |
321 | # in NEWS items -- they might well say `introduced in 4.5.5', | |
322 | # and we don't want that to match. | |
323 | $line =~ /^(\* Major changes.*|[^ *-].*)\Q$prev_version\E/o | |
324 | and last; | |
325 | print $line; | |
326 | } | |
327 | } | |
328 | close NEWS; | |
329 | ||
330 | $in_items | |
331 | or die "$ME: $news_file: no matching lines for `$curr_version'\n"; | |
332 | } | |
333 | ||
334 | $release_type eq 'major' | |
335 | or print_changelog_deltas ($package_name, $prev_version); | |
336 | ||
337 | exit 0; | |
338 | } |