add support for "last"
[homepage.git] / blog / posts / 2008 / 01 / bts_followup / bts
1 #! /usr/bin/perl -w
2
3 # bts: This program provides a convenient interface to the Debian
4 # Bug Tracking System.
5 #
6 # Written by Joey Hess <joeyh@debian.org>
7 # Modifications by Julian Gilbey <jdg@debian.org>
8 # Modifications by Josh Triplett <josh@freedesktop.org>
9 # Copyright 2001-2003 Joey Hess <joeyh@debian.org>
10 # Modifications Copyright 2001-2003 Julian Gilbey <jdg@debian.org>
11 # Modifications Copyright 2007 Josh Triplett <josh@freedesktop.org>
12 #
13 # This program is free software; you can redistribute it and/or modify
14 # it under the terms of the GNU General Public License as published by
15 # the Free Software Foundation; either version 2 of the License, or
16 # (at your option) any later version.
17 #
18 # This program is distributed in the hope that it will be useful,
19 # but WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
21 # GNU General Public License for more details.
22 #
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
26
27 =head1 NAME
28
29 bts - developers' command line interface to the BTS
30
31 =cut
32
33 use 5.006_000;
34 use strict;
35 use File::Basename;
36 use File::Copy;
37 use File::Path;
38 use File::Spec;
39 use File::Temp qw/tempfile/;
40 use Net::SMTP;
41 use Cwd;
42 use IO::Handle;
43 use lib '/usr/share/devscripts';
44 use Devscripts::DB_File_Lock;
45 use Fcntl qw(O_RDWR O_RDONLY O_CREAT F_SETFD);
46 use Getopt::Long;
47 use Encode;
48
49 # Funny UTF-8 warning messages from HTML::Parse should be ignorable (#292671)
50 $SIG{'__WARN__'} = sub { warn $_[0] unless $_[0] =~ /^Parsing of undecoded UTF-8 will give garbage when decoding entities/; };
51
52 my $it = undef;
53 my $lwp_broken = undef;
54 my $ua;
55
56 sub have_lwp() {
57     return ($lwp_broken ? 0 : 1) if defined $lwp_broken;
58     eval {
59         require LWP;
60         require LWP::UserAgent;
61         require HTTP::Status;
62         require HTTP::Date;
63     };
64
65     if ($@) {
66         if ($@ =~ m%^Can\'t locate LWP%) {
67             $lwp_broken="the libwww-perl package is not installed";
68         } else {
69             $lwp_broken="couldn't load LWP::UserAgent: $@";
70         }
71     }
72     else { $lwp_broken=''; }
73     return $lwp_broken ? 0 : 1;
74 }
75
76 my $soap_broken;
77 sub have_soap {
78      return ($soap_broken ? 0 : 1) if defined $soap_broken;
79      eval {
80           require SOAP::Lite;
81      };
82
83      if ($@) {
84           if ($@ =~ m%^Can't locate SOAP/%) {
85                $soap_broken="the libsoap-lite-perl package is not installed";
86           } else {
87                $soap_broken="couldn't load SOAP::Lite: $@";
88           }
89      }
90      else {
91           $soap_broken = 0;
92      }
93      return ($soap_broken ? 0 : 1);
94 }
95
96 # Constants
97 sub MIRROR_ERROR      { 0; }
98 sub MIRROR_DOWNLOADED { 1; }
99 sub MIRROR_UP_TO_DATE { 2; }
100 my $NONPRINT = "\\x00-\\x1F\\x7F-\\xFF"; # we need this later for MIME stuff
101
102 my $progname = basename($0);
103 my $modified_conf_msg;
104 my $debug = (exists $ENV{'DEBUG'} and $ENV{'DEBUG'}) ? 1 : 0;
105
106 # Program version handling
107 # The BTS changed its format :/  Pages downloaded using old versions
108 # of bts won't look very good, so we force updating if the last cached
109 # version was downloaded by a devscripts version less than
110 # $new_cache_format_version
111 my $version = '2.10.13';
112 $version = '2.9.6' if $version =~ /\#/;  # for testing unconfigured version
113 my $new_cache_format_version = '2.9.6';
114
115 # The official list is mirrored
116 # bugs-mirror.debian.org:/org/bugs.debian.org/etc/config
117 # in the variable @gTags; we copy it verbatim here.
118 our (@gTags, @valid_tags, %valid_tags);
119 @gTags = ( "patch", "wontfix", "moreinfo", "unreproducible", "fixed",
120            "potato", "woody", "sid", "help", "security", "upstream",
121            "pending", "sarge", "sarge-ignore", "experimental", "d-i", 
122            "confirmed", "ipv6", "lfs", "fixed-in-experimental",
123            "fixed-upstream", "l10n", "etch", "etch-ignore",
124            "lenny", "lenny-ignore",
125          );
126
127 *valid_tags = \@gTags;
128 %valid_tags = map { $_ => 1 } @valid_tags;
129 my @valid_severities=qw(wishlist minor normal important
130                         serious grave critical);
131
132 my @no_cc_commands=qw(subscribe unsubscribe reportspam
133                         spamreport usertags);
134
135 my $browser;  # Will set if necessary
136 my $btsserver='bugs.debian.org';
137 my $btsurl='http://bugs.debian.org/';
138 my $btscgiurl='http://bugs.debian.org/cgi-bin/';
139 my $btscgipkgurl='http://bugs.debian.org/cgi-bin/pkgreport.cgi';
140 my $btscgibugurl='http://bugs.debian.org/cgi-bin/bugreport.cgi';
141 my $btscgispamurl='http://bugs.debian.org/cgi-bin/bugspam.cgi';
142 my $btsemail='control@bugs.debian.org';
143 my $soapurl='Debbugs/SOAP/1';
144 my $soapproxyurl='http://bugs.debian.org/cgi-bin/soap.cgi';
145
146 my $cachedir=$ENV{'HOME'}."/.devscripts_cache/bts/";
147 my $timestampdb=$cachedir."bts_timestamps.db";
148 my $prunestamp=$cachedir."bts_prune.timestamp";
149
150 my %timestamp;
151 END {
152     # This works even if we haven't tied it
153     untie %timestamp;
154 }
155
156 my %clonedbugs = ();
157 my %ccbugs = ();
158
159 =head1 SYNOPSIS
160
161 B<bts> [options] command [args] [#comment] [.|, command [args] [#comment]] ...
162
163 =head1 DESCRIPTION
164
165 This is a command line interface to the bug tracking system, intended mainly
166 for use by developers. It lets the BTS be manipulated using simple commands
167 that can be run at the prompt or in a script, does various sanity checks on
168 the input, and constructs and sends a mail to the BTS control address for
169 you.
170
171 In general, the command line interface is the same as what you would write
172 in a mail to control@bugs.debian.org, just prefixed with "bts". For
173 example:
174
175  % bts severity 69042 normal
176  % bts merge 69042 43233
177  % bts retitle 69042 blah blah
178
179 A few additional commands have been added for your convenience, and this
180 program is less strict about what constitutes a valid bug number. For example,
181 "severity Bug#85942 normal" is understood, as is "severity #85942 normal".
182 (Of course, your shell may regard "#" as a comment character though, so you
183 may need to quote it!)
184
185 Also, for your convenience, this program allows you to abbreviate commands
186 to the shortest unique substring (similar to how cvs lets you abbreviate
187 commands). So it understands things like "bts cl 85942".
188
189 It is also possible to include a comment in the mail sent to the BTS. If
190 your shell does not strip out the comment in a command like
191 "bts severity 30321 normal #inflated severity", then this program is smart
192 enough to figure out where the comment is, and include it in the email.
193 Note that most shells do strip out such comments before they get to the
194 program, unless the comment is quoted.  (Something like "bts
195 severity #85942 normal" will not be treated as a comment!)
196
197 In most cases, adding a comment will cause the generated mail to be CCed
198 to the bug report, in addition to control@bugs.debian.org.
199
200 You can specify multiple commands by separating them with a single dot,
201 rather like B<update-rc.d>; a single comma may also be used; all the
202 commands will then be sent in a single mail. For example (quoting where
203 necessary so that B<bts> sees the comment):
204
205  % bts severity 95672 normal , merge 95672 95673 \#they are the same!
206
207 The abbreviation "it" may be used to refer to the last mentioned bug
208 number, so you could write:
209
210  % bts severity 95672 wishlist, retitle it "bts: please add a --foo option"
211
212 Please use this program responsibly, and do take our users into
213 consideration.
214
215 =head1 OPTIONS
216
217 B<bts> examines the B<devscripts> configuration files as described
218 below.  Command line options override the configuration file settings,
219 though.
220
221 =over 4
222
223 =item -o, --offline
224
225 Make bts use cached bugs for the 'show' and 'bugs' commands, if a cache
226 is available for the requested data. See the cache command, below for
227 information on setting up a cache.
228
229 =item --online, --no-offline
230
231 Opposite of --offline; overrides any configuration file directive to work
232 offline.
233
234 =item -n, --no-action
235
236 Do not send emails but print them to standard output.
237
238 =item --cache, --no-cache
239
240 Should we attempt to cache new versions of BTS pages when
241 performing show/bugs commands?  Default is to cache.
242
243 =item --cache-mode={min|mbox|full}
244
245 When running a B<bts cache> command, should we only mirror the basic
246 bug (min), or should we also mirror the mbox version (mbox), or should
247 we mirror the whole thing, including the mbox and the boring
248 attachments to the BTS bug pages and the acknowledgement emails (full)?
249 Default is min.
250
251 =item --cache-delay=seconds
252
253 Time in seconds to delay between each download, to avoid hammering the BTS
254 web server. Default is 5 seconds.
255
256 =item --mbox
257
258 Open a mail reader to read the mbox corresponding to a given bug number
259 for show and bugs commands.
260
261 =item --mailreader=READER
262
263 Specify the command to read the mbox.  Must contain a "%s" string
264 (unquoted!), which will be replaced by the name of the mbox file.  The
265 command will be split on white space and will not be passed to a
266 shell.  Default is 'mutt -f %s'.  (Also, %% will be substituted by a
267 single % if this is needed.)
268
269 =item --mailcomposer=COMPOSER
270
271 Specify the command to compose mail from a template. Must contain a "%s"
272 as per --mailreader, however it will be replaced by a mail template
273 containing some headers and body, similar to what is expected by mutt
274 when invoked with -H. Default is, no wonder, 'mutt -H %s'.
275
276 =item --cc-addr=CC_EMAIL_ADDRESS
277
278 Send carbon copies to a list of users. CC_EMAIL_ADDRESS should be a 
279 comma-separated list of emails.
280
281 =item --sendmail=SENDMAILCMD
282
283 Specify the sendmail command.  The command will be split on white
284 space and will not be passed to a shell.  Default is
285 '/usr/sbin/sendmail'.  The -t option will be automatically added if
286 the command is /usr/sbin/sendmail or /usr/sbin/exim*.  For other
287 mailers, if they require a -t option, this must be included in the
288 SENDMAILCMD, for example: --sendmail="/usr/sbin/mymailer -t"
289
290 =item --smtp-host=SMTPHOST
291
292 Specify an SMTP host.  If given, bts will send mail by talking directly to
293 this SMTP host rather than by invoking a sendmail command.
294
295 Note that when sending directly via an SMTP host, specifying addresses in
296 --cc-addr that the SMTP host will not relay will cause the SMTP host to reject
297 the entire mail.
298
299 =item -f, --force-refresh
300
301 Download a bug report again, even if it does not appear to have
302 changed since the last cache command.  Useful if a --cache-mode=full is
303 requested for the first time (otherwise unchanged bug reports will not
304 be downloaded again, even if the boring bits have not been
305 downloaded).
306
307 =item --no-force-refresh
308
309 Suppress any configuration file --force-refresh option.
310
311 =item --only-new
312
313 Download only new bugs when caching. Do not check for updates in
314 bugs we already have.
315
316 =item --include-resolved
317
318 When caching bug reports, include those that are marked as resolved.  This
319 is the default behaviour.
320
321 =item --no-include-resolved
322
323 Reverse the behaviour of the previous option.  That is, do not cache bugs
324 that are marked as resolved.
325
326 =item -q, --quiet
327
328 When running bts cache, only display information about newly cached
329 pages, not messages saying already cached.  If this option is
330 specified twice, only output error messages (to stderr).
331
332 =item --no-conf, --noconf
333
334 Do not read any configuration files.  This can only be used as the
335 first option given on the command-line.
336
337 =back
338
339 =cut
340
341 # Start by setting default values
342
343 my $offlinemode=0;
344 my $caching=1;
345 my $cachemode='min';
346 my $refreshmode=0;
347 my $updatemode=0;
348 my $mailreader='mutt -f %s';
349 my $mailcomposer='mutt -H %s';
350 my $sendmailcmd='/usr/sbin/sendmail';
351 my $smtphost='';
352 my $noaction=0;
353 # regexp for mailers which require a -t option
354 my $sendmail_t='^/usr/sbin/sendmail$|^/usr/sbin/exim';
355 my $includeresolved=1;
356
357 # Next, read read configuration files and then command line
358 # The next stuff is boilerplate
359
360 if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) {
361     $modified_conf_msg = "  (no configuration files read)";
362     shift;
363 } else {
364     my @config_files = ('/etc/devscripts.conf', '~/.devscripts');
365     my %config_vars = (
366                        'BTS_OFFLINE' => 'no',
367                        'BTS_CACHE' => 'yes',
368                        'BTS_CACHE_MODE' => 'min',
369                        'BTS_FORCE_REFRESH' => 'no',
370                        'BTS_ONLY_NEW' => 'no',
371                        'BTS_MAIL_READER' => 'mutt -f %s',
372                        'BTS_MAIL_COMPOSER' => 'mutt -H %s',
373                        'BTS_SENDMAIL_COMMAND' => '/usr/sbin/sendmail',
374                        'BTS_INCLUDE_RESOLVED' => 'yes',
375                        'BTS_SMTP_HOST' => '',
376                        );
377     my %config_default = %config_vars;
378     
379     my $shell_cmd;
380     # Set defaults
381     foreach my $var (keys %config_vars) {
382         $shell_cmd .= qq[$var="$config_vars{$var}";\n];
383     }
384     $shell_cmd .= 'for file in ' . join(" ",@config_files) . "; do\n";
385     $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n";
386     # Read back values
387     foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" }
388     my $shell_out = `/bin/bash -c '$shell_cmd'`;
389     @config_vars{keys %config_vars} = split /\n/, $shell_out, -1;
390
391     # Check validity
392     $config_vars{'BTS_OFFLINE'} =~ /^(yes|no)$/
393         or $config_vars{'BTS_OFFLINE'}='no';
394     $config_vars{'BTS_CACHE'} =~ /^(yes|no)$/
395         or $config_vars{'BTS_CACHE'}='yes';
396     $config_vars{'BTS_CACHE_MODE'} =~ /^(min|mbox|full)$/
397         or $config_vars{'BTS_CACHE_MODE'}='min';
398     $config_vars{'BTS_FORCE_REFRESH'} =~ /^(yes|no)$/
399         or $config_vars{'BTS_FORCE_REFRESH'}='no';
400     $config_vars{'BTS_ONLY_NEW'} =~ /^(yes|no)$/
401         or $config_vars{'BTS_ONLY_NEW'}='no';
402     $config_vars{'BTS_MAIL_READER'} =~ /\%s/
403         or $config_vars{'BTS_MAIL_READER'}='mutt -f %s';
404     $config_vars{'BTS_SENDMAIL_COMMAND'} =~ /./
405         or $config_vars{'BTS_SENDMAIL_COMMAND'}='/usr/sbin/sendmail';
406     $config_vars{'BTS_INCLUDE_RESOLVED'} =~ /^(yes|no)$/
407         or $config_vars{'BTS_INCLUDE_RESOLVED'} = 'yes';
408
409     if (!length $config_vars{'BTS_SMTP_HOST'}
410         and $config_vars{'BTS_SENDMAIL_COMMAND'} ne '/usr/sbin/sendmail') {
411         my $cmd = (split ' ', $config_vars{'BTS_SENDMAIL_COMMAND'})[0];
412         unless ($cmd =~ /^[A-Za-z0-9_\-\+\.\/]*$/) {
413             warn "BTS_SENDMAIL_COMMAND contained funny characters: $cmd\nReverting to default value /usr/sbin/sendmail\n";
414             $config_vars{'BTS_SENDMAIL_COMMAND'}='/usr/sbin/sendmail';
415         } elsif (system("command -v $cmd >/dev/null 2>&1") != 0) {
416             warn "BTS_SENDMAIL_COMMAND $cmd could not be executed.\nReverting to default value /usr/sbin/sendmail\n";
417             $config_vars{'BTS_SENDMAIL_COMMAND'}='/usr/sbin/sendmail';
418         }
419     }
420
421     foreach my $var (sort keys %config_vars) {
422         if ($config_vars{$var} ne $config_default{$var}) {
423             $modified_conf_msg .= "  $var=$config_vars{$var}\n";
424         }
425     }
426     $modified_conf_msg ||= "  (none)\n";
427     chomp $modified_conf_msg;
428
429     $offlinemode = $config_vars{'BTS_OFFLINE'} eq 'yes' ? 1 : 0;
430     $caching = $config_vars{'BTS_CACHE'} eq 'no' ? 0 : 1;
431     $cachemode = $config_vars{'BTS_CACHE_MODE'};
432     $refreshmode = $config_vars{'BTS_FORCE_REFRESH'} eq 'yes' ? 1 : 0;
433     $updatemode = $config_vars{'BTS_ONLY_NEW'} eq 'yes' ? 1 : 0;
434     $mailreader = $config_vars{'BTS_MAIL_READER'};
435     $mailcomposer = $config_vars{'BTS_MAIL_COMPOSER'};
436     $sendmailcmd = $config_vars{'BTS_SENDMAIL_COMMAND'};
437     $smtphost = $config_vars{'BTS_SMTP_HOST'};
438     $includeresolved = $config_vars{'BTS_INCLUDE_RESOLVED'} eq 'yes' ? 1 : 0;
439 }
440
441 if (exists $ENV{'BUGSOFFLINE'}) {
442     warn "BUGSOFFLINE environment variable deprecated: please use ~/.devscripts\nor --offline/-o option instead!  (See bts(1) for details.)\n";
443 }
444
445 my ($opt_help, $opt_version, $opt_noconf);
446 my ($opt_cachemode, $opt_mailreader, $opt_mailcomposer, $opt_sendmail, $opt_smtphost);
447 my $opt_cachedelay=5;
448 my $mboxmode = 0;
449 my $quiet=0;
450 my $ccemail="";
451 my $ccsecurity="";
452
453 Getopt::Long::Configure('require_order');
454 GetOptions("help|h" => \$opt_help,
455            "version" => \$opt_version,
456            "o" => \$offlinemode,
457            "offline!" => \$offlinemode,
458            "online" => sub { $offlinemode = 0; },
459            "cache!" => \$caching,
460            "cache-mode|cachemode=s" => \$opt_cachemode,
461            "cache-delay=i" => \$opt_cachedelay,
462            "m|mbox" => \$mboxmode,
463            "mailreader|mail-reader=s" => \$opt_mailreader,
464            "mailcomposer|mail-composer=s" => \$opt_mailcomposer,
465            "cc-addr=s" => \$ccemail,
466            "sendmail=s" => \$opt_sendmail,
467            "smtp-host|smtphost=s" => \$opt_smtphost,
468            "f" => \$refreshmode,
469            "force-refresh!" => \$refreshmode,
470            "only-new!" => \$updatemode,
471            "n|no-action" => \$noaction,
472            "q|quiet+" => \$quiet,
473            "noconf|no-conf" => \$opt_noconf,
474            "include-resolved!" => \$includeresolved,
475            )
476     or die "Usage: bts [options]\nRun $progname --help for more details\n";
477
478 if ($opt_noconf) {
479     die "bts: --no-conf is only acceptable as the first command-line option!\n";
480 }
481 if ($opt_help) { bts_help(); exit 0; }
482 if ($opt_version) { bts_version(); exit 0; }
483
484 if ($opt_mailreader) {
485     if ($opt_mailreader =~ /\%s/) {
486         $mailreader=$opt_mailreader;
487     } else {
488         warn "bts: ignoring invalid --mailreader option: invalid mail command following it.\n";
489     }
490 }
491
492 if ($opt_mailcomposer) {
493     if ($opt_mailcomposer =~ /\%s/) {
494         $mailcomposer=$opt_mailcomposer;
495     } else {
496         warn "bts: ignoring invalid --mailcomposer option: invalid mail command following it.\n";
497     }
498 }
499
500 if ($opt_sendmail and $opt_smtphost) {
501     die "bts: --sendmail and --smtp-host mutually exclusive\n";
502 }
503
504 $smtphost = $opt_smtphost if $opt_smtphost;
505
506 if ($opt_sendmail) {
507     if ($opt_sendmail ne '/usr/sbin/sendmail'
508         and $opt_sendmail ne $sendmailcmd) {
509         my $cmd = (split ' ', $opt_sendmail)[0];
510         unless ($cmd =~ /^[A-Za-z0-9_\-\+\.\/]*$/) {
511             warn "--sendmail command contained funny characters: $cmd\nReverting to default value $sendmailcmd\n";
512             undef $opt_sendmail;
513         } elsif (system("command -v $cmd >/dev/null 2>&1") != 0) {
514             warn "--sendmail command $cmd could not be executed.\nReverting to default value $sendmailcmd\n";
515             undef $opt_sendmail;
516         }
517     }
518 }
519
520 if ($opt_sendmail) {
521     $sendmailcmd = $opt_sendmail;
522     $smtphost = '';
523 }
524
525 if ($opt_cachemode) {
526     if ($opt_cachemode =~ /^(min|mbox|full)$/) {
527         $cachemode=$opt_cachemode;
528     } else {
529         warn "bts: ignoring invalid --cache-mode; must be one of min, mbox, full.\n";
530     }
531 }
532
533
534 if (@ARGV == 0) {
535     bts_help();
536     exit 0;
537 }
538
539
540 # Otherwise, parse the arguments
541 my @command;
542 my @args;
543 our @comment=('');
544 my $ncommand = 0;
545 my $iscommand = 1;
546 while (@ARGV) {
547     $_ = shift @ARGV;
548     if ($_ =~ /^[\.,]$/) {
549         next if $iscommand;  # ". ." in command line - oops!
550         $ncommand++;
551         $iscommand = 1;
552         $comment[$ncommand] = '';
553     }
554     elsif ($iscommand) {
555         push @command, $_;
556         $iscommand = 0;
557     }
558     elsif ($comment[$ncommand]) {
559         $comment[$ncommand] .= " $_";
560     }
561     elsif (/^\#/ and not /^\#\d+$/) {
562         $comment[$ncommand] = $_;
563     } else {
564         push @{$args[$ncommand]}, $_;
565     }
566 }
567 $ncommand-- if $iscommand;
568
569 # Grub through the symbol table to find matching commands.
570 my $subject = '';
571 my $body = '';
572 our $index;
573 for $index (0 .. $ncommand) {
574     no strict 'refs';
575     if (exists $::{"bts_$command[$index]"}) {
576         "bts_$command[$index]"->(@{$args[$index]});
577     } else {
578         my @matches=grep /^bts_\Q$command[$index]\E/, keys %::;
579         if (@matches != 1) {
580             die "bts: Couldn't find a unique match for the command $command[$index]!\nRun $progname --help for a list of valid commands.\n";
581         }
582
583         # Replace the abbreviated command with its expanded equivalent
584         $command[$index] = $matches[0];
585         $command[$index] =~ s/^bts_//;
586
587         $matches[0]->(@{$args[$index]});
588     }
589 }
590
591 # Send all cached commands.
592 mailbtsall($subject, $body) if length $body;
593
594 # Unnecessary, but we'll do this for clarity
595 exit 0;
596
597 =head1 COMMANDS
598
599 For full details about the commands, see the BTS documentation.
600 L<http://www.debian.org/Bugs/server-control>
601
602 =over 4
603
604 =item show [options] [<bug number> | <package> | <maintainer> | : ] [opt=val ...]
605
606 =item show [options] [src:<package> | from:<submitter>] [opt=val ...]
607
608 =item show [options] [tag:<tag> | usertag:<tag> ] [opt=val ...]
609
610 =item show [release-critical | release-critical/... | RC]
611
612 This is a synonym for bts bugs.
613
614 =cut
615
616 sub bts_show {
617     goto &bts_bugs;
618 }
619
620 =item bugs [options] [<bug number> | <package> | <maintainer> | : ] [opt=val ..]
621
622 =item bugs [options] [src:<package> | from:<submitter>] [opt=val ..]
623
624 =item bugs [options] [tag:<tag> | usertag:<tag> ] [opt=val ..]
625
626 =item bugs [release-critical | release-critical/... | RC]
627
628 Display the page listing the requested bugs in a web browser using
629 L<sensible-browser(1)>.
630
631 Options may be specified after the "bugs" command in addition to or
632 instead of options at the start of the command line: recognised
633 options at his point are: -o/--offline/--online, --mbox, --mailreader
634 and --[no-]cache.  These are described earlier in this manpage.  If
635 either the -o or --offline option is used, or there is already an
636 up-to-date copy in the local cache, the cached version will be used.
637
638 The meanings of the possible arguments are as follows:
639
640 =over 8
641
642 =item (none)
643
644 If nothing is specified, bts bugs will display your bugs, assuming
645 that either DEBEMAIL or EMAIL (examined in that order) is set to the
646 appropriate email address.
647
648 =item <bug number>
649
650 Display bug number <bug number>.
651
652 =item <package>
653
654 Display the bugs for the package <package>.
655
656 =item src:<package>
657
658 Display the bugs for the source package <package>.
659
660 =item <maintainer>
661
662 Display the bugs for the maintainer email address <maintainer>.
663
664 =item from:<submitter>
665
666 Display the bugs for the submitter email address <submitter>.
667
668 =item tag:<tag>
669
670 Display the bugs which are tagged with <tag>.
671
672 =item usertag:<tag>
673
674 Display the bugs which are tagged with usertag <tag>.  See the BTS
675 documentation for more information on usertags.  This will require the
676 use of a users=<email> option.
677
678 =item :
679
680 Details of the bug tracking system itself, along with a bug-request
681 page with more options than this script, can be found on
682 http://bugs.debian.org/.  This page itself will be opened if the
683 command 'bts bugs :' is used.
684
685 =item release-critical, RC
686
687 Display the front page of the release-critical pages on the BTS.  This
688 is a synonym for http://bugs.debian.org/release-critical/index.html.
689 It is also possible to say release-critical/debian/main.html and the like.
690 RC is a synonym for release-critical/other/all.html.
691
692 =back
693
694 After the argument specifying what to display, you can optionally
695 specify options to use to format the page or change what it displayed.
696 These are passed to the BTS in the URL downloaded. For example, pass
697 dist=stable to see bugs affecting the stable version of a package,
698 version=1.0 to see bugs affecting that version of a package, or reverse=yes
699 to display newest messages first in a bug log.
700
701 If caching has been enabled (that is, --no-cache has not been used,
702 and BTS_CACHE has not been set to "no"), then any page requested by
703 "bts show" will automatically be cached, and be available offline
704 thereafter.  Pages which are automatically cached in this way will be
705 deleted on subsequent "bts show|bugs|cache" invocations if they have
706 not been accessed in 30 days.
707
708 Any other B<bts> commands following this on the command line will be
709 executed after the browser has been exited.
710
711 The desired browser can be specified and configured by setting the
712 BROWSER environment variable.  The conventions follow those defined by
713 Eric Raymond at http://www.catb.org/~esr/BROWSER/; we here reproduce the
714 relevant part.
715
716 The value of BROWSER may consist of a colon-separated series of
717 browser command parts. These should be tried in order until one
718 succeeds. Each command part may optionally contain the string "%s"; if
719 it does, the URL to be viewed is substituted there. If a command part
720 does not contain %s, the browser is to be launched as if the URL had
721 been supplied as its first argument. The string %% must be substituted
722 as a single %.
723
724 Rationale: We need to be able to specify multiple browser commands so
725 programs obeying this convention can do the right thing in either X or
726 console environments, trying X first. Specifying multiple commands may
727 also be useful for people who share files like .profile across
728 multiple systems. We need %s because some popular browsers have
729 remote-invocation syntax that requires it. Unless %% reduces to %, it
730 won't be possible to have a literal %s in the string.
731
732 For example, on most Linux systems a good thing to do would be:
733
734 BROWSER='mozilla -raise -remote "openURL(%s,new-window)":links'
735
736 =cut
737
738 sub bts_bugs {
739     @ARGV = @_; # needed for GetOptions
740     my ($sub_offlinemode, $sub_caching, $sub_mboxmode, $sub_mailreader);
741     GetOptions("o" => \$sub_offlinemode,
742                "offline!" => \$sub_offlinemode,
743                "online" => sub { $sub_offlinemode = 0; },
744                "cache!" => \$sub_caching,
745                "m|mbox" => \$sub_mboxmode,
746                "mailreader|mail-reader=s" => \$sub_mailreader,
747                )
748     or die "bts: unknown options for bugs command\n";
749     @_ = @ARGV; # whatever's left
750
751     if (defined $sub_offlinemode) {
752         ($offlinemode, $sub_offlinemode) = ($sub_offlinemode, $offlinemode);
753     }
754     if (defined $sub_caching) {
755         ($caching, $sub_caching) = ($sub_caching, $caching);
756     }
757     if (defined $sub_mboxmode) {
758         ($mboxmode, $sub_mboxmode) = ($sub_mboxmode, $mboxmode);
759     }
760     if (defined $sub_mailreader) {
761         if ($sub_mailreader =~ /\%s/) {
762             ($mailreader, $sub_mailreader) = ($sub_mailreader, $mailreader);
763         } else {
764             warn "bts: ignoring invalid --mailreader $sub_mailreader option:\ninvalid mail command following it.\n";
765             $sub_mailreader = undef;
766         }
767     }
768
769     my $url = sanitizething(shift);
770     if (! $url) {
771         if (defined $ENV{'DEBEMAIL'}) {
772             $url=$ENV{'DEBEMAIL'};
773         } else {
774             if (defined $ENV{'EMAIL'}) {
775                 $url=$ENV{'EMAIL'};
776             } else {
777                 die "bts bugs: Please set DEBEMAIL or EMAIL to your Debian email address.\n";
778             }
779         }
780     }
781     if ($url =~ /^.*\s<(.*)>\s*$/) { $url = $1; }
782     $url =~ s/^:$//;
783
784     # Are there any options?
785     my $urlopts = '';
786     if (@_) { 
787         $urlopts = join(";", '', @_); # so it'll be ";opt1=val1;opt2=val2"
788         $urlopts =~ s/:/=/g;
789         $urlopts =~ s/;tag=/;include=/;
790     }
791     
792     browse($url, $urlopts);
793
794     # revert options
795     if (defined $sub_offlinemode) {
796         $offlinemode = $sub_offlinemode;
797     }
798     if (defined $sub_caching) {
799         $caching = $sub_caching;
800     }
801     if (defined $sub_mboxmode) {
802         $mboxmode = $sub_mboxmode;
803     }
804     if (defined $sub_mailreader) {
805         $mailreader = $sub_mailreader;
806     }
807 }
808
809 =item select [key:value  ...]
810
811 Uses the SOAP interface to output a list of bugs which match the given
812 selection requirements.
813
814 The following keys are allowed, and may be given multiple times.
815
816 =over 8
817
818 =item package
819
820 Binary package name.
821
822 =item source
823
824 Source package name.
825
826 =item maintainer
827
828 E-mail address of the maintainer.
829
830 =item submitter
831
832 E-mail address of the submitter.
833
834 =item severity
835
836 Bug severity.
837
838 =item status
839
840 Status of the bug.
841
842 =item tag
843
844 Tags applied to the bug. If I<users> is specified, may include 
845 usertags in addition to the standard tags.
846
847 =item owner
848
849 Bug's owner.
850
851 =item bugs
852
853 List of bugs to search within.
854
855 =item users
856
857 Users to use when looking up usertags.
858
859 =item archive
860
861 Whether to search archived bugs or normal bugs; defaults to 0 
862 (i.e. only search normal bugs). As a special case, if archive is 
863 'both', both archived and unarchived bugs are returned.
864
865 =back
866
867 For example, to select the set of bugs submitted by 
868 jrandomdeveloper@example.com and tagged wontfix, one would use
869
870 bts select submitter:jrandomdeveloper@example.com tag:wontfix
871
872 =cut
873
874 sub bts_select {
875      die "bts: Couldn't run bts select: $soap_broken\n" unless have_soap();
876      my @args = @_;
877      my %valid_keys = (package => 'package',
878                        pkg     => 'package',
879                        src     => 'src',
880                        source  => 'src',
881                        maint   => 'maint',
882                        maintainer => 'maint',
883                        submitter => 'submitter',
884                        status    => 'status',
885                        tag       => 'tag',
886                        owner     => 'owner',
887                        dist      => 'dist',
888                        distribution => 'dist',
889                        bugs       => 'bugs',
890                        archive    => 'archive',
891                       );
892      my %users;
893      my %search_parameters;
894      my $soap = SOAP::Lite->uri($soapurl)->proxy($soapproxyurl);
895      for my $arg (@args) {
896           my ($key,$value) = split /:/, $arg, 2;
897           if (exists $valid_keys{$key}) {
898                push @{$search_parameters{$valid_keys{$key}}},
899                     $value;
900           }
901           elsif ($key =~/users?/) {
902                $users{$value} = 1;
903           }
904      }
905      my %usertags;
906      for my $user (keys %users) {
907           my $ut = $soap->get_usertag($user)->result();
908           next unless defined $ut;
909           for my $tag (keys %{$ut}) {
910                push @{$usertags{$tag}},
911                     @{$ut->{$tag}};
912           }
913      }
914      my $bugs = $soap->get_bugs(%search_parameters,
915                                 (keys %usertags)?(usertags=>\%usertags):()
916                                )->result();
917      if (not defined $bugs) {
918           die "Error while retrieving bugs from SOAP server";
919      }
920      print map {qq($_\n)} @{$bugs};
921 }
922
923 =item followup <bug> [bug log message ID]
924
925 Fire up a mail user agent to follow up to a given bug report, quoting the bug
926 log text. Per default the text of the first message in the bug log is inlined
927 for quoting purposes, you can specify an alternative one providing an optional
928 bug log ID. The first message in the bug log has bug log ID 1, second message
929 2, and so on. Alternatively, "last" can be specified as a bug log ID to choose
930 the last message, "last-1" to choose the next to last, and so on.
931
932 =cut
933
934 sub bts_followup {
935   die "bts: Couldn't run bts followup: $soap_broken\n" unless have_soap();
936   my $bug = checkbug(shift) or die "bts followup: follow up on which bug?\n";
937   my $msglogid = shift;
938   $msglogid = 1 unless defined $msglogid;
939   my $soap = SOAP::Lite->uri($soapurl)->proxy($soapproxyurl);
940   my $log = $soap->get_bug_log($bug)->result();
941   my @logs = @$log;
942   my $msg;
943   if ($msglogid =~ /^last(-(\d+))?$/i) {
944     my $idx = defined $2 ? $#logs-$2 : $#logs;
945     $msg = $logs[$idx];
946   } else {
947     $msg = $logs[$msglogid-1];
948   }
949   my %headers = parse_rfc822_headers($msg->{header});
950
951   # extract data needed to compose the follow up email
952   my $qbody = # quoted text body
953     join "\n", map { s/^/> /; $_ } (split /\r?\n/, $msg->{body});
954   my $subject = "follow up for $bug";   # default subject
955   $subject = "Re: $headers{subject}" if defined $headers{'subject'};
956   my $from = "anonymous"; # default author
957   if (defined $headers{'from'} and $headers{'from'} =~ /^(.*)\s+<[^<>]+>\s*$/) {
958     $from = $1;
959   }
960   my $ref = ""; # id for In-Reply-To 
961   $ref = $headers{'message-id'} if defined $headers{'message-id'};
962   my $submitter = "";
963   $submitter = $headers{'from'} if defined $headers{'from'};
964
965   # compose follow up email
966   my ($fh, $mailtpl) = tempfile("btsXXXXXX",
967     SUFFIX => ".mail",
968     DIR => File::Spec->tmpdir,
969     UNLINK => 1);
970   open (MAIL, ">/dev/fd/" . fileno($fh))
971     or die "bts: writing to temporary file: $!\n";
972   print MAIL "To: $submitter\n";
973   print MAIL "Cc: $bug\@$btsserver\n";
974   print MAIL "Subject: $subject\n";
975   print MAIL "In-Reply-To: $ref\n" if $ref;
976   print MAIL "\n";
977   print MAIL "On $headers{'date'}, " if defined $headers{'date'};
978   print MAIL "$from wrote:\n";
979   print MAIL "$qbody\n";
980   close MAIL;
981
982   # fire up MUA on email template
983   my $cmd = $mailcomposer;
984   $cmd =~ s/\%s/$mailtpl/g;
985   system $cmd;
986   unless ($? == 0) {
987     my $rc = $? >> 8;
988     print "Failure to follow up: mail composer returned exit status $rc.\n";
989     print "Dumping intended mail template to standard output:\n\n";
990     system "cat $mailtpl";
991   }
992 }
993
994 =item clone <bug> [new IDs]
995
996 The clone control command allows you to duplicate a bug report. It is useful
997 in the case where a single report actually indicates that multiple distinct
998 bugs have occurred. "New IDs" are negative numbers, separated by spaces,
999 which may be used in subsequent control commands to refer to the newly
1000 duplicated bugs.  A new report is generated for each new ID.
1001
1002 =cut
1003
1004 sub bts_clone {
1005     my $bug=checkbug(shift) or die "bts clone: clone what bug?\n";
1006     @clonedbugs{@_} = (1) x @_;  # add these bug numbers to hash
1007     mailbts("cloning $bug", "clone $bug " . join(" ",@_));
1008 }
1009
1010 # Do not include this in the manpage - it's deprecated
1011
1012 # =item close <bug> <version>
1013
1014 # Close a bug. Remember that using this to close a bug is often bad manners,
1015 # sending an informative mail to nnnnn-done@bugs.debian.org is much better.
1016 # You should specify which version of the package closed the bug, if
1017 # possible.
1018
1019 # =cut
1020
1021 sub bts_close {
1022     my $bug=checkbug(shift) or die "bts close: close what bug?\n";
1023     my $version=shift;
1024     $version="" unless defined $version;
1025     opts_done(@_);
1026     mailbts("closing $bug", "close $bug $version");
1027     warn <<"EOT";
1028 bts: Closing $bug as you requested.
1029 Please note that the "bts close" command is deprecated!
1030 It is usually better to email nnnnnn-done\@bugs.debian.org with
1031 an informative mail.
1032 Please remember to email $bug-submitter\@bugs.debian.org with
1033 an explanation of why you have closed this bug.  Thank you!
1034 EOT
1035 }
1036
1037 =item reopen <bug> [<submitter>]
1038
1039 Reopen a bug, with optional submitter.
1040
1041 =cut
1042
1043 sub bts_reopen {
1044     my $bug=checkbug(shift) or die "bts reopen: reopen what bug?\n";
1045     my $submitter=shift || ''; # optional
1046     opts_done(@_);
1047     mailbts("reopening $bug", "reopen $bug $submitter");
1048 }
1049
1050 =item archive <bug>
1051
1052 Archive a bug that has previously been archived but is currently not.
1053 The bug must fulfil all of the requirements for archiving with the
1054 exception of those that are time-based.
1055
1056 =cut
1057
1058 sub bts_archive {
1059     my $bug=checkbug(shift) or die "bts archive: archive what bug?\n";
1060     opts_done(@_);
1061     mailbts("archiving $bug", "archive $bug");
1062 }
1063
1064 =item unarchive <bug>
1065
1066 Unarchive a bug that is currently archived.
1067
1068 =cut
1069
1070 sub bts_unarchive {
1071     my $bug=checkbug(shift) or die "bts unarchive: unarchive what bug?\n";
1072     opts_done(@_);
1073     mailbts("unarchiving $bug", "unarchive $bug");
1074 }
1075
1076 =item retitle <bug> <title>
1077
1078 Change the title of the bug.
1079
1080 =cut
1081
1082 sub bts_retitle {
1083     my $bug=checkbug(shift) or die "bts retitle: retitle what bug?\n";
1084     my $title=join(" ", @_);
1085     if (! length $title) {
1086         die "bts retitle: set title of $bug to what?\n";
1087     }
1088     mailbts("retitle $bug to $title", "retitle $bug $title");
1089 }
1090
1091 =item submitter <bug> [<bug> ...] <submitter-email>
1092
1093 Change the submitter address of a bug or a number of bugs, with `!' meaning
1094 `use the address on the current email as the new submitter address'.
1095
1096 =cut
1097
1098 sub bts_submitter {
1099     @_ or die "bts submitter: change submitter of what bug?\n";
1100     my $submitter=pop;
1101     if ($submitter !~ /\@/ and $submitter ne '!') {
1102         die "bts submitter: change submitter to what?\n";
1103     }
1104     foreach (@_) {
1105         my $bug=checkbug($_) or die "bts submitter: $_ is not a bug number\n";
1106         mailbts("submitter $bug", "submitter $bug $submitter");
1107     }
1108 }
1109
1110 =item reassign <bug> [<bug> ...] <package> [<version>]
1111
1112 Reassign a bug or a number of bugs to a different package.
1113 The version field is optional; see the explanation at
1114 L<http://www.debian.org/Bugs/server-control>.
1115
1116 =cut
1117
1118 sub bts_reassign {
1119     my ($bug, @bugs);
1120     while ($_ = shift) {
1121         $bug=checkbug($_, 1) or last;
1122         push @bugs, $bug;
1123     }
1124     @bugs or die "bts reassign: reassign what bug(s)?\n";
1125     my $package=$_ or die "bts reassign: reassign bug(s) to what package?\n";
1126     my $version=shift;
1127     $version="" unless defined $version;
1128     if (length $version and $version !~ /\d/) {
1129         die "bts reassign: version number $version contains no digits!\n";
1130     }
1131     opts_done(@_);
1132
1133     foreach $bug (@bugs) {
1134         mailbts("reassign $bug to $package", "reassign $bug $package $version");
1135     }
1136 }
1137
1138 =item found <bug> [<version>]
1139
1140 Indicate that a bug was found to exist in a particular package version.
1141
1142 =cut
1143
1144 sub bts_found {
1145     my $bug=checkbug(shift) or die "bts found: found what bug?\n";
1146     my $version=shift;
1147     if (! defined $version) {
1148         warn "bts: found has no version number, but sending to the BTS anyway\n";
1149         $version="";
1150     }
1151     opts_done(@_);
1152     mailbts("found $bug in $version", "found $bug $version");
1153 }
1154
1155 =item notfound <bug> <version>
1156
1157 Remove the record that bug was encountered in the given version of the
1158 package to which it is assigned.
1159
1160 =cut
1161
1162 sub bts_notfound {
1163     my $bug=checkbug(shift) or die "bts notfound: what bug?\n";
1164     my $version=shift or die "bts notfound: remove record \#$bug from which version?\n";
1165     opts_done(@_);
1166     mailbts("notfound $bug in $version", "notfound $bug $version");
1167 }
1168
1169 =item fixed <bug> <version>
1170
1171 Indicate that a bug was fixed in a particular package version, without
1172 affecting the bug's open/closed status.
1173
1174 =cut
1175
1176 sub bts_fixed {
1177     my $bug=checkbug(shift) or die "bts fixed: what bug?\n";
1178     my $version=shift or die "bts fixed: \#$bug fixed in which version?\n";
1179     opts_done(@_);
1180     mailbts("fixed $bug in $version", "fixed $bug $version");
1181 }
1182
1183 =item notfixed <bug> <version>
1184
1185 Remove the record that a bug was fixed in the given version of the
1186 package to which it is assigned.
1187
1188 This is equivalent to the sequence of commands "found <bug> <version>",
1189 "notfound <bug> <version>".
1190
1191 =cut
1192
1193 sub bts_notfixed {
1194     my $bug=checkbug(shift) or die "bts notfixed: what bug?\n";
1195     my $version=shift or die "bts notfixed: remove record \#$bug from which version?\n";
1196     opts_done(@_);
1197     mailbts("notfixed $bug in $version", "notfixed $bug $version");
1198 }
1199
1200 =item block <bug> by|with <bug> [<bug> ...]
1201
1202 Note that a bug is blocked from being fixed by a set of other bugs.
1203
1204 =cut
1205
1206 sub bts_block {
1207     my $bug=checkbug(shift) or die "bts block: what bug is blocked?\n";
1208     my $word=shift;
1209     if ($word ne 'by' && $word ne 'with') {
1210             unshift @_, $word;
1211     }
1212     my @blockers;
1213     foreach (@_) {
1214         my $blocker=checkbug($_) or die "bts block: some blocking bug number(s) not valid\n";
1215         push @blockers, $blocker;
1216     }
1217     mailbts("block $bug with @blockers", "block $bug with @blockers");
1218 }
1219
1220 =item unblock <bug> by|with <bug> [<bug> ...]
1221
1222 Note that a bug is no longer blocked from being fixed by a set of other bugs.
1223
1224 =cut
1225
1226 sub bts_unblock {
1227     my $bug=checkbug(shift) or die "bts unblock: what bug is blocked?\n";
1228     my $word=shift;
1229     if ($word ne 'by' && $word ne 'with') {
1230             unshift @_, $word;
1231     }
1232     my @blockers;
1233     foreach (@_) {
1234         my $blocker=checkbug($_) or die "bts unblock: some blocking bug number(s) not valid\n";
1235         push @blockers, $blocker;
1236     }
1237     mailbts("unblock $bug with @blockers", "unblock $bug with @blockers");
1238 }
1239
1240 =item merge <bug> <bug> [<bug> ...]
1241
1242 Merge a set of bugs together.
1243
1244 =cut
1245
1246 sub bts_merge {
1247     my @bugs;
1248     foreach (@_) {
1249         my $bug=checkbug($_) or die "bts merge: some bug number(s) not valid\n";
1250         push @bugs, $bug;
1251     }
1252     @bugs > 1 or
1253         die "bts merge: at least two bug numbers to be merged must be specified\n";
1254     mailbts("merging @bugs", "merge @bugs");
1255 }
1256
1257 =item forcemerge <bug> <bug> [<bug> ...]
1258
1259 Forcibly merge a set of bugs together. The first bug listed is the master bug, 
1260 and its settings (those which must be equal in a normal merge) are assigned to 
1261 the bugs listed next.
1262
1263 =cut
1264
1265 sub bts_forcemerge {
1266     my @bugs;
1267     foreach (@_) {
1268         my $bug=checkbug($_) or die "bts forcemerge: some bug number(s) not valid\n";
1269         push @bugs, $bug;
1270     }
1271     @bugs > 1 or
1272         die "bts forcemerge: at least two bug numbers to be merged must be specified\n";
1273     mailbts("forcibly merging @bugs", "forcemerge @bugs");
1274 }
1275
1276
1277 =item unmerge <bug>
1278
1279 Unmerge a bug.
1280
1281 =cut
1282
1283 sub bts_unmerge {
1284     my $bug=checkbug(shift) or die "bts unmerge: unmerge what bug?\n";
1285     opts_done(@_);
1286     mailbts("unmerging $bug", "unmerge $bug");
1287 }
1288
1289 =item tag <bug> [+|-|=] tag [tag ..]
1290
1291 =item tags <bug> [+|-|=] tag [tag ..]
1292
1293 Set or unset a tag on a bug. The tag may either be the exact tag name
1294 or it may be abbreviated to any unique tag substring. (So using
1295 "fixed" will set the tag "fixed", not "fixed-upstream", for example,
1296 but "fix" would not be acceptable.) Multiple tags may be specified as
1297 well. The two commands (tag and tags) are identical. At least one tag
1298 must be specified, unless the '=' flag is used, where the command
1299
1300   bts tags <bug> =
1301
1302 will remove all tags from the specified bug.
1303
1304 =cut
1305
1306 sub bts_tags {
1307     my $bug=checkbug(shift) or die "bts tags: tag what bug?\n";
1308     if (! @_) {
1309         die "bts tags: set what tag?\n";
1310     }
1311     # Parse the rest of the command line.
1312     my $command="tags $bug";
1313     my $flag="";
1314     if ($_[0] =~ /^[-+=]$/) {
1315         $flag = $_[0];
1316         $command .= " $flag";
1317         shift;
1318     }
1319     elsif ($_[0] =~ s/^([-+=])//) {
1320         $flag = $1;
1321         $command .= " $flag";
1322     }
1323
1324     if ($flag ne '=' && ! @_) {
1325         die "bts tags: set what tag?\n";
1326     }
1327     
1328     foreach my $tag (@_) {
1329         if (exists $valid_tags{$tag}) {
1330             $command .= " $tag";
1331             if ($tag eq "security") {
1332                     $ccsecurity = "team\@security.debian.org";
1333             }
1334         } else {
1335             # Try prefixes
1336             my @matches = grep /^\Q$tag\E/, @valid_tags;
1337             if (@matches != 1) {
1338                 if ($tag =~ /^[-+=]/) {
1339                     die "bts tags: The +|-|= flag must not be joined to the tags.  Run bts help for usage info.\n";
1340                 }
1341                 die "bts tags: \"$tag\" is not a " . (@matches > 1 ? "unique" : "valid") . " tag prefix. Choose from: " . join(" ", @valid_tags) . "\n";
1342             }
1343             $command .= " $matches[0]";
1344         }
1345     }
1346     mailbts("tagging $bug", $command);
1347 }
1348
1349 =item user <email>
1350
1351 Specify a user email address before using the usertags command.
1352
1353 =cut
1354
1355 sub bts_user {
1356     my $email=shift or die "bts user: set user to what email address?\n";
1357     if (! length $email) {
1358         die "bts user: set user to what email address?\n";
1359     }
1360     opts_done(@_);
1361     mailbts("user $email", "user $email");
1362 }
1363
1364 =item usertag <bug> [+|-|=] tag [tag ..]
1365
1366 =item usertags <bug> [+|-|=] tag [tag ..]
1367
1368 Set or unset a user tag on a bug. The tag must be the exact tag name wanted;
1369 there are no defaults or checking of tag names.  Multiple tags may be
1370 specified as well. The two commands (usertag and usertags) are identical.
1371 At least one tag must be specified, unless the '=' flag is used, where the
1372 command
1373
1374   bts usertags <bug> =
1375
1376 will remove all user tags from the specified bug.
1377
1378 =cut
1379
1380 sub bts_usertags {
1381     my $bug=checkbug(shift) or die "bts usertags: tag what bug?\n";
1382     if (! @_) {
1383         die "bts usertags: set what user tag?\n";
1384     }
1385     # Parse the rest of the command line.
1386     my $command="usertags $bug";
1387     my $flag="";
1388     if ($_[0] =~ /^[-+=]$/) {
1389         $flag = $_[0];
1390         $command .= " $flag";
1391         shift;
1392     }
1393     elsif ($_[0] =~ s/^([-+=])//) {
1394         $flag = $1;
1395         $command .= " $flag";
1396     }
1397
1398     if ($flag ne '=' && ! @_) {
1399         die "bts usertags: set what tag?\n";
1400     }
1401     
1402     $command .= " " . join(" ", @_);
1403
1404     mailbts("usertagging $bug", $command);
1405 }
1406
1407 =item claim <bug> [<claim>]
1408
1409 Record that you have claimed a bug (e.g. for a bug squashing party).
1410
1411 If no claim is specified, the environment variable DEBEMAIL
1412 or EMAIL (checked in that order) is used.
1413
1414 =cut
1415
1416 sub bts_claim {
1417     my $bug=checkbug(shift) or die "bts claim: claim what bug?\n";
1418     my $claim=shift || $ENV{'DEBEMAIL'} || $ENV{'EMAIL'};
1419     bts_user("bugsquash\@qa.debian.org");
1420     bts_usertags("$bug" , " + $claim");
1421 }
1422
1423 =item unclaim <bug> [<claim>]
1424
1425 Remove the record that you have claimed a bug.
1426
1427 If no claim is specified, the environment variable DEBEMAIL
1428 or EMAIL (checked in that order) is used.
1429
1430 =cut
1431
1432 sub bts_unclaim {
1433     my $bug=checkbug(shift) or die "bts unclaim: unclaim what bug?\n";
1434     my $claim=shift || $ENV{'DEBEMAIL'} || $ENV{'EMAIL'};
1435     bts_user("bugsquash\@qa.debian.org");
1436     bts_usertags("$bug" , " - $claim");
1437 }
1438
1439 =item severity <bug> <severity>
1440
1441 Change the severity of a bug. Available severities are: wishlist, minor, normal,
1442 important, serious, grave, critical. The severity may be abbreviated to any
1443 unique substring.
1444
1445 =cut
1446
1447 sub bts_severity {
1448     my $bug=checkbug(shift) or die "bts severity: change the severity of what bug?\n";
1449     my $severity=lc(shift) or die "bts severity: set \#$bug\'s severity to what?\n";
1450     my @matches = grep /^\Q$severity\E/i, @valid_severities;
1451     if (@matches != 1) {
1452         die "bts severity: \"$severity\" is not a valid severity.\nChoose from: @valid_severities\n";
1453     }
1454     opts_done(@_);
1455     mailbts("severity of $bug is $matches[0]", "severity $bug $matches[0]");
1456 }
1457
1458 =item forwarded <bug> <email>
1459
1460 Mark the bug as forwarded to the given email address.
1461
1462 =cut
1463
1464 sub bts_forwarded {
1465     my $bug=checkbug(shift) or die "bts forwarded: mark what bug as forwarded?\n";
1466     my $email=join(' ', @_);
1467     if ($email =~ /$btsserver/) {
1468         die "bts forwarded: We don't forward bugs within $btsserver, use bts reassign instead\n";
1469     }
1470     if (! length $email) {
1471         die "bts forwarded: mark bug $bug as forwarded to what email address?\n";
1472     }
1473     mailbts("bug $bug is forwarded to $email", "forwarded $bug $email");
1474 }
1475
1476 =item notforwarded <bug>
1477
1478 Mark a bug as not forwarded.
1479
1480 =cut
1481
1482 sub bts_notforwarded {
1483     my $bug=checkbug(shift) or die "bts notforwarded: what bug?\n";
1484     opts_done(@_);
1485     mailbts("bug $bug is not forwarded", "notforwarded $bug");
1486 }
1487
1488 =item package [ <package> ... ]
1489
1490 The following commands will only apply to bugs against the listed
1491 packages; this acts as a safety mechanism for the BTS.  If no packages
1492 are listed, this check is turned off again.
1493
1494 =cut
1495
1496 sub bts_package {
1497     my $email=join(' ', @_);
1498     mailbts("setting package to $email", "package $email");
1499 }
1500
1501 =item owner <bug> <owner-email>
1502
1503 Change the "owner" address of a bug, with `!' meaning
1504 `use the address on the current email as the new owner address'.
1505
1506 The owner of a bug accepts responsibility for dealing with it. Note that 
1507 the "owner" of a bug does not automatically receive all of the email 
1508 corresponding to it; use "subscribe" to achieve that.
1509
1510 =cut
1511
1512 sub bts_owner {
1513     my $bug=checkbug(shift) or die "bts owner: change owner of what bug?\n";
1514     my $owner=shift or die "bts owner: change owner to what?\n";
1515     opts_done(@_);
1516     mailbts("owner $bug", "owner $bug $owner");
1517 }
1518
1519 =item noowner <bug>
1520
1521 Mark a bug as having no "owner".
1522
1523 =cut
1524
1525 sub bts_noowner {
1526     my $bug=checkbug(shift) or die "bts noowner: what bug?\n";
1527     opts_done(@_);
1528     mailbts("bug $bug has no owner", "noowner $bug");
1529 }
1530
1531 =item subscribe <bug> <email>
1532
1533 Subscribe the given email address to the specified bug report.  If no email
1534 address is specified, the environment variable DEBEMAIL or EMAIL (in that
1535 order) is used.  If those are not set, or `!' is given as email address,
1536 your default address will be used.
1537
1538 After executing this command, you will be sent a subscription confirmation to
1539 which you have to reply.  When subscribed to a bug report, you receive all
1540 relevant emails and notifications.  Use the unsubscribe command to unsubscribe.
1541
1542 =cut
1543
1544 sub bts_subscribe {
1545     my $bug=checkbug(shift) or die "bts subscribe: subscribe to what bug?\n";
1546     my $email=lc(shift);
1547     if (defined $email and $email eq '!') { $email = undef; }
1548     else {
1549         $email ||= $ENV{'DEBEMAIL'};
1550         $email ||= $ENV{'EMAIL'};
1551     }
1552     opts_done(@_);
1553     mailto('subscription request for bug #' . $bug, '',
1554            $bug . '-subscribe@' . $btsserver, $email);
1555 }
1556
1557 =item unsubscribe <bug> <email>
1558
1559 Unsubscribe the given email address from the specified bug report.  As with
1560 subscribe above, if no email address is specified, the environment variables
1561 DEBEMAIL or EMAIL (in that order) is used.  If those are not set, or `!' is
1562 given as email address, your default address will be used.
1563
1564 After executing this command, you will be sent an unsubscription confirmation
1565 to which you have to reply. Use the subscribe command to, well, subscribe.
1566
1567 =cut
1568
1569 sub bts_unsubscribe {
1570     my $bug=checkbug(shift) or die "bts unsubscribe: unsubscribe from what bug?\n";
1571     my $email=lc(shift);
1572     if (defined $email and $email eq '!') { $email = undef; }
1573     else {
1574         $email ||= $ENV{'DEBEMAIL'};
1575         $email ||= $ENV{'EMAIL'};
1576     }
1577     opts_done(@_);
1578     mailto('unsubscription request for bug #' . $bug, '',
1579            $bug . '-unsubscribe@' . $btsserver, $email);
1580 }
1581
1582 =item reportspam <bug> ...
1583
1584 The reportspam command allows you to report a bug report as containing spam.
1585 It saves one from having to go to the bug web page to do so.
1586
1587 =cut
1588
1589 sub bts_reportspam {
1590     my @bugs;
1591
1592     if (! have_lwp()) {
1593         die "bts: Couldn't run bts reportspam: $lwp_broken\n";
1594     }
1595
1596     foreach (@_) {
1597         my $bug=checkbug($_) or die "bts reportspam: some bug number(s) not valid\n";
1598         push @bugs, $bug;
1599     }
1600     @bugs >= 1 or
1601         die "bts reportspam: at least one bug number must be specified\n";
1602
1603     init_agent() unless $ua;
1604     foreach my $bug (@bugs) {
1605         my $request = HTTP::Request->new('GET', "$btscgispamurl?bug=$bug;ok=ok");
1606         my $response = $ua->request($request);
1607         if (! $response->is_success) {
1608             warn "bts: failed to report $bug as containing spam: " . $response->status_line . "\n";
1609         }
1610     }
1611 }
1612
1613 =item spamreport <bug> ...
1614
1615 spamreport is a synonym for reportspam.
1616
1617 =cut
1618
1619 sub bts_spamreport {
1620     goto &bts_reportspam;
1621 }
1622
1623 =item cache [options] [<maint email> | <pkg> | src:<pkg> | from:<submitter>]
1624
1625 =item cache [options] [release-critical | release-critical/... | RC]
1626
1627 Generate or update a cache of bug reports for the given email address
1628 or package. By default it downloads all bugs belonging to the email
1629 address in the DEBEMAIL environment variable (or the EMAIL environment
1630 variable if DEBEMAIL is unset). This command may be repeated to cache
1631 bugs belonging to several people or packages. If multiple packages or
1632 addresses are supplied, bugs belonging to any of the arguments will be
1633 cached; those belonging to more than one of the arguments will only be
1634 downloaded once. The cached bugs are stored in ~/.devscripts_cache/bts/
1635
1636 You can use the cached bugs with the -o switch. For example:
1637
1638   bts -o bugs
1639   bts -o show 12345
1640
1641 Also, bts will update the files in it in a piecemeal fashion as it
1642 downloads information from the BTS using the 'show' command. You might
1643 thus set up the cache, and update the whole thing once a week, while
1644 letting the automatic cache updates update the bugs you frequently
1645 refer to during the week.
1646
1647 Some options affect the behaviour of the cache command.  The first is
1648 the setting of --cache-mode, which controls how much B<bts> downloads
1649 of the referenced links from the bug page, including boring bits such
1650 as the acknowledgement emails, emails to the control bot, and the mbox
1651 version of the bug report.  It can take three values: min (the
1652 minimum), mbox (download the minimum plus the mbox version of the bug
1653 report) or full (the whole works).  The second is --force-refresh or
1654 -f, which forces the download, even if the cached bug report is
1655 up-to-date.  The --include-resolved option indicates whether bug
1656 reports marked as resolved should be downloaded during caching.
1657
1658 Each of these is configurable from the configuration
1659 file, as described below.  They may also be specified after the
1660 "cache" command as well as at the start of the command line.
1661
1662 Finally, -q or --quiet will suppress messages about caches being
1663 up-to-date, and giving the option twice will suppress all cache
1664 messages (except for error messages).
1665
1666 Beware of caching RC, though: it will take a LONG time!  (With 1000+
1667 RC bugs and a delay of 5 seconds between bugs, you're looking at a
1668 minimum of 1.5 hours, and probably significantly more than that.)
1669
1670 =cut
1671
1672 sub bts_cache {
1673     @ARGV = @_;
1674     my ($sub_cachemode, $sub_refreshmode, $sub_updatemode);
1675     my $sub_quiet = $quiet;
1676     my $sub_includeresolved = $includeresolved;
1677     GetOptions("cache-mode|cachemode=s" => \$sub_cachemode,
1678                "f" => \$sub_refreshmode,
1679                "force-refresh!" => \$sub_refreshmode,
1680                "only-new!" => \$sub_updatemode,
1681                "q|quiet+" => \$sub_quiet,
1682                "include-resolved!" => \$sub_includeresolved,
1683                )
1684     or die "bts: unknown options for cache command\n";
1685     @_ = @ARGV; # whatever's left
1686
1687     if (defined $sub_refreshmode) {
1688         ($refreshmode, $sub_refreshmode) = ($sub_refreshmode, $refreshmode);
1689     }
1690     if (defined $sub_updatemode) {
1691         ($updatemode, $sub_updatemode) = ($sub_updatemode, $updatemode);
1692     }
1693     if (defined $sub_cachemode) {
1694         if ($sub_cachemode =~ /^(min|mbox|full)$/) {
1695             ($cachemode, $sub_cachemode) = ($sub_cachemode, $cachemode);
1696         } else {
1697             warn "bts: ignoring invalid --cache-mode $sub_cachemode;\nmust be one of min, mbox, full.\n";
1698         }
1699     }
1700     # This may be a no-op, we don't mind
1701     ($quiet, $sub_quiet) = ($sub_quiet, $quiet);
1702     ($includeresolved, $sub_includeresolved) = ($sub_includeresolved, $includeresolved);
1703
1704     prunecache();
1705     if (! have_lwp()) {
1706         die "bts: Couldn't run bts cache: $lwp_broken\n";
1707     }
1708
1709     if (! -d $cachedir) {
1710         if (! -d dirname($cachedir)) {
1711             mkdir(dirname($cachedir))
1712                 or die "bts: couldn't mkdir ".dirname($cachedir).": $!\n";
1713         }
1714         mkdir($cachedir)
1715             or die "bts: couldn't mkdir $cachedir: $!\n";
1716     }
1717
1718     download("css/bugs.css");
1719
1720     my $tocache;
1721     if (@_ > 0) { $tocache=sanitizething(shift); }
1722     else { $tocache=''; }
1723     
1724     if (! length $tocache) {
1725         $tocache=$ENV{'DEBEMAIL'} || $ENV{'EMAIL'} || '';
1726         if ($tocache =~ /^.*\s<(.*)>\s*$/) { $tocache = $1; }
1727     }
1728     if (! length $tocache) {
1729         die "bts cache: cache what?\n";
1730     }
1731
1732     my $sub_thgopts = '';
1733     $sub_thgopts = ';pend-exc=done'
1734         if (! $includeresolved && $tocache !~ /^release-critical/);
1735
1736     my %bugs = ();
1737     my %oldbugs = ();
1738
1739     do {
1740         %oldbugs = (%oldbugs, map { $_ => 1 } bugs_from_thing($tocache, $sub_thgopts));
1741
1742         # download index
1743         download($tocache, $sub_thgopts, 1);
1744
1745         %bugs = (%bugs, map { $_ => 1 } bugs_from_thing($tocache, $sub_thgopts));
1746
1747         $tocache = sanitizething(shift);
1748     } while (defined $tocache);
1749
1750     # remove old bugs from cache
1751     if (keys %oldbugs) {
1752         tie (%timestamp, "Devscripts::DB_File_Lock", $timestampdb,
1753              O_RDWR()|O_CREAT(), 0600, $DB_HASH, "write")
1754             or die "bts: couldn't open DB file $timestampdb for writing: $!\n"
1755             if ! tied %timestamp;
1756     }
1757
1758     foreach my $bug (keys %oldbugs) {
1759         if (! $bugs{$bug}) {
1760             deletecache($bug);
1761         }
1762     }
1763
1764     untie %timestamp;
1765     
1766     # download bugs
1767     my $bugcount = 1;
1768     my $bugtotal = scalar keys %bugs;
1769     foreach my $bug (keys %bugs) {
1770         if (-f cachefile($bug, '') and $updatemode) {
1771             print "Skipping $bug as requested ... $bugcount/$bugtotal\n"
1772                 if !$quiet;
1773             $bugcount++;
1774             next;
1775         }
1776         download($bug, '', 1, 0, $bugcount, $bugtotal);
1777         sleep $opt_cachedelay;
1778         $bugcount++;
1779     }
1780
1781     # revert options    
1782     if (defined $sub_refreshmode) {
1783         $refreshmode = $sub_refreshmode;
1784     }
1785     if (defined $sub_updatemode) {
1786         $updatemode = $sub_updatemode;
1787     }
1788     if (defined $sub_cachemode) {
1789         $cachemode = $sub_cachemode;
1790     }
1791     $quiet = $sub_quiet;
1792     $includeresolved = $sub_includeresolved;
1793 }
1794
1795 =item cleancache <package> | src:<package> | <maintainer>
1796
1797 =item cleancache from:<submitter> | tag:<tag> | usertag:<tag> | <number> | ALL
1798
1799 Clean the cache for the specified package, maintainer, etc., as
1800 described above for the "bugs" command, or clean the entire cache if
1801 "ALL" is specified. This is useful if you are going to have permanent
1802 network access or if the database has become corrupted for some
1803 reason.  Note that for safety, this command does not default to the
1804 value of DEBEMAIL or EMAIL.
1805
1806 =cut
1807
1808 sub bts_cleancache {
1809     prunecache();
1810     my $toclean=sanitizething(shift);
1811     if (! defined $toclean) {
1812         die "bts cleancache: clean what?\n";
1813     }
1814     if (! -d $cachedir) {
1815         return;
1816     }
1817     if ($toclean eq 'ALL') {
1818         if (system("/bin/rm", "-rf", $cachedir) >> 8 != 0) {
1819             warn "Problems cleaning cache: $!\n";
1820         }
1821         return;
1822     }
1823     
1824     # clean index
1825     tie (%timestamp, "Devscripts::DB_File_Lock", $timestampdb,
1826          O_RDWR()|O_CREAT(), 0600, $DB_HASH, "write")
1827         or die "bts: couldn't open DB file $timestampdb for writing: $!\n"
1828         if ! tied %timestamp;
1829
1830     if ($toclean =~ /^\d+$/) {
1831         # single bug only
1832         deletecache($toclean);
1833     } else {
1834         my @bugs_to_clean = bugs_from_thing($toclean);
1835         deletecache($toclean);
1836         
1837         # remove old bugs from cache
1838         foreach my $bug (@bugs_to_clean) {
1839             deletecache($bug);
1840         }
1841     }
1842
1843     untie %timestamp;
1844 }
1845
1846 # Add any new commands here.
1847
1848 =item version
1849
1850 Display version and copyright information.
1851
1852 =cut
1853
1854 sub bts_version {
1855     print <<"EOF";
1856 $progname version $version
1857 Copyright (C) 2001-2003 by Joey Hess <joeyh\@debian.org>.
1858 Modifications Copyright (C) 2002-2004 by Julian Gilbey <jdg\@debian.org>.
1859 Modifications Copyright (C) 2007 by Josh Triplett <josh\@freedesktop.org>.
1860 It is licensed under the terms of the GPL, either version 2 of the
1861 License, or (at your option) any later version.
1862 EOF
1863 }
1864
1865 =item help
1866
1867 Display a short summary of commands, suspiciously similar to parts of this
1868 man page.
1869
1870 =cut
1871
1872 # Other supporting subs
1873
1874 # This must be the last bts_* sub
1875 sub bts_help {
1876     my $inlist = 0;
1877     my $insublist = 0;
1878     print <<"EOF";
1879 Usage: $progname [options] command [args] [\#comment] [.|, command ... ]
1880 Valid options are:
1881    --no-conf, --noconf    Do not read devscripts config files;
1882                           must be the first option given
1883    -o, --offline          Do not attempt to connect to BTS for show/bug
1884                           commands: use cached copy
1885    --online, --no-offline Attempt to connect (default)
1886    -n, --no-action        Do not send emails but print them to standard output.
1887    --no-cache             Do not attempt to cache new versions of BTS
1888                           pages when performing show/bug commands
1889    --cache                Do attempt to cache new versions of BTS
1890                           pages when performing show/bug commands (default)
1891    --cache-mode={min|mbox|full}
1892                           How much to cache when we are caching: the sensible
1893                           bare minimum (default), the mbox as well, or
1894                           everything?
1895    --cache-delay=seconds  Time to sleep between each download when caching.
1896    -m, --mbox             With show or bugs, open a mailreader to read the mbox
1897                           version instead
1898    --mailreader=CMD       Run CMD to read an mbox; default is 'mutt -f %s'
1899                           (must contain %s, which is replaced by mbox name)
1900    -f, --force-refresh    Reload all bug reports being cached, even unchanged
1901                           ones
1902    --no-force-refresh     Do not do so (default)
1903    --sendmail=cmd         Sendmail command to use (default /usr/sbin/sendmail)
1904    --smtp-host=host       SMTP host to use
1905    --no-include-resolved  Do not cache bugs marked as resolved
1906    --include-resolved     Cache bugs marked as resolved (default)
1907    --help, -h             Display this message
1908    --version, -v          Display version and copyright info
1909
1910 Default settings modified by devscripts configuration files:
1911 $modified_conf_msg
1912
1913 Valid commands are:
1914 EOF
1915     seek DATA, 0, 0;
1916     while (<DATA>) {
1917         $inlist = 1 if /^=over 4/;
1918         next unless $inlist;
1919         $insublist = 1 if /^=over [^4]/;
1920         $insublist = 0 if /^=back/;
1921         print "\t$1\n" if /^=item\s([^\-].*)/ and ! $insublist;
1922         last if defined $1 and $1 eq 'help';
1923     }
1924 }
1925
1926 # Strips any leading # or Bug# and trailing : from a thing if what's left is
1927 # a pure positive number;
1928 # also RC is a synonym for release-critical/other/all.html
1929 sub sanitizething {
1930     my $bug = $_[0];
1931     defined $bug or return undef;
1932
1933     return 'release-critical/other/all.html' if $bug eq 'RC';
1934     return 'release-critical/index.html' if $bug eq 'release-critical';
1935     $bug =~ s/^(?:(?:Bug)?\#)?(\d+):?$/$1/;
1936     return $bug;
1937 }
1938
1939 # Validate a bug number. Strips out extraneous leading junk, allowing
1940 # for things like "#74041" and "Bug#94921"
1941 sub checkbug {
1942     my $bug=$_[0] or return "";
1943     my $quiet=$_[1] || 0;  # used when we don't want warnings from checkbug
1944
1945     if ($bug eq 'it') {
1946         if (not defined $it) {
1947             die "bts: You specified 'it', but no previous bug number referenced!\n";
1948         }
1949     } else {    
1950         $bug=~s/^(?:(?:bug)?\#)?(-?\d+):?$/$1/i;
1951         if (! exists $clonedbugs{$bug} &&
1952            (! length $bug || $bug !~ /^[0-9]+$/)) {
1953             warn "\"$_[0]\" does not look like a bug number\n" unless $quiet;
1954             return "";
1955         }
1956
1957         # Valid, now set $it to this so that we can refer to it by 'it' later
1958         $it = $bug;
1959     }
1960
1961     $ccbugs{$it} = 1 if ! exists $clonedbugs{$it} &&
1962         ! (grep /^\Q$command[$index]\E/, @no_cc_commands);
1963
1964     return $it;
1965 }
1966
1967 # Stores up some extra information for a mail to the bts.
1968 sub mailbts {
1969     if ($subject eq '') {
1970         $subject = $_[0];
1971     }
1972     elsif (length($subject) + length($_[0]) < 100) {
1973         $subject .= ", $_[0]";
1974     }
1975     else {
1976         $subject .= " ...";
1977     }
1978     $body .= "$comment[$index]\n" if $comment[$index];
1979     $body .= "$_[1]\n";
1980 }
1981
1982 # Extract an array of email addresses from a string
1983 sub extract_addresses {
1984         my $s = shift;
1985         my @addresses;
1986
1987         # Original regular expression from git-send-email, slightly modified
1988         while ($s =~ /([^,<>"\s\@]+\@[^.,<>"\s@]+(?:\.[^.,<>"\s\@]+)+)(.*)/) {
1989             push @addresses, $1;
1990             $s = $2;
1991         }
1992         return @addresses;
1993 }
1994
1995 # Send one full mail message using the smtphost or sendmail.
1996 sub send_mail {
1997     my ($from, $to, $cc, $subject, $body) = @_;
1998
1999     my @fromaddresses = extract_addresses($from);
2000     my $fromaddress = $fromaddresses[0];
2001     # Message-ID algorithm from git-send-email
2002     my $msgid = sprintf("%s-%s", time(), int(rand(4200)))."-bts-$fromaddress";
2003     my $date = `date -R`;
2004     chomp $date;
2005
2006     my $message = fold_from_header("From: $from") . "\n";
2007     $message   .= "To: $to\n" if length $to;
2008     $message   .= "Cc: $cc\n" if length $cc;
2009     $message   .= "Subject: $subject\n"
2010                .  "Date: $date\n"
2011                .  "X-BTS-Version: $version\n"
2012                .  "Message-ID: <$msgid>\n"
2013                .  "\n"
2014                .  "# Automatically generated email from bts,"
2015                   . " devscripts version $version\n"
2016                .  "$body\n";
2017
2018     if ($noaction) {
2019         print "$message\n";
2020     }
2021     elsif (length $smtphost) {
2022         my $smtp = Net::SMTP->new($smtphost)
2023             or die "bts: failed to open SMTP connection to $smtphost\n";
2024         $smtp->mail($fromaddress)
2025             or die "bts: failed to set SMTP from address $fromaddress\n";
2026         my @addresses = extract_addresses($to);
2027         push @addresses, extract_addresses($cc);
2028         foreach my $address (@addresses) {
2029             $smtp->recipient($address)
2030                 or die "bts: failed to set SMTP recipient $address\n";
2031         }
2032         $smtp->data($message)
2033             or die "bts: failed to send message as SMTP DATA\n";
2034         $smtp->quit
2035             or die "bts: failed to quit SMTP connection\n";
2036     }
2037     else {
2038         my $pid = open(MAIL, "|-");
2039         if (! defined $pid) {
2040             die "bts: Couldn't fork: $!\n";
2041         }
2042         $SIG{'PIPE'} = sub { die "bts: pipe for $sendmailcmd broke\n"; };
2043         if ($pid) {
2044             # parent
2045             print MAIL $message;
2046             close MAIL or die "bts: sendmail error: $!\n";
2047         }
2048         else {
2049             # child
2050             if ($debug) {
2051                 exec("/bin/cat")
2052                     or die "bts: error running cat: $!\n";
2053             } else {
2054                 my @mailcmd = split ' ', $sendmailcmd;
2055                 push @mailcmd, "-t" if $sendmailcmd =~ /$sendmail_t/;
2056                 exec @mailcmd
2057                     or die "bts: error running sendmail: $!\n";
2058             }
2059         }
2060     }
2061 }
2062
2063 # Sends all cached mail to the bts (duh).
2064 sub mailbtsall {
2065     my $subject=shift;
2066     my $body=shift;
2067
2068     # If there were comments, we CC each of the bugs
2069     if (keys %ccbugs && length(join('', @comment))) {
2070         $ccemail .= ", " if length $ccemail;
2071         $ccemail .= join("\@$btsserver, ", sort (keys %ccbugs)) . "\@$btsserver";
2072     }
2073     if ($ENV{'DEBEMAIL'} || $ENV{'EMAIL'}) {
2074         # We need to fake the From: line
2075         my ($email, $name);
2076         if (exists $ENV{'DEBFULLNAME'}) { $name = $ENV{'DEBFULLNAME'}; }
2077         if (exists $ENV{'DEBEMAIL'}) {
2078             $email = $ENV{'DEBEMAIL'};
2079             if ($email =~ /^(.*?)\s+<(.*)>\s*$/) {
2080                 $name ||= $1;
2081                 $email = $2;
2082             }
2083         }
2084         if (exists $ENV{'EMAIL'}) {
2085             if ($ENV{'EMAIL'} =~ /^(.*?)\s+<(.*)>\s*$/) {
2086                 $name ||= $1;
2087                 $email ||= $2;
2088             } else {
2089                 $email ||= $ENV{'EMAIL'};
2090             }
2091         }
2092         if (! $name) {
2093             # Perhaps not ideal, but it will have to do
2094             $name = (getpwuid($<))[6];
2095             $name =~ s/,.*//;
2096         }
2097         my $from = $name ? "$name <$email>" : $email;
2098         my $charset = `locale charmap`;
2099         chomp $charset;
2100         $charset =~ s/^ANSI_X3\.4-19(68|86)$/US-ASCII/;
2101         $from = MIME_encode_mimewords($from, 'Charset' => $charset);
2102
2103         if ($ccsecurity) {
2104             my $comma = "";
2105             if ($ccemail) {
2106                     $comma = ", ";
2107             }
2108             $ccemail = "$ccemail$comma$ccsecurity";
2109         }
2110
2111         send_mail($from, $btsemail, $ccemail, $subject, $body);
2112     }
2113     else {  # No DEBEMAIL
2114         unless (system("command -v mail >/dev/null 2>&1") == 0) {
2115             die "bts: You need to either set DEBEMAIL or have the mailx/mailutils package\ninstalled to send mail!\n";
2116         }
2117         my $pid = open(MAIL, "|-");
2118         if (! defined $pid) {
2119             die "bts: Couldn't fork: $!\n";
2120         }
2121         $SIG{'PIPE'} = sub { die "bts: pipe for mail broke\n"; };
2122         if ($pid) {
2123             # parent
2124             print MAIL "# Automatically generated email from bts, devscripts version $version\n";
2125             print MAIL $body;
2126             close MAIL or die "bts: mail: $!\n";
2127         }
2128         else {
2129             # child
2130             if ($debug) {
2131                 exec("/bin/cat")
2132                     or die "bts: error running cat: $!\n";
2133             } else {
2134                 my @args;
2135                 @args = ("-s", $subject, "-a", "X-BTS-Version: $version", $btsemail);
2136                 push(@args, "-c", "$ccemail") if $ccemail;
2137                 push(@args, "-c", "$ccsecurity") if $ccsecurity;
2138                 exec("mail", @args) or die "bts: error running mail: $!\n";
2139             }
2140         }
2141     }
2142 }
2143
2144 # A simplified version of mailbtsall which sends one message only to
2145 # a specified address using the specified email From: header
2146 sub mailto {
2147     my ($subject, $body, $to, $from) = @_;
2148
2149     if (defined $from) {
2150         send_mail($from, $to, '', $subject, $body);
2151     }
2152     else {  # No $from
2153         unless (system("command -v mail >/dev/null 2>&1") == 0) {
2154             die "bts: You need to either specify an email address (say using DEBEMAIL)\n or have the mailx/mailutils package installed to send mail!\n";
2155         }
2156         my $pid = open(MAIL, "|-");
2157         if (! defined $pid) {
2158             die "bts: Couldn't fork: $!\n";
2159         }
2160         $SIG{'PIPE'} = sub { die "bts: pipe for mail broke\n"; };
2161         if ($pid) {
2162             # parent
2163             print MAIL $body;
2164             close MAIL or die "bts: mail: $!\n";
2165         }
2166         else {
2167             # child
2168             if ($debug) {
2169                 exec("/bin/cat")
2170                     or die "bts: error running cat: $!\n";
2171             } else {
2172                 exec("mail", "-s", $subject, $to)
2173                     or die "bts: error running mail: $!\n";
2174             }
2175         }
2176     }
2177 }
2178
2179 # The following routines are taken from a patched version of MIME::Words
2180 # posted at http://mail.nl.linux.org/linux-utf8/2002-01/msg00242.html
2181 # by Richard =?utf-8?B?xIxlcGFz?= (Chepas) <rch@richard.eu.org>
2182
2183 sub MIME_encode_B {
2184     my $str = shift;
2185     require MIME::Base64;
2186     encode_base64($str, '');
2187 }
2188
2189 sub MIME_encode_Q {
2190     my $str = shift;
2191     $str =~ s{([_\?\=\015\012\t $NONPRINT])}{$1 eq ' ' ? '_' : sprintf("=%02X", ord($1))}eog;  # RFC-2047, Q rule 3
2192     $str;
2193 }
2194
2195 sub MIME_encode_mimeword {
2196     my $word = shift;
2197     my $encoding = uc(shift || 'Q');
2198     my $charset  = uc(shift || 'ISO-8859-1');
2199     my $encfunc  = (($encoding eq 'Q') ? \&MIME_encode_Q : \&MIME_encode_B);
2200     "=?$charset?$encoding?" . &$encfunc($word) . "?=";
2201 }
2202
2203 sub MIME_encode_mimewords {
2204     my ($rawstr, %params) = @_;
2205     # check if we have something to encode
2206     $rawstr !~ /[$NONPRINT]/o and $rawstr !~ /\=\?/o and return $rawstr;
2207     my $charset  = $params{Charset} || 'ISO-8859-1';
2208     # if there is 1/3 unsafe bytes, the Q encoded string will be 1.66 times
2209     # longer and B encoded string will be 1.33 times longer than original one
2210     my $encoding = lc($params{Encoding} ||
2211        (length($rawstr) > 3*($rawstr =~ tr/[\x00-\x1F\x7F-\xFF]//) ? 'q':'b'));
2212
2213     # Encode any "words" with unsafe bytes.
2214     my ($last_token, $last_word_encoded, $token) = ('', 0);
2215     $rawstr =~ s{([^\015\012\t ]+|[\015\012\t ]+)}{     # get next "word"
2216         $token = $1;
2217         if ($token =~ /[\015\012\t ]+/) {  # white-space
2218             $last_token = $token;
2219         } else {
2220             if ($token !~ /[$NONPRINT]/o and $token !~ /\=\?/o) { 
2221                 # no unsafe bytes, leave as it is
2222                 $last_word_encoded = 0;
2223                 $last_token = $token;
2224             } else {
2225                 # has unsafe bytes, encode to one or more encoded words
2226                 # white-space between two encoded words is skipped on
2227                 # decoding, so we should encode space in that case
2228                 $_ = $last_token =~ /[\015\012\t ]+/ && $last_word_encoded ? $last_token.$token : $token;
2229                 # We limit such words to about 18 bytes, to guarantee that the 
2230                 # worst-case encoding give us no more than 54 + ~10 < 75 bytes
2231                 s{(.{1,15}[\x80-\xBF]{0,4})}{
2232                     # don't split multibyte characters - this regexp should
2233                     # work for UTF-8 characters
2234                     MIME_encode_mimeword($1, $encoding, $charset).' ';
2235                 }sxeg;
2236                 $_ = substr($_, 0, -1); # remove trailing space
2237                 $last_word_encoded = 1;
2238                 $last_token = $token;
2239                 $_;
2240             }
2241         }
2242     }sxeg;
2243     $rawstr;
2244 }
2245
2246 # This is a stripped-down version of Mail::Header::_fold_line, but is
2247 # not as general-purpose as the original, so take care if using it elsewhere!
2248 # The heuristics are changed to prevent splitting in the middle of an
2249 # encoded word; we should not have any commas or semicolons!
2250 sub fold_from_header {
2251     my $header = shift;
2252     chomp $header;  # We assume there wasn't a newline anyhow
2253
2254     my $maxlen = 76;
2255     my $max = int($maxlen - 5);         # 4 for leading spcs + 1 for [\,\;]
2256
2257     if(length($header) > $maxlen) {
2258         # Split the line up:
2259         # first split at a whitespace,
2260         # else we are looking at a single word and we won't try to split
2261         # it, even though we really ought to
2262         # But this could only happen if someone deliberately uses a really
2263         # long name with no spaces in it.
2264         my @x;
2265         
2266         push @x, $1
2267             while($header =~ s/^\s*
2268                   ([^\"]{1,$max}\s
2269                    |[^\s\"]*(?:\"[^\"]*\"[ \t]?[^\s\"]*)+\s
2270                    |[^\s\"]+\s
2271                    )
2272                   //x);
2273         push @x, $header;
2274         map { s/\s*$// } @x;
2275         if (@x > 1 and length($x[-1]) + length($x[-2]) < $max) {
2276             $x[-2] .= " $x[-1]";
2277             pop @x;
2278         }
2279         $x[0] =~ s/^\s*//;
2280         $header = join("\n  ", @x);
2281     }
2282
2283     $header =~ s/^(\S+)\n\s*(?=\S)/$1 /so;
2284     return $header;
2285 }
2286
2287 # Given mail headers as a raw string, parses them and return a hash mapping
2288 # (lowercase) header names to header values; handles properly (?) RFC822 line
2289 # continuation.
2290 sub parse_rfc822_headers {
2291   my ($raw) = @_;
2292   my %headers;
2293   my $key = ""; # remember last seen header name
2294   foreach my $line (split /\r?\n/, $raw) {
2295     if ($line =~ /^([^:]+):\s+(.*)$/) { # 1st header field
2296       my $key = lc $1;
2297       $headers{$key} = $2;
2298     } elsif ($line =~ /^\s+(.*)/ ) { # header field continuation
2299       $headers{$key} .= " $1";
2300     }
2301   }
2302   return %headers;
2303 }
2304
2305 ##########  Browsing and caching subroutines
2306
2307 # Mirrors a given thing; if the online version is no newer than our
2308 # cached version, then returns an empty string, otherwise returns the
2309 # live thing as a (non-empty) string
2310 sub download {
2311     my $thing=shift;
2312     my $thgopts=shift ||'';
2313     my $manual=shift;  # true="bts cache", false="bts show/bug"
2314     my $mboxing=shift;  # true="bts --mbox show/bugs", and only if $manual=0
2315     my $bug_current=shift;  # current bug being downloaded if caching
2316     my $bug_total=shift;    # total things to download if caching
2317     my $timestamp = 0;
2318     my $versionstamp = '';
2319     my $url;
2320
2321     my $oldcwd = getcwd;
2322
2323     # What URL are we to download?
2324     if ($thgopts ne '') {
2325         # have to be intelligent here :/
2326         $url = thing_to_url($thing) . $thgopts;
2327     } else {
2328         # let the BTS be intelligent
2329         $url = "$btsurl$thing";
2330     }
2331
2332     if (! -d $cachedir) {
2333         die "bts: download() called but no cachedir!\n";
2334     }
2335
2336     chdir($cachedir) || die "bts: chdir $cachedir: $!\n";
2337
2338     if (-f cachefile($thing, $thgopts)) {
2339         ($timestamp, $versionstamp) = get_timestamp($thing, $thgopts);
2340         $timestamp ||= 0;
2341         $versionstamp ||= 0;
2342         # And ensure we preserve any manual setting
2343         if (is_manual($timestamp)) { $manual = 1; }
2344     }
2345
2346     # do we actually have to do more than we might have thought?
2347     # yes, if we've caching with --cache-mode=mbox or full and the bug had
2348     # previously been cached in a less thorough format
2349     my $forcedownload = 0;
2350     if ($thing =~ /^\d+$/ and ! $refreshmode) {
2351         if (old_cache_format_version($versionstamp)) {
2352             $forcedownload = 1;
2353         } elsif ($cachemode ne 'min' or $mboxing) {
2354             if (! -r mboxfile($thing)) {
2355                 $forcedownload = 1;
2356             } elsif ($cachemode eq 'full' and -d $thing) {
2357                 opendir DIR, $thing or die "bts: opendir $cachedir/$thing: $!\n";
2358                 my @htmlfiles = grep { /^\d+\.html$/ } readdir(DIR);
2359                 closedir DIR;
2360                 $forcedownload = 1 unless @htmlfiles;
2361             }
2362         }
2363     }
2364
2365     print "Downloading $url ... "
2366         if ! $quiet and $manual and $thing ne "css/bugs.css";
2367     IO::Handle::flush(\*STDOUT);
2368     my ($ret, $msg, $livepage) = bts_mirror($url, $timestamp, $forcedownload);
2369     if ($ret == MIRROR_UP_TO_DATE) {
2370         # we have an up-to-date version already, nothing to do
2371         # and $timestamp is guaranteed to be well-defined
2372         if (is_automatic($timestamp) and $manual) {
2373             set_timestamp($thing, $thgopts, make_manual($timestamp), $versionstamp);
2374         }
2375
2376         if (! $quiet and $manual and $thing ne "css/bugs.css") {
2377             print "(cache already up-to-date) ";
2378             print "$bug_current/$bug_total" if $bug_total;
2379             print "\n";
2380         }
2381         chdir $oldcwd or die "bts: chdir $oldcwd failed: $!\n";
2382         return "";
2383     }
2384     elsif ($ret == MIRROR_DOWNLOADED) {
2385         # Note the current timestamp, but don't record it until
2386         # we've successfully stashed the data away
2387         $timestamp = time;
2388
2389         die "bts: empty page downloaded\n" unless length $livepage;
2390
2391         my $bug2filename = { };
2392
2393         if ($thing =~ /^\d+$/) {
2394             # we've downloaded an individual bug, and it's been updated,
2395             # so we need to also download all the attachments
2396             $bug2filename =
2397                 download_attachments($thing, $livepage, $timestamp);
2398         }
2399
2400         my $data = $livepage;  # work on a copy, not the original
2401         my $cachefile=cachefile($thing,$thgopts);
2402         open (OUT_CACHE, ">$cachefile") or die "bts: open $cachefile: $!\n";
2403
2404         $data = mangle_cache_file($data, $thing, $bug2filename, $timestamp);
2405         print OUT_CACHE $data;
2406         close OUT_CACHE or die "bts: problems writing to $cachefile: $!\n";
2407
2408         set_timestamp($thing, $thgopts,
2409             $manual ? make_manual($timestamp) : make_automatic($timestamp),
2410             $version);
2411
2412         if (! $quiet and $manual and $thing ne "css/bugs.css") {
2413             print "(cached new version) ";
2414             print "$bug_current/$bug_total" if $bug_total;
2415             print "\n";
2416         } elsif ($quiet == 1 and $manual and $thing ne "css/bugs.css") {
2417             print "Downloading $url ... (cached new version)\n";
2418         } elsif ($quiet > 1) {
2419             # do nothing
2420         }
2421
2422         # Add a <base> tag to the live page content, so that relative urls
2423         # in it work when it's passed to the web browser.
2424         my $base=$url;
2425         $base=~s%/[^/]*$%%;
2426         $livepage=~s%<head>%<head><base href="$base">%i;
2427
2428         chdir $oldcwd or die "bts: chdir $oldcwd failed: $!\n";
2429         return $livepage;
2430     } else {
2431         die "bts: couldn't download $url:\n$msg\n";
2432     }
2433 }
2434
2435 sub download_attachments {
2436     my ($thing, $toppage, $timestamp) = @_;
2437     my %bug2filename;
2438
2439     # We search for appropriate strings in the top page, and save the
2440     # attachments in files with names as follows:
2441     # - if the attachment specifies a filename, save as bug#/msg#-att#/filename
2442     # - if not, save as bug#/msg#-att# with suffix .txt if plain/text and
2443     #   .html if plain/html, no suffix otherwise (too much like hard work!)
2444     # Since messages are never modified retrospectively, we don't download
2445     # attachments which have already been downloaded
2446     
2447     # Yuck, yuck, yuck.  This regex splits the $data string at every
2448     # occurrence of either "[<a " or plain "<a ", preserving any "[".
2449     my @data = split /(?:(?=\[<[Aa]\s)|(?<!\[)(?=<[Aa]\s))/, $toppage;
2450     foreach (@data) {
2451         next unless m%<a(?: class=\".*?\")? href="(?:/cgi-bin/)?((bugreport\.cgi[^\"]+)">|(version\.cgi[^\"]+)"><img[^>]* src="(?:/cgi-bin/)?([^\"]+)">|(version\.cgi[^\"]+)">)%i;
2452
2453         my $ref = $5;
2454         $ref = $4 if not defined $ref;
2455         $ref = $2 if not defined $ref;
2456
2457         my ($msg, $filename) = href_to_filename($_);
2458
2459         next unless defined $msg;
2460
2461         if ($msg =~ /^\d+-\d+$/) {
2462             # it's an attachment, must download
2463             $bug2filename{$msg} = $filename;
2464             # already downloaded?
2465             next if -f $bug2filename{$msg} and not $refreshmode;
2466         }
2467         elsif ($cachemode eq 'full' and $msg =~ /^\d+$/) {
2468             $bug2filename{$msg} = $filename;
2469             # already downloaded?
2470             next if -f $bug2filename{$msg} and not $refreshmode;
2471         }
2472         elsif ($cachemode eq 'full' and $msg =~ /^\d+-mbox$/) {
2473             $bug2filename{$msg} = $filename;
2474             # already downloaded?
2475             next if -f $bug2filename{$msg} and not $refreshmode;
2476         }
2477         elsif (($cachemode eq 'full' or $cachemode eq 'mbox' or $mboxmode) and
2478                $msg eq 'mbox') {
2479             $bug2filename{$msg} = $filename;
2480             # This always needs refreshing, as it does change as the bug
2481             # changes
2482         }
2483         elsif ($cachemode eq 'full' and $msg =~ /^(status|raw)mbox$/) {
2484             $bug2filename{$msg} = $filename;
2485             # Always need refreshing, as they could change each time the
2486             # bug does
2487         }
2488         elsif ($cachemode eq 'full' and $msg eq 'versions') {
2489             $bug2filename{$msg} = $filename;
2490             $ref =~ s%;info=1%;info=0%;
2491             # already downloaded?
2492             next if -f $bug2filename{$msg} and not $refreshmode;
2493         }
2494
2495         next unless exists $bug2filename{$msg};
2496
2497         warn "bts debug: downloading $btscgiurl$ref\n" if $debug;
2498         init_agent() unless $ua;  # shouldn't be necessary, but do just in case
2499         my $request = HTTP::Request->new('GET', $btscgiurl . $ref);
2500         my $response = $ua->request($request);
2501         if ($response->is_success) {
2502             my $content_length = defined $response->content ?
2503                 length($response->content) : 0;
2504             if ($content_length == 0) {
2505                 warn "bts: failed to download $ref, skipping\n";
2506                 next;
2507             }
2508
2509             my $data = $response->content;
2510
2511             if ($msg =~ /^\d+$/) {
2512                 # we're dealing with a boring message, and so we must be
2513                 # in 'full' mode
2514                 $data =~ s%<HEAD>%<HEAD><BASE href="../">%;
2515                 $data = mangle_cache_file($data, $thing, 'full', $timestamp);
2516             }
2517             mkpath(dirname $bug2filename{$msg});
2518             open OUT_CACHE, ">$bug2filename{$msg}"
2519                 or die "bts: open cache $bug2filename{$msg}\n";
2520             print OUT_CACHE $data;
2521             close OUT_CACHE;
2522         } else {
2523             warn "bts: failed to download $ref, skipping\n";
2524             next;
2525         }
2526     }
2527
2528     return \%bug2filename;
2529 }
2530
2531
2532 # Download the mailbox for a given bug, return mbox ($fh, filename) on success,
2533 # die on failure
2534 sub download_mbox {
2535     my $thing = shift;
2536     my $temp = shift;  # do we wish to store it in cache or in a temp file?
2537     my $mboxfile = mboxfile($thing);
2538
2539     die "bts: trying to download mbox for illegal bug number $thing.\n"
2540         unless $mboxfile;
2541
2542     if (! have_lwp()) {
2543         die "bts: couldn't run bts --mbox: $lwp_broken\n";
2544     }
2545     init_agent() unless $ua;
2546
2547     my $request = HTTP::Request->new('GET', $btscgiurl . "bugreport.cgi?bug=$thing;mboxmaint=yes");
2548     my $response = $ua->request($request);
2549     if ($response->is_success) {
2550         my $content_length = defined $response->content ?
2551             length($response->content) : 0;
2552         if ($content_length == 0) {
2553             die "bts: failed to download mbox.\n";
2554         }
2555
2556         my ($fh, $filename);
2557         if ($temp) {
2558             ($fh,$filename) = tempfile("btsXXXXXX",
2559                                        SUFFIX => ".mbox",
2560                                        DIR => File::Spec->tmpdir,
2561                                        UNLINK => 1);
2562             # Use filehandle for security
2563             open (OUT_MBOX, ">/dev/fd/" . fileno($fh))
2564                 or die "bts: writing to temporary file: $!\n";
2565         } else {
2566             $filename = $mboxfile;
2567             open (OUT_MBOX, ">$mboxfile")
2568                 or die "bts: writing to mbox file $mboxfile: $!\n";
2569         }
2570         print OUT_MBOX $response->content;
2571         close OUT_MBOX;
2572             
2573         return ($fh, $filename);
2574     } else {
2575         die "bts: failed to download mbox.\n";
2576     }
2577 }
2578
2579
2580 # Mangle downloaded file to work in the local cache, so
2581 # selectively modify the links
2582 sub mangle_cache_file {
2583     my ($data, $thing, $bug2filename, $timestamp) = @_;
2584     my $fullmode = ! ref $bug2filename;
2585
2586     # Undo unnecessary '+' encoding in URLs
2587     while ($data =~ s!(href=\"[^\"]*)\%2b!$1+!ig) { };
2588     my $time=localtime(abs($timestamp));
2589     $data =~ s%(<BODY.*>)%$1<p><em>[Locally cached on $time by devscripts version $version]</em></p>%i;
2590     $data =~ s%href="/css/bugs.css"%href="bugs.css"%;
2591
2592     my @data;
2593     # We have to distinguish between release-critical pages and normal BTS
2594     # pages as they have a different structure
2595     if ($thing =~ /^release-critical/) {
2596         @data = split /(?=<[Aa])/, $data;
2597         foreach (@data) {
2598             s%<a href="(http://bugs.debian.org/cgi-bin/bugreport\.cgi.*bug=(\d+)[^\"]*)">(.+?)</a>%<a href="$2.html">$3</a> (<a href="$1">online</a>)%i;
2599             s%<a href="(http://bugs.debian.org/cgi-bin/pkgreport\.cgi.*pkg=([^\"&;]+)[^\"]*)">(.+?)</a>%<a href="$2.html">$3</a> (<a href="$1">online</a>)%i;
2600             # References to other bug lists on bugs.d.o/release-critical
2601             if (m%<a href="((?:debian|other)[-a-z/]+\.html)"%i) {
2602                 my $ref = 'release-critical/'.$1;
2603                 $ref =~ s%/%_%g;
2604                 s%<a href="((?:debian|other)[-a-z/]+\.html)">(.+?)</a>%<a href="$ref">$2</a> (<a href="${btsurl}release-critical/$1">online</a>)%i;
2605             }
2606             # Maintainer email address - YUCK!!
2607             s%<a href="(http://bugs.debian.org/([^\"?]*\@[^\"?]*))">(.+?)</a>&gt;%<a href="$2.html">$3</a>&gt; (<a href="$1">online</a>)%i;
2608             # Graph - we don't download
2609             s%<img src="graph.png" alt="Graph of RC bugs">%<img src="${btsurl}release-critical/graph.png" alt="Graph of RC bugs (online)">%
2610         }
2611     } else {
2612         # Yuck, yuck, yuck.  This regex splits the $data string at every
2613         # occurrence of either "[<a " or plain "<a ", preserving any "[".
2614         @data = split /(?:(?=\[<[Aa]\s)|(?<!\[)(?=<[Aa]\s))/, $data;
2615         foreach (@data) {
2616             if (m%<a(?: class=\".*?\")? href=\"(?:/cgi-bin/)?bugreport\.cgi[^\?]*\?.*?;?bug=(\d+)%i) {
2617                 my $bug = $1;
2618                 my ($msg, $filename) = href_to_filename($_);
2619                 if ($bug eq $thing and defined $msg) {
2620                     if ($fullmode or
2621                         (! $fullmode and exists $$bug2filename{$msg})) {
2622                         s%<a((?: class=\".*?\")?) href="(?:/cgi-bin/)?(bugreport\.cgi[^\"]*)">(.+?)</a>%<a$1 href="$filename">$3</a> (<a$1 href="$btscgiurl$2">online</a>)%i;
2623                     } else {
2624                         s%<a((?: class=\".*?\")?) href="(?:/cgi-bin/)?(bugreport\.cgi[^\"]*)">(.+?)</a>%$3 (<a$1 href="$btscgiurl$2">online</a>)%i;
2625                     }
2626                 } else {
2627                     s%<a((?: class=\".*?\")?) href="(?:/cgi-bin/)?(bugreport\.cgi[^\?]*\?.*?bug=(\d+))">(.+?)</a>%<a$1 href="$3.html">$4</a> (<a$1 href="$btscgiurl$2">online</a>)%i;
2628                 }
2629             }
2630             else {
2631                 s%<a((?: class=\".*?\")?) href="(?:/cgi-bin/)(pkgreport\.cgi\?(?:pkg|maint)=([^\"&;]+)[^\"]*)">(.+?)</a>%<a$1 href="$3.html">$4</a> (<a$1 href="$btscgiurl$2">online</a>)%i;
2632                 s%<a((?: class=\".*?\")?) href="(?:/cgi-bin/)?(pkgreport\.cgi\?src=([^\"&;]+)[^\"]*)">(.+?)</a>%<a$1 href="src_$3.html">$4</a> (<a$1 href="$btscgiurl$2">online</a>)%i;
2633                 s%<a((?: class=\".*?\")?) href="(?:/cgi-bin/)?(pkgreport\.cgi\?submitter=([^\"&;]+)[^\"]*)">(.+?)</a>%<a$1 href="from_$3.html">$4</a> (<a$1 href="$btscgiurl$2">online</a>)%i;
2634                 s%<a((?: class=\".*?\")?) href="(?:/cgi-bin/)?(pkgreport\.cgi\?.*?;?archive=([^\"&;]+);submitter=([^\"&;]+)[^\"]*)">(.+?)</a>%<a$1 href="from_$4_3Barchive_3D$3.html">$5</a> (<a$1 href="$btscgiurl$2">online</a>)%i;
2635                 s%<a((?: class=\".*?\")?) href="(?:/cgi-bin/)?(pkgreport\.cgi\?.*?;?package=([^\"&;]+)[^\"]*)">(.+?)</a>%<a$1 href="$3.html">$4</a> (<a$1 href="$btscgiurl$2">online</a>)%i;
2636                 s%<a((?: class=\".*?\")?) href="(?:/cgi-bin/)?(bugspam\.cgi[^\"]+)">%<a$1 href="$btscgiurl$2">%i;
2637                 s%<a((?: class=\".*?\")?) href="/([0-9]+?)">(.+?)</a>%<a$1 href="$2.html">$3</a> (<a$1 href="$btsurl$2">online</a>)%i;
2638
2639                 # Version graphs
2640                 # - remove 'package='
2641                 s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi-bin/)?version\.cgi\?)package=([^;]+)(;[^\"]+)\">%$1$2$3">%gi;
2642                 # - replace ';found=' with '.f.' and ';fixed=' with '.fx.'
2643                 1 while s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi-bin/)?version\.cgi\?[^;]*);found=([^\"]+)\">%$1.f.$2">%gi;
2644                 1 while s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi-bin/)?version\.cgi\?[^;]*);fixed=([^\"]+)\">%$1.fx.$2">%gi;
2645                 # - replace '%2F' or '%2C' (a URL-encoded / or ,) with '.'
2646                 1 while s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi-bin/)?version\.cgi\?[^\%]*)\%2[FC]([^\"]+)\">%$1.$2">%gi;
2647                 # - display collapsed graph images at 25%
2648                 s%(<img[^>]* src=\"[^\"]+);width=[^;]+;height=[^;]+;collapse=1\">%$1.co" width="25\%" height="25\%">%gi;
2649                 # - remove ;info=1
2650                 s%(<a[^>]* href=\"(?:/cgi-bin/)?version\.cgi\?[^\"]+);info=1">%$1">%i;
2651                 # - remove any +s (encoded spaces)
2652                 1 while s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi-bin/)?version\.cgi\?[^\+]*)\+([^\"]+)\">%$1$2">%gi;
2653                 # - final reference should be $package.$versions[.co].png
2654                 s%(<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi-bin/)?version\.cgi\?([^\"]+)(\"[^>]*)>%$1$2.png$3>%gi;
2655             }
2656         }
2657     }
2658
2659     return join("", @data);
2660 }
2661
2662
2663 # Removes a specified thing from the cache
2664 sub deletecache {
2665     my $thing=shift;
2666     my $thgopts=shift || '';
2667
2668     if (! -d $cachedir) {
2669         die "bts: deletecache() called but no cachedir!\n";
2670     }
2671
2672     delete_timestamp($thing,$thgopts);
2673     unlink cachefile($thing,$thgopts);
2674     if ($thing =~ /^\d+$/) {
2675         rmtree("$cachedir/$thing", 0, 1) if -d "$cachedir/$thing";
2676         unlink("$cachedir/$thing.mbox") if -f "$cachedir/$thing.mbox";
2677         unlink("$cachedir/$thing.status.mbox") if -f "$cachedir/$thing.status.mbox";
2678         unlink("$cachedir/$thing.raw.mbox") if -f "$cachedir/$thing.raw.mbox";
2679     }
2680 }
2681
2682 # Given a thing, returns the filename for it in the cache.
2683 sub cachefile {
2684     my $thing=shift;
2685     my $thgopts=shift || '';
2686     if ($thing eq '') { die "bts: cachefile given empty argument\n"; }
2687     if ($thing =~ /bugs.css$/) { return $cachedir."bugs.css" }
2688     $thing =~ s/^src:/src_/;
2689     $thing =~ s/^from:/from_/;
2690     $thing =~ s/^tag:/tag_/;
2691     $thing =~ s/^usertag:/usertag_/;
2692     $thing =~ s%^release-critical/index\.html$%release-critical.html%;
2693     $thing =~ s%/%_%g;
2694     $thgopts =~ s/;/_3B/g;
2695     $thgopts =~ s/=/_3D/g;
2696     return $cachedir.$thing.$thgopts.($thing =~ /\.html$/ ? "" : ".html");
2697 }
2698
2699 # Given a thing, returns the filename for its mbox in the cache.
2700 sub mboxfile {
2701     my $thing=shift;
2702     return $thing =~ /^\d+$/ ? $cachedir.$thing.".mbox" : undef;
2703 }
2704
2705 # Given a bug number, returns the dirname for it in the cache.
2706 sub cachebugdir {
2707     my $thing=shift;
2708     if ($thing !~ /^\d+$/) { die "bts: cachebugdir given faulty argument: $thing\n"; }
2709     return $cachedir.$thing;
2710 }
2711
2712 # And the reverse: Given a filename in the cache, returns the corresponding
2713 # "thing".
2714 sub cachefile_to_thing {
2715     my $thing=basename(shift, '.html');
2716     my $thgopts='';
2717     $thing =~ s/^src_/src:/;
2718     $thing =~ s/^from_/from:/;
2719     $thing =~ s/^tag_/tag:/;
2720     $thing =~ s/^usertag_/usertag:/;
2721     $thing =~ s%^release-critical\.html$%release-critical/index\.html%;
2722     $thing =~ s%_%/%g;
2723     $thing =~ s/_3B/;/g;
2724     $thing =~ s/_3D/=/g;
2725     $thing =~ /^(.*?)((?:;.*)?)$/;
2726     ($thing, $thgopts) = ($1, $2);
2727     return ($thing, $thgopts);
2728 }
2729
2730 # Given a thing, gives the official BTS cgi page for it
2731 sub thing_to_url {
2732     my $thing = shift;
2733     my $thingurl;
2734
2735     # have to be intelligent here :/
2736     if ($thing =~ /^\d+$/) {
2737         $thingurl = $btscgibugurl."?bug=".$thing;
2738     } elsif ($thing =~ /^from:/) {
2739         ($thingurl = $thing) =~ s/^from:/submitter=/;
2740         $thingurl = $btscgipkgurl.'?'.$thingurl;
2741     } elsif ($thing =~ /^src:/) {
2742         ($thingurl = $thing) =~ s/^src:/src=/;
2743         $thingurl = $btscgipkgurl.'?'.$thingurl;
2744     } elsif ($thing =~ /^tag:/) {
2745         ($thingurl = $thing) =~ s/^tag:/tag=/;
2746         $thingurl = $btscgipkgurl.'?'.$thingurl;
2747     } elsif ($thing =~ /^usertag:/) {
2748         ($thingurl = $thing) =~ s/^usertag:/usertag=/;
2749         $thingurl = $btscgipkgurl.'?'.$thingurl;
2750     } elsif ($thing =~ m%^release-critical(\.html|/(index\.html)?)?$%) {
2751         $thingurl = $btsurl . 'release-critical/index.html';
2752     } elsif ($thing =~ m%^release-critical/%) {
2753         $thingurl = $btsurl . $thing;
2754     } elsif ($thing =~ /\@/) { # so presume it's a maint request
2755         $thingurl = $btscgipkgurl.'?maint='.$thing;
2756     } else { # it's a package, or had better be...
2757         $thingurl = $btscgipkgurl.'?pkg='.$thing;
2758     }
2759
2760     return $thingurl;
2761 }
2762
2763 # Given a thing, reads all links to bugs from the corresponding cache file
2764 # if there is one, and returns a list of them.
2765 sub bugs_from_thing {
2766     my $thing=shift;
2767     my $thgopts=shift || '';
2768     my $cachefile=cachefile($thing,$thgopts);
2769
2770     if (-f $cachefile) {
2771         local $/;
2772         open (IN, $cachefile) || die "bts: open $cachefile: $!\n";
2773         my $data=<IN>;
2774         close IN;
2775
2776         return $data =~ m!href="(\d+)\.html"!g;
2777     } else {
2778         return ();
2779     }
2780 }
2781
2782 # Given an <a href="bugreport.cgi?...>...</a> string, return a
2783 # msg id and corresponding filename
2784 sub href_to_filename {
2785     my $href = $_[0];
2786     my ($msg, $filename);
2787
2788     if ($href =~ m%\[<a(?: class=\".*?\")? href="(?:/cgi-bin/)?bugreport\.cgi([^\?]*)\?([^\"]*);bug=(\d+)">.*?\(([^,]*), .*?\)\]%) {
2789         # this looks like an attachment; $1 should give the MIME-type
2790         my $urlfilename = $1;
2791         my $ref = $2;
2792         my $bug = $3;
2793         my $mimetype = $4;
2794         $ref =~ s/&(?:amp;)?/;/g;  # normalise all hrefs
2795
2796         return undef unless $ref =~ /msg=(\d+);(filename=[^;]*;)?att=(\d+)/;
2797         $msg = "$1-$3";
2798
2799         my $fileext = '';
2800         if ($urlfilename =~ m%^/%) {
2801             $filename = basename($urlfilename);
2802         } else {
2803             $filename = '';
2804             if ($mimetype eq 'text/plain') { $fileext = '.txt'; }
2805             if ($mimetype eq 'text/html') { $fileext = '.html'; }
2806         }
2807         if (length ($filename)) {
2808             $filename = "$bug/$msg/$filename";
2809         } else {
2810             $filename = "$bug/$msg$fileext";
2811         }
2812     }
2813     elsif ($href =~ m%<a(?: class=\".*?\")? href="(?:/cgi-bin/)?bugreport\.cgi([^\?]*)\?([^"]*);?bug=(\d+).*?">%) {
2814         my $urlfilename = $1;
2815         my $ref = $2;
2816         my $bug = $3;
2817         $ref =~ s/&(?:amp;)?/;/g;  # normalise all hrefs
2818         $ref =~ s/;archive=(yes|no)\b//;
2819         $ref =~ s/%3D/=/g;
2820
2821         if ($ref =~ /msg=(\d+);$/) {
2822             $msg = $1;
2823             $filename = "$bug/$1.html";
2824         }
2825         elsif ($ref =~ /msg=(\d+);mbox=yes;$/) {
2826             $msg = "$1-mbox";
2827             $filename = "$bug/$1.mbox";
2828         }
2829         elsif ($ref =~ /^mbox=yes;$/) {
2830             $msg = 'rawmbox';
2831             $filename = "$bug.raw.mbox";
2832         }
2833         elsif ($ref =~ /mboxstat(us)?=yes/) {
2834             $msg = 'statusmbox';
2835             $filename = "$bug.status.mbox";
2836         }
2837         elsif ($ref =~ /mboxmaint=yes/) {
2838             $msg = 'mbox';
2839             $filename = "$bug.mbox";
2840         }
2841         elsif ($ref eq '') {
2842             return undef;
2843         }
2844         else {
2845             $href =~ s/>.*/>/s;
2846             warn "bts: in href_to_filename: unrecognised BTS URL type: $href\n";
2847             return undef;
2848         }
2849     }
2850     elsif ($href =~ m%<a[^>]* href=\"(?:/cgi-bin/)?version\.cgi([^>]+><img[^>]* src=\"(?:/cgi-bin/)?version\.cgi)?\?([^\"]+)\">%i) {
2851         my $refs = $2;
2852         $refs = $1 if not defined $refs;
2853
2854         $refs =~ s/package=//;
2855         $refs =~ s/;info=1//;
2856         $refs =~ s/;found=/.f./g;
2857         $refs =~ s/;fixed=/.fx./g;
2858         $refs =~ s/%2[FC]/./g;
2859         $refs =~ s/\+//g;
2860         $refs =~ s/;width=[^;]+;height=[^;]+;collapse=1/.co/;
2861
2862         $msg = 'versions';
2863         $filename = "$refs.png";
2864     }
2865     else {
2866         return undef;
2867     }
2868
2869     return ($msg, $filename);
2870 }
2871
2872 # Browses a given thing, with preprocessed list of URL options such as
2873 # ";opt1=val1;opt2=val2" with possible caching if there are no options
2874 sub browse {
2875     prunecache();
2876     my $thing=shift;
2877     my $thgopts=shift || '';
2878     
2879     if ($thing eq '') {
2880         if ($thgopts ne '') {
2881             die "bts: you can only give options for a BTS page if you specify a bug/maint/... .\n";
2882         }
2883         runbrowser($btsurl);
2884         return;
2885     }
2886
2887     my $hascache=-d $cachedir;
2888     my $cachefile=cachefile($thing,$thgopts);
2889     my $mboxfile=mboxfile($thing);
2890     if ($mboxmode and ! $mboxfile) {
2891         die "bts: you can only request a mailbox for a single bug report.\n";
2892     }
2893
2894     # Check that if we're requesting a tag, that it's a valid tag
2895     if (($thing.$thgopts) =~ /(?:^|;)(?:tag|include|exclude)[:=]([^;]*)/) {
2896         unless (exists $valid_tags{$1}) {
2897             die "bts: invalid tag requested: $1\nRecognised tag names are: " . join(" ", @valid_tags) . "\n";
2898         }
2899     }
2900
2901     my $livedownload = 1;
2902     if ($offlinemode) {
2903         $livedownload = 0;
2904         if (! $hascache) {
2905             die "bts: Sorry, you are in offline mode and have no cache.\nRun \"bts cache\" or \"bts show\" to create one.\n";
2906         }
2907         elsif ((! $mboxmode and ! -r $cachefile) or
2908                ($mboxmode and ! -r $mboxfile)) {
2909             die "bts: Sorry, you are in offline mode and that is not cached.\nUse \"bts [--cache-mode=...] cache\" to update the cache.\n";
2910         }
2911         if ($mboxmode) {
2912             runmailreader($mboxfile);
2913         } else {
2914             runbrowser("file://$cachefile");
2915         }
2916     }
2917     # else we're in online mode
2918     elsif ($caching && have_lwp() && $thing ne '') {
2919         if (! $hascache) {
2920             if (! -d dirname($cachedir)) {
2921                 unless (mkdir(dirname($cachedir))) {
2922                     warn "bts: couldn't mkdir ".dirname($cachedir).": $!\n";
2923                     goto LIVE;
2924                 }
2925             }
2926             unless (mkdir($cachedir)) {
2927                 warn "bts: couldn't mkdir $cachedir: $!\n";
2928                 goto LIVE;
2929             }
2930         }
2931
2932         $livedownload = 0;
2933         my $live=download($thing, $thgopts, 0, $mboxmode);
2934         
2935         if ($mboxmode) {
2936             runmailreader($mboxfile);
2937         } else {
2938             if (length($live)) {
2939                 my ($fh,$livefile) = tempfile("btsXXXXXX",
2940                                               SUFFIX => ".html",
2941                                               DIR => File::Spec->tmpdir,
2942                                               UNLINK => 1);
2943
2944                 # Use filehandle for security
2945                 open (OUT_LIVE, ">/dev/fd/" . fileno($fh))
2946                     or die "bts: writing to temporary file: $!\n";
2947                 # Correct relative urls to point to the bts.
2948                 $live =~ s%\shref="(?:/cgi-bin/)?(\w+\.cgi)% href="$btscgiurl$1%g;
2949                 print OUT_LIVE $live;
2950                 # Some browsers don't like unseekable filehandles,
2951                 # so use filename
2952                 runbrowser("file://$livefile");
2953             } else {
2954                 runbrowser("file://$cachefile");
2955             }
2956         }
2957     }
2958
2959  LIVE: # we are not caching; just show it live
2960     if ($livedownload) {
2961         if ($mboxmode) {
2962             # we appear not to be caching; OK, we'll download to a
2963             # temporary file
2964             warn "bts debug: downloading ${btscgiurl}bugreport.cgi?bug=$thing;mbox=yes\n" if $debug;
2965             my ($fh, $fn) = download_mbox($thing, 1);
2966             runmailreader($fn);
2967         } else {
2968             if ($thgopts ne '') {
2969                 my $thingurl = thing_to_url($thing);            
2970                 runbrowser($thingurl.$thgopts);
2971             } else {
2972                 # let the BTS be intelligent
2973                 runbrowser($btsurl.$thing);
2974             }
2975         }
2976     }
2977 }
2978
2979 # Removes all files from the cache which were downloaded automatically
2980 # and have not been accessed for more than 30 days.  We also only run
2981 # this at most once per day for efficiency.
2982
2983 sub prunecache {
2984     return unless -d $cachedir;
2985     return if -f $prunestamp and -M _ < 1;
2986
2987     my $oldcwd = getcwd;
2988
2989     chdir($cachedir) || die "bts: chdir $cachedir: $!\n";
2990
2991     # remove the now-defunct live-download file
2992     unlink "live_download.html";
2993
2994     opendir DIR, '.' or die "bts: opendir $cachedir: $!\n";
2995     my @cachefiles = grep { ! /^\.\.?$/ } readdir(DIR);
2996     closedir DIR;
2997
2998     # Are there any unexpected files lying around?
2999     my @known_files = map { basename($_) } ($timestampdb, $timestampdb.".lock",
3000                                             $prunestamp);
3001
3002     my %weirdfiles = map { $_ => 1 } grep { ! /\.(html|css|png)$/ } @cachefiles;
3003     foreach (@known_files) {
3004         delete $weirdfiles{$_} if exists $weirdfiles{$_};
3005     }
3006     # and bug directories
3007     foreach (@cachefiles) {
3008         if (/^(\d+)\.html$/) {
3009             delete $weirdfiles{$1} if exists $weirdfiles{$1} and -d $1;
3010             delete $weirdfiles{"$1.mbox"}
3011                 if exists $weirdfiles{"$1.mbox"} and -f "$1.mbox";
3012             delete $weirdfiles{"$1.raw.mbox"}
3013                 if exists $weirdfiles{"$1.raw.mbox"} and -f "$1.raw.mbox";
3014             delete $weirdfiles{"$1.status.mbox"}
3015                 if exists $weirdfiles{"$1.status.mbox"} and -f "$1.status.mbox";
3016         }
3017     }
3018
3019     warn "bts: unexpected files/dirs in cache directory $cachedir:\n  " .
3020         join("\n  ", keys %weirdfiles) . "\n"
3021         if keys %weirdfiles;
3022
3023     my @oldfiles;
3024     foreach (@cachefiles) {
3025         next unless /\.(html|css)$/;
3026         push @oldfiles, $_ if -A $_ > 30;
3027     }
3028     
3029     # We now remove the oldfiles if they're automatically downloaded
3030     tie (%timestamp, "Devscripts::DB_File_Lock", $timestampdb,
3031          O_RDWR()|O_CREAT(), 0600, $DB_HASH, "write")
3032         or die "bts: couldn't open DB file $timestampdb for writing: $!\n"
3033         if ! tied %timestamp;
3034
3035     my @unrecognised;
3036     foreach my $oldfile (@oldfiles) {
3037         my ($thing, $thgopts) = cachefile_to_thing($oldfile);
3038         unless (defined get_timestamp($thing, $thgopts)) {
3039             push @unrecognised, $oldfile;
3040             next;
3041         }
3042         next if is_manual(get_timestamp($thing, $thgopts));
3043         
3044         # Otherwise, it's automatic and we purge it
3045         deletecache($thing, $thgopts);
3046     }
3047
3048     untie %timestamp;
3049
3050     if (! -e $prunestamp) {
3051         open PRUNESTAMP, ">$prunestamp" || die "bts: prune timestamp: $!\n";
3052         close PRUNESTAMP;
3053     }
3054     chdir $oldcwd || die "bts: chdir $oldcwd: $!\n";
3055     utime time, time, $prunestamp;
3056 }
3057
3058 # Determines which browser to use
3059 sub runbrowser {
3060     my $URL = shift;
3061     
3062     if (system('sensible-browser', $URL) >> 8 != 0) {
3063         warn "Problem running sensible-browser: $!\n";
3064     }
3065 }
3066
3067 # Determines which mailreader to use
3068 sub runmailreader {
3069     my $file = shift;
3070     my $quotedfile;
3071     die "bts: could not read mbox file!\n" unless -r $file;
3072
3073     if ($file !~ /\'/) { $quotedfile = qq['$file']; }
3074     elsif ($file !~ /[\"\\\$\'\!]/) { $quotedfile = qq["$file"]; }
3075     else { die "bts: could not figure out how to quote the mbox filename \"$file\"\n"; }
3076
3077     my $reader = $mailreader;
3078     $reader =~ s/\%([%s])/$1 eq '%' ? '%' : $quotedfile/eg;
3079
3080     if (system($reader) >> 8 != 0) {
3081         warn "Problem running mail reader: $!\n";
3082     }
3083 }
3084
3085 # Timestamp handling
3086
3087 # We store a +ve timestamp to represent an automatic download and
3088 # a -ve one to represent a manual download.
3089
3090 sub get_timestamp {
3091     my $thing = shift;
3092     my $thgopts = shift || '';
3093     my $timestamp = undef;
3094     my $versionstamp = undef;
3095
3096     if (tied %timestamp) {
3097         ($timestamp, $versionstamp) = split /;/, $timestamp{$thing.$thgopts}
3098             if exists $timestamp{$thing.$thgopts};
3099     } else {
3100         tie (%timestamp, "Devscripts::DB_File_Lock", $timestampdb,
3101              O_RDONLY(), 0600, $DB_HASH, "read")
3102             or die "bts: couldn't open DB file $timestampdb for reading: $!\n";
3103
3104         ($timestamp, $versionstamp) = split /;/, $timestamp{$thing.$thgopts}
3105             if exists $timestamp{$thing.$thgopts};
3106
3107         untie %timestamp;
3108     }
3109
3110     return wantarray ? ($timestamp, $versionstamp) : $timestamp;
3111 }
3112
3113 sub set_timestamp {
3114     my $thing = shift;
3115     my $thgopts = shift || '';
3116     my $timestamp = shift;
3117     my $versionstamp = shift || $version;
3118
3119     if (tied %timestamp) {
3120         $timestamp{$thing.$thgopts} = "$timestamp;$versionstamp";
3121     } else {
3122         tie (%timestamp, "Devscripts::DB_File_Lock", $timestampdb,
3123              O_RDWR()|O_CREAT(), 0600, $DB_HASH, "write")
3124             or die "bts: couldn't open DB file $timestampdb for writing: $!\n";
3125
3126         $timestamp{$thing.$thgopts} = "$timestamp;$versionstamp";
3127
3128         untie %timestamp;
3129     }
3130 }
3131
3132 sub delete_timestamp {
3133     my $thing = shift;
3134     my $thgopts = shift || '';
3135
3136     if (tied %timestamp) {
3137         delete $timestamp{$thing.$thgopts};
3138     } else {
3139         tie (%timestamp, "Devscripts::DB_File_Lock", $timestampdb,
3140              O_RDWR()|O_CREAT(), 0600, $DB_HASH, "write")
3141             or die "bts: couldn't open DB file $timestampdb for writing: $!\n";
3142
3143         delete $timestamp{$thing.$thgopts};
3144
3145         untie %timestamp;
3146     }
3147 }
3148
3149 sub is_manual {
3150     return $_[0] < 0;
3151 }
3152
3153 sub make_manual {
3154     return -abs($_[0]);
3155 }
3156
3157 sub is_automatic {
3158     return $_[0] > 0;
3159 }
3160
3161 sub make_automatic {
3162     return abs($_[0]);
3163 }
3164
3165 # Returns true if current cached version is older than critical version
3166 # We're only using really simple version numbers here: a.b.c
3167 sub old_cache_format_version {
3168     my $cacheversion = $_[0];
3169
3170     my @cache = split /\./, $cacheversion;
3171     my @new = split /\./, $new_cache_format_version;
3172
3173     push @cache, 0, 0, 0, 0;
3174     push @new, 0, 0;
3175
3176     return
3177         ($cache[0]<$new[0]) ||
3178         ($cache[0]==$new[0] && $cache[1]<$new[1]) ||
3179         ($cache[0]==$new[0] && $cache[1]==$new[1] && $cache[2]<$new[2]) ||
3180         ($cache[0]==$new[0] && $cache[1]==$new[1] && $cache[2]==$new[2] &&
3181          $cache[3]<$new[3]);
3182 }
3183
3184 # We would love to use LWP::Simple::mirror in this script.
3185 # Unfortunately, bugs.debian.org does not respect the
3186 # If-Modified-Since header.  For single bug reports, however,
3187 # bugreport.cgi will return a Last-Modified header if sent a HEAD
3188 # request.  So this is a hack, based on code from the LWP modules.  :-(
3189 # Return value:
3190 #  (return value, error string)
3191 #  with return values:  MIRROR_ERROR        failed
3192 #                       MIRROR_DOWNLOADED   downloaded new version
3193 #                       MIRROR_UP_TO_DATE   up-to-date
3194
3195 sub bts_mirror {
3196     my ($url, $timestamp, $force) = @_;
3197
3198     init_agent() unless $ua;
3199     if ($url =~ m%/\d+$% and ! $refreshmode and ! $force) {
3200         # Single bug, worth doing timestamp checks
3201         my $request = HTTP::Request->new('HEAD', $url);
3202         my $response = $ua->request($request);
3203
3204         if ($response->is_success) {
3205             my $lm = $response->last_modified;
3206             if (defined $lm and $lm <= abs($timestamp)) {
3207                 return (MIRROR_UP_TO_DATE, $response->status_line);
3208             }
3209         } else {
3210             return (MIRROR_ERROR, $response->status_line);
3211         }
3212     }
3213
3214     # So now we download the full thing regardless
3215     # We don't care if we scotch the contents of $file - it's only
3216     # a temporary file anyway
3217     my $request = HTTP::Request->new('GET', $url);
3218     my $response = $ua->request($request);
3219
3220     if ($response->is_success) {
3221         # This check from LWP::UserAgent; I don't even know whether
3222         # the BTS sends a Content-Length header...
3223         my $nominal_content_length = $response->content_length || 0;
3224         my $true_content_length = defined $response->content ?
3225             length($response->content) : 0;
3226         if ($true_content_length == 0) {
3227             return (MIRROR_ERROR, $response->status_line);
3228         }
3229         if ($nominal_content_length > 0) {
3230             if ($true_content_length < $nominal_content_length) {
3231                 return (MIRROR_ERROR,
3232                         "Transfer truncated: only $true_content_length out of $nominal_content_length bytes received");
3233             }
3234             if ($true_content_length > $nominal_content_length) {
3235                 return (MIRROR_ERROR,
3236                         "Content-length mismatch: expected $nominal_content_length bytes, got $true_content_length");
3237             }
3238             # else OK
3239         }
3240
3241         return (MIRROR_DOWNLOADED, $response->status_line, $response->content);
3242     } else {
3243         return (MIRROR_ERROR, $response->status_line);
3244     }
3245 }
3246
3247 sub init_agent {
3248     $ua = new LWP::UserAgent;  # we create a global UserAgent object
3249     $ua->agent("LWP::UserAgent/Devscripts/$version");
3250     $ua->env_proxy;
3251 }
3252
3253 sub opts_done {
3254     if (@_) {
3255          die "bts: unknown options: @_\n";
3256     }
3257 }
3258
3259 =back
3260
3261 =head1 ENVIRONMENT VARIABLES
3262
3263 =over 4
3264
3265 =item DEBEMAIL
3266
3267 If this is set, the From: line in the email will be set to use this email
3268 address instead of your normal email address (as would be determined by
3269 B<mail>).
3270
3271 =item DEBFULLNAME
3272
3273 If DEBEMAIL is set, DEBFULLNAME is examined to determine the full name
3274 to use; if this is not set, B<bts> attempts to determine a name from
3275 your passwd entry.
3276
3277 =item BROWSER
3278
3279 If set, it specifies the browser to use for the 'show' and 'bugs'
3280 options.  See the description above.
3281
3282 =back
3283
3284 =head1 CONFIGURATION VARIABLES
3285
3286 The two configuration files F</etc/devscripts.conf> and
3287 F<~/.devscripts> are sourced by a shell in that order to set
3288 configuration variables.  Command line options can be used to override
3289 configuration file settings.  Environment variable settings are
3290 ignored for this purpose.  The currently recognised variables are:
3291
3292 =over 4
3293
3294 =item BTS_OFFLINE
3295
3296 If this is set to I<yes>, then it is the same as the --offline command
3297 line parameter being used.  Only has an effect on the show and bugs
3298 commands.  The default is I<no>.  See the description of the show
3299 command above for more information.
3300
3301 =item BTS_CACHE
3302
3303 If this is set to I<no>, then it is the same as the --no-cache command
3304 line parameter being used.  Only has an effect on the show and bug
3305 commands.  The default is I<yes>.  Again, see the show command above
3306 for more information.
3307
3308 =item BTS_CACHE_MODE={min,mbox,full}
3309
3310 How much of the BTS should we mirror when we are asked to cache something?
3311 Just the minimum, or also the mbox or the whole thing?  The default is
3312 I<min>, and it has the same meaning as the --cache-mode command line
3313 parameter.  Only has an effect on the cache.  See the cache command for more
3314 information.
3315
3316 =item BTS_FORCE_REFRESH
3317
3318 If this is set to I<yes>, then it is the same as the --force-refresh
3319 command line parameter being used.  Only has an effect on the cache
3320 command.  The default is I<no>.  See the cache command for more
3321 information.
3322
3323 =item BTS_MAIL_READER
3324
3325 If this is set, specifies a mail reader to use instead of mutt.  Same as
3326 the --mailreader command line option.
3327
3328 =item BTS_MAIL_COMPOSER
3329
3330 If this is set, specifies a mail composer to use instead of mutt.  Same
3331 as the --mailcomposer command line option.
3332
3333 =item BTS_SENDMAIL_COMMAND
3334
3335 If this is set, specifies a sendmail command to use instead of
3336 /usr/sbin/sendmail.  Same as the --sendmail command line option.
3337
3338 =item BTS_ONLY_NEW
3339
3340 Download only new bugs when caching. Do not check for updates in
3341 bugs we already have.
3342
3343 =item BTS_SMTP_HOST
3344
3345 If this is set, specifies an SMTP host to use for sending mail rather
3346 than using the sendmail command.  Same as the --smtp-host command line
3347 option.
3348
3349 Note that this option takes priority over BTS_SENDMAIL_COMMAND if both are
3350 set, unless the --sendmail option is used.
3351
3352 =item BTS_INCLUDE_RESOLVED
3353
3354 If this is set to I<no>, then it is the same as the --no-include-resolved
3355 command line parameter being used.  Only has an effect on the cache
3356 command.  The default is I<yes>.  See the cache command for more
3357 information.
3358
3359 =cut
3360
3361 =head1 SEE ALSO
3362
3363 Please see L<http://www.debian.org/Bugs/server-control> for
3364 more details on how to control the BTS using emails and
3365 L<http://www.debian.org/Bugs/> for more information about the BTS.
3366
3367 reportbug(1), querybts(1)
3368
3369 =cut
3370
3371 =head1 COPYRIGHT
3372
3373 This program is Copyright (C) 2001-2003 by Joey Hess <joeyh@debian.org>.
3374 Many modifications have been made, Copyright (C) 2002-2005 Julian
3375 Gilbey <jdg@debian.org> and Copyright (C) 2007 Josh Triplett
3376 <josh@freedesktop.org>.
3377
3378 It is licensed under the terms of the GPL, either version 2 of the
3379 License, or (at your option) any later version.
3380
3381 =cut
3382
3383 # Please leave this alone unless you understand the seek above.
3384 __DATA__