diff options
Diffstat (limited to 'scripts/bts.pl')
| -rwxr-xr-x | scripts/bts.pl | 4337 |
1 files changed, 4337 insertions, 0 deletions
diff --git a/scripts/bts.pl b/scripts/bts.pl new file mode 100755 index 0000000..481cfcd --- /dev/null +++ b/scripts/bts.pl @@ -0,0 +1,4337 @@ +#!/usr/bin/perl + +# bts: This program provides a convenient interface to the Debian +# Bug Tracking System. +# +# Written by Joey Hess <joeyh@debian.org> +# Modifications by Julian Gilbey <jdg@debian.org> +# Modifications by Josh Triplett <josh@freedesktop.org> +# Copyright 2001-2003 Joey Hess <joeyh@debian.org> +# Modifications Copyright 2001-2003 Julian Gilbey <jdg@debian.org> +# Modifications Copyright 2007 Josh Triplett <josh@freedesktop.org> +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see <https://www.gnu.org/licenses/>. + +# Use our own subclass of Pod::Text to +# a) Strip the POD markup before displaying it via "bts help" +# b) Automatically display the text which is supposed to be replaced by the +# user between <>, as per convention. +package Pod::BTS; +use strict; + +use base qw(Pod::Text); + +sub cmd_i { return '<' . $_[2] . '>' } + +package main; + +=head1 NAME + +bts - developers' command line interface to the Debian Bug Tracking System + +=cut + +use 5.010; # for defined-or +use strict; +use warnings; +use File::Basename; +use File::Copy; +use File::HomeDir; +use File::Path qw(make_path rmtree); +use File::Spec; +use File::Temp qw/tempfile/; +use Net::SMTP; +use Cwd; +use IO::File; +use IO::Handle; +use Devscripts::DB_File_Lock; +use Devscripts::Debbugs; +use Fcntl qw(O_RDWR O_RDONLY O_CREAT F_SETFD); +use Getopt::Long; +use Encode; +# Need support for ; as query param separator +use URI 1.37; +use URI::QueryParam; + +use Scalar::Util qw(looks_like_number); +use POSIX qw(locale_h strftime); + +setlocale(LC_TIME, "C"); # so that strftime is locale independent + +# Funny UTF-8 warning messages from HTML::Parse should be ignorable (#292671) +$SIG{'__WARN__'} = sub { + warn $_[0] + unless $_[0] + =~ /^Parsing of undecoded UTF-8 will give garbage when decoding entities/; +}; + +my $it = undef; +my $last_user = ''; +my $lwp_broken = undef; +my $authen_sasl_broken; +my $ua; + +sub have_lwp() { + return ($lwp_broken ? 0 : 1) if defined $lwp_broken; + eval { + require LWP; + require LWP::UserAgent; + require HTTP::Status; + require HTTP::Date; + }; + + if ($@) { + if ($@ =~ m%^Can\'t locate LWP%) { + $lwp_broken = "the libwww-perl package is not installed"; + } else { + $lwp_broken = "couldn't load LWP::UserAgent: $@"; + } + } else { + $lwp_broken = ''; + } + return $lwp_broken ? 0 : 1; +} + +sub have_authen_sasl() { + return ($authen_sasl_broken ? 0 : 1) if defined $authen_sasl_broken; + eval { require Authen::SASL; }; + + if ($@) { + if ($@ =~ m%^Can't locate Authen/SASL%) { + $authen_sasl_broken + = 'the libauthen-sasl-perl package is not installed'; + } else { + $authen_sasl_broken = "couldn't load Authen::SASL: $@"; + } + } else { + $authen_sasl_broken = ''; + } + return $authen_sasl_broken ? 0 : 1; +} + +# Constants +sub MIRROR_ERROR { 0; } +sub MIRROR_DOWNLOADED { 1; } +sub MIRROR_UP_TO_DATE { 2; } +my $NONPRINT = "\\x00-\\x1F\\x7F-\\xFF"; # we need this later for MIME stuff + +my $progname = basename($0); +my $modified_conf_msg; +my $debug = (exists $ENV{'DEBUG'} and $ENV{'DEBUG'}) ? 1 : 0; + +# Program version handling +# The BTS changed its format :/ Pages downloaded using old versions +# of bts won't look very good, so we force updating if the last cached +# version was downloaded by a devscripts version less than +# $new_cache_format_version +my $version = '###VERSION###'; +$version = '2.9.6' if $version =~ /\#/; # for testing unconfigured version +my $new_cache_format_version = '2.9.6'; + +# The official list is mirrored +# bugs-mirror.debian.org:/srv/bugs.debian.org/etc/config +# in the variable @gTags; we copy it verbatim here. +# +# Note that it is also in the POD documentation in the bts_tag +# function below, look for "potato". +our (@gTags, @valid_tags, %valid_tags); +#<<< This variable definition should be kept verbatim from the BTS config +@gTags = ( "patch", "wontfix", "moreinfo", "unreproducible", + "help", "security", "upstream", "pending", "confirmed", + "ipv6", "lfs", "d-i", "l10n", "newcomer", "a11y", "ftbfs", + "fixed-upstream", "fixed", "fixed-in-experimental", + "sid", "experimental", + "potato", "woody", + "sarge", "sarge-ignore", "etch", "etch-ignore", + "lenny", "lenny-ignore", "squeeze", "squeeze-ignore", + "wheezy", "wheezy-ignore", "jessie", "jessie-ignore", + "stretch", "stretch-ignore", "buster", "buster-ignore", + "bullseye", "bullseye-ignore","bookworm","bookworm-ignore", + "trixie","trixie-ignore", + ); +#>>> + +*valid_tags = \@gTags; +%valid_tags = map { $_ => 1 } @valid_tags; +my @valid_severities = qw(wishlist minor normal important + serious grave critical); + +my $browser; # Will set if necessary + +$ENV{HOME} = File::HomeDir->my_home; +my $cachedir + = $ENV{XDG_CACHE_HOME} || File::Spec->catdir($ENV{HOME}, '.cache'); +$cachedir = File::Spec->catdir($cachedir, 'devscripts', 'bts'); + +my $timestampdb = File::Spec->catfile($cachedir, 'bts_timestamps.db'); +my $prunestamp = File::Spec->catfile($cachedir, 'bts_prune.timestamp'); + +my %timestamp; + +END { + # This works even if we haven't tied it + untie %timestamp; +} + +my %clonedbugs = (); +my %ccpackages = (); +my %ccsubmitters = (); + +=head1 SYNOPSIS + +B<bts> [I<options>] I<command> [I<args>] [B<#>I<comment>] [B<.>|B<,> I<command> [I<args>] [B<#>I<comment>]] ... + +=head1 DESCRIPTION + +This is a command line interface to the Debian Bug Tracking System +(BTS), intended mainly +for use by developers. It lets the BTS be manipulated using simple commands +that can be run at the prompt or in a script, does various sanity checks on +the input, and constructs and sends a mail to the BTS control address for +you. A local cache of web pages and e-mails from the BTS may also be +created and updated. + +In general, the command line interface is the same as what you would write +in a mail to control@bugs.debian.org, just prefixed with "bts". For +example: + + % bts severity 69042 normal + % bts merge 69042 43233 + % bts retitle 69042 blah blah + +A few additional commands have been added for your convenience, and this +program is less strict about what constitutes a valid bug number. For example, +"severity Bug#85942 normal" is understood, as is "severity #85942 normal". +(Of course, your shell may regard "#" as a comment character though, so you +may need to quote it!) + +Also, for your convenience, this program allows you to abbreviate commands +to the shortest unique substring (similar to how cvs lets you abbreviate +commands). So it understands things like "bts cl 85942". + +It is also possible to include a comment in the mail sent to the BTS. If +your shell does not strip out the comment in a command like +"bts severity 30321 normal #inflated severity", then this program is smart +enough to figure out where the comment is, and include it in the email. +Note that most shells do strip out such comments before they get to the +program, unless the comment is quoted. (Something like "bts +severity #85942 normal" will not be treated as a comment!) + +You can specify multiple commands by separating them with a single dot, +rather like B<update-rc.d>; a single comma may also be used; all the +commands will then be sent in a single mail. It is important the dot/comma is +surrounded by whitespace so it is not mistaken for part of a command. For +example (quoting where necessary so that B<bts> sees the comment): + + % bts severity 95672 normal , merge 95672 95673 \#they are the same! + +The abbreviation "it" may be used to refer to the last mentioned bug +number, so you could write: + + % bts severity 95672 wishlist , retitle it "bts: please add a --foo option" + +Please use this program responsibly, and do take our users into +consideration. + +=head1 OPTIONS + +B<bts> examines the B<devscripts> configuration files as described +below. Command line options override the configuration file settings, +though. + +=over 4 + +=item B<-o>, B<--offline> + +Make B<bts> use cached bugs for the B<show> and B<bugs> commands, if a cache +is available for the requested data. See the B<cache> command, below for +information on setting up a cache. + +=item B<--online>, B<--no-offline> + +Opposite of B<--offline>; overrides any configuration file directive to work +offline. + +=item B<-n>, B<--no-action> + +Do not send emails but print them to standard output. + +=item B<--cache>, B<--no-cache> + +Should we attempt to cache new versions of BTS pages when +performing B<show>/B<bugs> commands? Default is to cache. + +=item B<--cache-mode=>{B<min>|B<mbox>|B<full>} + +When running a B<bts cache> command, should we only mirror the basic +bug (B<min>), or should we also mirror the mbox version (B<mbox>), or should +we mirror the whole thing, including the mbox and the boring +attachments to the BTS bug pages and the acknowledgement emails (B<full>)? +Default is B<min>. + +=item B<--cache-delay=>I<seconds> + +Time in seconds to delay between each download, to avoid hammering the BTS +web server. Default is 5 seconds. + +=item B<--mbox> + +Open a mail reader to read the mbox corresponding to a given bug number +for B<show> and B<bugs> commands. + +=item B<--mailreader=>I<READER> + +Specify the command to read the mbox. Must contain a "B<%s>" string +(unquoted!), which will be replaced by the name of the mbox file. The +command will be split on white space and will not be passed to a +shell. Default is 'B<mutt -f %s>'. (Also, B<%%> will be substituted by a +single B<%> if this is needed.) + +=item B<--cc-addr=>I<CC_EMAIL_ADDRESS> + +Send carbon copies to a list of users. I<CC_EMAIL_ADDRESS> should be a +comma-separated list of email addresses. Multiple options add more CCs. + +=item B<--use-default-cc> + +Add the addresses specified in the configuration file option +B<BTS_DEFAULT_CC> to the list specified using B<--cc-addr>. This is the +default. + +=item B<--no-use-default-cc> + +Do not add addresses specified in B<BTS_DEFAULT_CC> to the carbon copy +list. + +=item B<--sendmail=>I<SENDMAILCMD> + +Specify the B<sendmail> command. The command will be split on white +space and will not be passed to a shell. Default is +F</usr/sbin/sendmail>. The B<-t> option will be automatically added if +the command is F</usr/sbin/sendmail> or F</usr/sbin/exim*>. For other +mailers, if they require a B<-t> option, this must be included in the +I<SENDMAILCMD>, for example: B<--sendmail="/usr/sbin/mymailer -t">. + +=item B<--mutt> + +Use B<mutt> for sending of mails. Default is not to use B<mutt>, except for some +commands. + +Note that one of B<$DEBEMAIL> or B<$EMAIL> must be set in the environment in order +to use B<mutt> to send emails. + +=item B<--no-mutt> + +Don't use B<mutt> for sending of mails. + +=item B<--soap-timeout=>I<SECONDS> + +Specify a timeout for SOAP calls as used by the B<select> and B<status> commands. + +=item B<--smtp-host=>I<SMTPHOST> + +Specify an SMTP host. If given, B<bts> will send mail by talking directly to +this SMTP host rather than by invoking a B<sendmail> command. + +The host name may be followed by a colon (":") and a port number in +order to use a port other than the default. It may also begin with +"ssmtp://" or "smtps://" to indicate that SMTPS should be used. + +If SMTPS not specified, B<bts> will still try to use STARTTLS if it's advertised +by the SMTP host. + +Note that one of B<$DEBEMAIL> or B<$EMAIL> must be set in the environment in order +to use direct SMTP connections to send emails. + +Note that when sending directly via an SMTP host, specifying addresses in +B<--cc-addr> or B<BTS_DEFAULT_CC> that the SMTP host will not relay will cause the +SMTP host to reject the entire mail. + +Note also that the use of the B<reassign> command may, when either B<--mutt> +or B<--force-interactive> mode is enabled, lead to the automatic addition of a Cc +to I<$newpackage>@packages.debian.org. In these cases, the note above regarding +relaying applies. The submission interface (port 587) on reportbug.debian.org +does not support relaying and, as such, should not be used as an SMTP server +for B<bts> under the circumstances described in this paragraph. + +=item B<--smtp-username=>I<USERNAME>, B<--smtp-password=>I<PASSWORD> + +Specify the credentials to use when connecting to the SMTP server +specified by B<--smtp-host>. If the server does not require authentication +then these options should not be used. + +If a username is specified but not a password, B<bts> will prompt for +the password before sending the mail. + +=item B<--smtp-helo=>I<HELO> + +Specify the name to use in the I<HELO> command when connecting to the SMTP +server; defaults to the contents of the file F</etc/mailname>, if it +exists. + +Note that some SMTP servers may reject the use of a I<HELO> which either +does not resolve or does not appear to belong to the host using it. + +=item B<--bts-server> + +Use a debbugs server other than https://bugs.debian.org. + +=item B<-f>, B<--force-refresh> + +Download a bug report again, even if it does not appear to have +changed since the last B<cache> command. Useful if a B<--cache-mode=full> is +requested for the first time (otherwise unchanged bug reports will not +be downloaded again, even if the boring bits have not been +downloaded). + +=item B<--no-force-refresh> + +Suppress any configuration file B<--force-refresh> option. + +=item B<--only-new> + +Download only new bugs when caching. Do not check for updates in +bugs we already have. + +=item B<--include-resolved> + +When caching bug reports, include those that are marked as resolved. This +is the default behaviour. + +=item B<--no-include-resolved> + +Reverse the behaviour of the previous option. That is, do not cache bugs +that are marked as resolved. + +=item B<--no-ack> + +Suppress acknowledgment mails from the BTS. Note that this will only +affect the copies of messages CCed to bugs, not those sent to the +control bot. + +=item B<--ack> + +Do not suppress acknowledgement mails. This is the default behaviour. + +=item B<-i>, B<--interactive> + +Before sending an e-mail to the control bot, display the content and +allow it to be edited, or the sending cancelled. + +=item B<--force-interactive> + +Similar to B<--interactive>, with the exception that an editor is spawned +before prompting for confirmation of the message to be sent. + +=item B<--no-interactive> + +Send control e-mails without confirmation. This is the default behaviour. + +=item B<-q>, B<--quiet> + +When running B<bts cache>, only display information about newly cached +pages, not messages saying already cached. If this option is +specified twice, only output error messages (to stderr). + +=item B<--no-conf>, B<--noconf> + +Do not read any configuration files. This can only be used as the +first option given on the command-line. + +=back + +=cut + +# Start by setting default values + +my $offlinemode = 0; +my $caching = 1; +my $cachemode = 'min'; +my $cachemode_re = '^(full|mbox|min)$'; +my $refreshmode = 0; +my $updatemode = 0; +my $mailreader = 'mutt -f %s'; +my $muttcmd = 'mutt -H %s'; +my $sendmailcmd = '/usr/sbin/sendmail'; +my $smtphost = ''; +my $smtpuser = ''; +my $smtppass = ''; +my $smtphelo = ''; +my $noaction = 0; + +# regexp for mailers which require a -t option +my $sendmail_t = '^/usr/sbin/sendmail$|^/usr/sbin/exim'; +my $includeresolved = 1; +my $requestack = 1; +my $interactive_re = '^(force|no|yes)$'; +my $interactive = 'no'; +my @ccemails = (); +my $toolname = ""; +my $btsserver = 'https://bugs.debian.org'; +my $use_mutt = 0; + +# Next, read read configuration files and then command line +# The next stuff is boilerplate + +if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) { + $modified_conf_msg = " (no configuration files read)"; + shift; +} else { + my @config_files = ('/etc/devscripts.conf', '~/.devscripts'); + my %config_vars = ( + 'BTS_OFFLINE' => 'no', + 'BTS_CACHE' => 'yes', + 'BTS_CACHE_MODE' => 'min', + 'BTS_FORCE_REFRESH' => 'no', + 'BTS_ONLY_NEW' => 'no', + 'BTS_MAIL_READER' => 'mutt -f %s', + 'BTS_SENDMAIL_COMMAND' => '/usr/sbin/sendmail', + 'BTS_INCLUDE_RESOLVED' => 'yes', + 'BTS_SMTP_HOST' => '', + 'BTS_SMTP_AUTH_USERNAME' => '', + 'BTS_SMTP_AUTH_PASSWORD' => '', + 'BTS_SMTP_HELO' => '', + 'BTS_SUPPRESS_ACKS' => 'no', + 'BTS_INTERACTIVE' => 'no', + 'BTS_DEFAULT_CC' => '', + 'BTS_SERVER' => $btsserver, + ); + my %config_default = %config_vars; + + my $shell_cmd; + # Set defaults + foreach my $var (keys %config_vars) { + $shell_cmd .= qq[$var="$config_vars{$var}";\n]; + } + $shell_cmd .= 'for file in ' . join(" ", @config_files) . "; do\n"; + $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n"; + # Read back values + foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" } + my $shell_out = `/bin/bash -c '$shell_cmd'`; + @config_vars{ keys %config_vars } = split /\n/, $shell_out, -1; + + # Check validity + $config_vars{'BTS_OFFLINE'} =~ /^(yes|no)$/ + or $config_vars{'BTS_OFFLINE'} = 'no'; + $config_vars{'BTS_CACHE'} =~ /^(yes|no)$/ + or $config_vars{'BTS_CACHE'} = 'yes'; + $config_vars{'BTS_CACHE_MODE'} =~ $cachemode_re + or $config_vars{'BTS_CACHE_MODE'} = 'min'; + $config_vars{'BTS_FORCE_REFRESH'} =~ /^(yes|no)$/ + or $config_vars{'BTS_FORCE_REFRESH'} = 'no'; + $config_vars{'BTS_ONLY_NEW'} =~ /^(yes|no)$/ + or $config_vars{'BTS_ONLY_NEW'} = 'no'; + $config_vars{'BTS_MAIL_READER'} =~ /\%s/ + or $config_vars{'BTS_MAIL_READER'} = 'mutt -f %s'; + $config_vars{'BTS_SENDMAIL_COMMAND'} =~ /./ + or $config_vars{'BTS_SENDMAIL_COMMAND'} = '/usr/sbin/sendmail'; + $config_vars{'BTS_INCLUDE_RESOLVED'} =~ /^(yes|no)$/ + or $config_vars{'BTS_INCLUDE_RESOLVED'} = 'yes'; + $config_vars{'BTS_SUPPRESS_ACKS'} =~ /^(yes|no)$/ + or $config_vars{'BTS_SUPPRESS_ACKS'} = 'no'; + $config_vars{'BTS_INTERACTIVE'} =~ $interactive_re + or $config_vars{'BTS_INTERACTIVE'} = 'no'; + + if (!length $config_vars{'BTS_SMTP_HOST'} + and $config_vars{'BTS_SENDMAIL_COMMAND'} ne '/usr/sbin/sendmail') { + my $cmd = (split ' ', $config_vars{'BTS_SENDMAIL_COMMAND'})[0]; + unless ($cmd =~ /^~?[A-Za-z0-9_\-\+\.\/]*$/) { + die +"BTS_SENDMAIL_COMMAND contained funny characters: $cmd\nPlease fix the configuration file.\n"; + } elsif (system("command -v $cmd >/dev/null 2>&1") != 0) { + die +"BTS_SENDMAIL_COMMAND $cmd could not be executed.\nPlease fix the configuration file.\n"; + } + } + + foreach my $var (sort keys %config_vars) { + if ($config_vars{$var} ne $config_default{$var}) { + $modified_conf_msg .= " $var=$config_vars{$var}\n"; + } + } + $modified_conf_msg ||= " (none)\n"; + chomp $modified_conf_msg; + + $offlinemode = $config_vars{'BTS_OFFLINE'} eq 'yes' ? 1 : 0; + $caching = $config_vars{'BTS_CACHE'} eq 'no' ? 0 : 1; + $cachemode = $config_vars{'BTS_CACHE_MODE'}; + $refreshmode = $config_vars{'BTS_FORCE_REFRESH'} eq 'yes' ? 1 : 0; + $updatemode = $config_vars{'BTS_ONLY_NEW'} eq 'yes' ? 1 : 0; + $mailreader = $config_vars{'BTS_MAIL_READER'}; + $sendmailcmd = $config_vars{'BTS_SENDMAIL_COMMAND'}; + $smtphost = $config_vars{'BTS_SMTP_HOST'}; + $smtpuser = $config_vars{'BTS_SMTP_AUTH_USERNAME'}; + $smtppass = $config_vars{'BTS_SMTP_AUTH_PASSWORD'}; + $smtphelo = $config_vars{'BTS_SMTP_HELO'}; + $includeresolved = $config_vars{'BTS_INCLUDE_RESOLVED'} eq 'yes' ? 1 : 0; + $requestack = $config_vars{'BTS_SUPPRESS_ACKS'} eq 'no' ? 1 : 0; + $interactive = $config_vars{'BTS_INTERACTIVE'}; + push @ccemails, $config_vars{'BTS_DEFAULT_CC'} || (); + $btsserver = $config_vars{'BTS_SERVER'}; +} + +if (exists $ENV{'BUGSOFFLINE'}) { + warn +"BUGSOFFLINE environment variable deprecated: please use ~/.devscripts\nor --offline/-o option instead! (See bts(1) for details.)\n"; +} + +my ($opt_help, $opt_version, $opt_noconf); +my ($opt_cachemode, $opt_mailreader, $opt_sendmail, $opt_smtphost); +my ($opt_smtpuser, $opt_smtppass, $opt_smtphelo); +my $opt_cachedelay = 5; +my $opt_mutt; +my $opt_soap_timeout; +my $mboxmode = 0; +my $quiet = 0; +my @opt_ccemails = (); +my $use_default_cc = 1; +my $ccsecurity = ""; + +Getopt::Long::Configure(qw(gnu_compat bundling require_order)); +GetOptions( + "help|h" => \$opt_help, + "version" => \$opt_version, + "o" => \$offlinemode, + "offline!" => \$offlinemode, + "online" => sub { $offlinemode = 0; }, + "cache!" => \$caching, + "cache-mode|cachemode=s" => \$opt_cachemode, + "cache-delay=i" => \$opt_cachedelay, + "m|mbox" => \$mboxmode, + "mailreader|mail-reader=s" => \$opt_mailreader, + "cc-addr=s" => \@opt_ccemails, + "sendmail=s" => \$opt_sendmail, + "smtp-host|smtphost=s" => \$opt_smtphost, + "smtp-user|smtp-username=s" => \$opt_smtpuser, + "smtp-pass|smtp-password=s" => \$opt_smtppass, + "smtp-helo=s" => \$opt_smtphelo, + "f" => \$refreshmode, + "force-refresh!" => \$refreshmode, + "only-new!" => \$updatemode, + "n|no-action" => \$noaction, + "q|quiet+" => \$quiet, + "noconf|no-conf" => \$opt_noconf, + "include-resolved!" => \$includeresolved, + "ack!" => \$requestack, + "i|interactive" => sub { $interactive = 'yes'; }, + "no-interactive" => sub { $interactive = 'no'; }, + "force-interactive" => sub { $interactive = 'force'; }, + "use-default-cc!" => \$use_default_cc, + "toolname=s" => \$toolname, + "bts-server=s" => \$btsserver, + "mutt!" => \$opt_mutt, + "soap-timeout:i" => \$opt_soap_timeout, + ) + or die "Usage: $progname [options]\nRun $progname --help for more details\n"; + +if ($opt_noconf) { + die +"$progname: --no-conf is only acceptable as the first command-line option!\n"; +} +if ($opt_help) { bts_help(); exit 0; } +if ($opt_version) { bts_version(); exit 0; } + +if (!$use_default_cc) { + @ccemails = (); +} + +if (@opt_ccemails) { + push @ccemails, @opt_ccemails; +} + +if ($opt_mailreader) { + if ($opt_mailreader =~ /\%s/) { + $mailreader = $opt_mailreader; + } else { + warn +"$progname: ignoring invalid --mailreader option: invalid mail command following it.\n"; + } +} + +if ($opt_mutt) { + $use_mutt = 1; +} + +if ($opt_soap_timeout) { + Devscripts::Debbugs::soap_timeout($opt_soap_timeout); +} + +if ($opt_sendmail and $opt_smtphost) { + die "$progname: --sendmail and --smtp-host mutually exclusive\n"; +} elsif ($opt_mutt and $opt_sendmail) { + die "$progname: --sendmail and --mutt mutually exclusive\n"; +} elsif ($opt_mutt and $opt_smtphost) { + die "$progname: --smtp-host and --mutt mutually exclusive\n"; +} + +$smtphost = $opt_smtphost if $opt_smtphost; +$smtpuser = $opt_smtpuser if $opt_smtpuser; +$smtppass = $opt_smtppass if $opt_smtppass; +$smtphelo = $opt_smtphelo if $opt_smtphelo; + +if ($opt_sendmail) { + if ( $opt_sendmail ne '/usr/sbin/sendmail' + and $opt_sendmail ne $sendmailcmd) { + my $cmd = (split ' ', $opt_sendmail)[0]; + unless ($cmd =~ /^~?[A-Za-z0-9_\-\+\.\/]*$/) { + die "--sendmail command contained funny characters: $cmd\n"; + } elsif (system("command -v $cmd >/dev/null 2>&1") != 0) { + die "--sendmail command $cmd could not be executed.\n"; + } + } +} + +if ($opt_sendmail) { + $sendmailcmd = $opt_sendmail; + $smtphost = ''; +} else { + if (length $smtphost and !length $smtphelo) { + if (-e "/etc/mailname") { + if (open MAILNAME, '<', "/etc/mailname") { + $smtphelo = <MAILNAME>; + chomp $smtphelo; + close MAILNAME; + } else { + warn +"Unable to open /etc/mailname: $!\nUsing default HELO for SMTP\n"; + } + } + } +} + +if ($opt_cachemode) { + if ($opt_cachemode =~ $cachemode_re) { + $cachemode = $opt_cachemode; + } else { + warn +"$progname: ignoring invalid --cache-mode; must be one of min, mbox, full.\n"; + } +} + +if ($toolname) { + $toolname = " (using $toolname)"; +} + +my $btsurl; +if ($btsserver =~ m%^https?://(.*)/?$%) { + $btsurl = $btsserver . '/'; + $btsserver = $1; +} else { + $btsurl = "http://$btsserver/"; +} +$btsurl =~ s%//$%/%; +my $btscgiurl = $btsurl . 'cgi-bin/'; +if ($btsserver =~ /^debbugs\.gnu\.org/) { + $btscgiurl = $btsurl . 'cgi/'; +} +my $btscgipkgurl = $btscgiurl . 'pkgreport.cgi'; +my $btscgibugurl = $btscgiurl . 'bugreport.cgi'; +my $btscgispamurl = $btscgiurl . 'bugspam.cgi'; +my $btsemail = 'control@' . $btsserver; +my $packagesserver = ''; +if ($btsserver =~ /^bugs(-[\w-]+)?\.debian\.org/i) { + $packagesserver = 'packages.debian.org'; + $btscgispamurl =~ s|$btsurl|http://bugs-master.debian.org/|; +} +no warnings 'once'; +$Devscripts::Debbugs::btsurl = $btsurl; +use warnings 'once'; + +if (@ARGV == 0) { + bts_help(); + exit 0; +} + +# Otherwise, parse the arguments +my @command; +my @args; +our @comment = (''); +my $ncommand = 0; +my $iscommand = 1; +while (@ARGV) { + $_ = shift @ARGV; + if ($_ =~ /^[\.,]$/) { + next if $iscommand; # ". ." in command line - oops! + $ncommand++; + $iscommand = 1; + $comment[$ncommand] = ''; + } elsif ($iscommand) { + push @command, $_; + $iscommand = 0; + } elsif ($comment[$ncommand]) { + $comment[$ncommand] .= " $_"; + } elsif (/^\#/ and not /^\#\d+$/) { + $comment[$ncommand] = $_; + } else { + push @{ $args[$ncommand] }, $_; + } +} +$ncommand-- if $iscommand; + +# Grub through the symbol table to find matching commands. +my $subject = ''; +my $body = ''; +our $index; +for $index (0 .. $ncommand) { + no strict 'refs'; + if (exists $::{"bts_$command[$index]"}) { + "bts_$command[$index]"->(@{ $args[$index] }); + } elsif ($command[$index] =~ /^#/) { + mailbts('', $command[$index]); + } else { + my @matches = grep /^bts_\Q$command[$index]\E/, keys %::; + if (@matches != 1) { + die +"$progname: Couldn't find a unique match for the command $command[$index]!\nRun $progname --help for a list of valid commands.\n"; + } + + # Replace the abbreviated command with its expanded equivalent + $command[$index] = $matches[0]; + $command[$index] =~ s/^bts_//; + + $matches[0]->(@{ $args[$index] }); + } +} + +# Send all cached commands. +mailbtsall($subject, $body) if length $body; + +# Unnecessary, but we'll do this for clarity +exit 0; + +=head1 COMMANDS + +For full details about the commands, see the BTS documentation. +L<https://www.debian.org/Bugs/server-control> + +=over 4 + +=item B<show> [I<options>] [I<bug number> | I<package> | I<maintainer> | B<:> ] [I<opt>B<=>I<val> ...] + +=item B<show> [I<options>] [B<src:>I<package> | B<from:>I<submitter>] [I<opt>B<=>I<val> ...] + +=item B<show> [I<options>] [B<tag:>I<tag> | B<usertag:>I<tag> ] [I<opt>B<=>I<val> ...] + +=item B<show> [B<release-critical> | B<release-critical/>... | B<RC>] + +This is a synonym for B<bts bugs>. + +=cut + +sub bts_show { + goto &bts_bugs; +} + +=item B<bugs> [I<options>] [I<bug_number> | I<package> | I<maintainer> | B<:> ] [I<opt>B<=>I<val> ...] + +=item B<bugs> [I<options>] [B<src:>I<package> | B<from:>I<submitter>] [I<opt>B<=>I<val> ...] + +=item B<bugs> [I<options>] [B<tag:>I<tag> | B<usertag:>I<tag> ] [I<opt>B<=>I<val> ...] + +=item B<bugs> [B<release-critical> | B<release-critical/>... | B<RC>] + +Display the page listing the requested bugs in a web browser using +sensible-browser(1). + +Options may be specified after the B<bugs> command in addition to or +instead of options at the start of the command line: recognised +options at this point are: B<-o>/B<--offline>/B<--online>, B<-m>/B<--mbox>, B<--mailreader> +and B<-->[B<no->]B<cache>. These are described earlier in this manpage. If +either the B<-o> or B<--offline> option is used, or there is already an +up-to-date copy in the local cache, the cached version will be used. + +The meanings of the possible arguments are as follows: + +=over 8 + +=item (none) + +If nothing is specified, B<bts bugs> will display your bugs, assuming +that either B<DEBEMAIL> or B<EMAIL> (examined in that order) is set to the +appropriate email address. + +=item I<bug_number> + +Display bug number I<bug_number>. + +=item I<package> + +Display the bugs for the package I<package>. + +=item B<src:>I<package> + +Display the bugs for the source package I<package>. + +=item I<maintainer> + +Display the bugs for the maintainer email address I<maintainer>. + +=item B<from:>I<submitter> + +Display the bugs for the submitter email address I<submitter>. + +=item B<tag:>I<tag> + +Display the bugs which are tagged with I<tag>. + +=item B<usertag:>I<tag> + +Display the bugs which are tagged with usertag I<tag>. See the BTS +documentation for more information on usertags. This will require the +use of a B<users=>I<email> option. + +=item B<:> + +Details of the bug tracking system itself, along with a bug-request +page with more options than this script, can be found on +https://bugs.debian.org/. This page itself will be opened if the +command 'bts bugs :' is used. + +=item B<release-critical>, B<RC> + +Display the front page of the release-critical pages on the BTS. This +is a synonym for https://bugs.debian.org/release-critical/index.html. +It is also possible to say release-critical/debian/main.html and the like. +RC is a synonym for release-critical/other/all.html. + +=back + +After the argument specifying what to display, you can optionally +specify options to use to format the page or change what it displayed. +These are passed to the BTS in the URL downloaded. For example, pass +dist=stable to see bugs affecting the stable version of a package, +version=1.0 to see bugs affecting that version of a package, or reverse=yes +to display newest messages first in a bug log. + +If caching has been enabled (that is, B<--no-cache> has not been used, +and B<BTS_CACHE> has not been set to B<no>), then any page requested by +B<bts show> will automatically be cached, and be available offline +thereafter. Pages which are automatically cached in this way will be +deleted on subsequent "B<bts show>|B<bugs>|B<cache>" invocations if they have +not been accessed in 30 days. Warning: on a filesystem mounted with +the "noatime" option, running "B<bts show>|B<bugs>" does not update the cache +files' access times; a cached bug will then be subject to auto-cleaning +30 days after its initial download, even if it has been accessed in the +meantime. + +Any other B<bts> commands following this on the command line will be +executed after the browser has been exited. + +The desired browser can be specified and configured by setting the +B<BROWSER> environment variable. The conventions follow those defined by +Eric Raymond at http://www.catb.org/~esr/BROWSER/; we here reproduce the +relevant part. + +The value of B<BROWSER> may consist of a colon-separated series of +browser command parts. These should be tried in order until one +succeeds. Each command part may optionally contain the string B<%s>; if +it does, the URL to be viewed is substituted there. If a command part +does not contain B<%s>, the browser is to be launched as if the URL had +been supplied as its first argument. The string B<%%> must be substituted +as a single %. + +Rationale: We need to be able to specify multiple browser commands so +programs obeying this convention can do the right thing in either X or +console environments, trying X first. Specifying multiple commands may +also be useful for people who share files like F<.profile> across +multiple systems. We need B<%s> because some popular browsers have +remote-invocation syntax that requires it. Unless B<%%> reduces to %, it +won't be possible to have a literal B<%s> in the string. + +For example, on most Linux systems a good thing to do would be: + +BROWSER='mozilla -raise -remote "openURL(%s,new-window)":links' + +=cut + +sub bts_bugs { + @ARGV = @_; # needed for GetOptions + my ($sub_offlinemode, $sub_caching, $sub_mboxmode, $sub_mailreader); + GetOptions( + "o" => \$sub_offlinemode, + "offline!" => \$sub_offlinemode, + "online" => sub { $sub_offlinemode = 0; }, + "cache!" => \$sub_caching, + "m|mbox" => \$sub_mboxmode, + "mailreader|mail-reader=s" => \$sub_mailreader, + ) or die "$progname: unknown options for bugs command\n"; + @_ = @ARGV; # whatever's left + + if (defined $sub_offlinemode) { + ($offlinemode, $sub_offlinemode) = ($sub_offlinemode, $offlinemode); + } + if (defined $sub_caching) { + ($caching, $sub_caching) = ($sub_caching, $caching); + } + if (defined $sub_mboxmode) { + ($mboxmode, $sub_mboxmode) = ($sub_mboxmode, $mboxmode); + } + if (defined $sub_mailreader) { + if ($sub_mailreader =~ /\%s/) { + ($mailreader, $sub_mailreader) = ($sub_mailreader, $mailreader); + } else { + warn +"$progname: ignoring invalid --mailreader $sub_mailreader option:\ninvalid mail command following it.\n"; + $sub_mailreader = undef; + } + } + + my $url = sanitizething(shift); + if (!$url) { + if (defined $ENV{'DEBEMAIL'}) { + $url = $ENV{'DEBEMAIL'}; + } else { + if (defined $ENV{'EMAIL'}) { + $url = $ENV{'EMAIL'}; + } else { + die +"bts bugs: Please set DEBEMAIL or EMAIL to your Debian email address.\n"; + } + } + } + if ($url =~ /^.*\s<(.*)>\s*$/) { $url = $1; } + $url =~ s/^:$//; + + # Are there any options? + my $urlopts = ''; + if (@_) { + $urlopts = join(";", '', @_); # so it'll be ";opt1=val1;opt2=val2" + $urlopts =~ s/:/=/g; + $urlopts =~ s/;tag=/;include=/; + } + + browse($url, $urlopts); + + # revert options + if (defined $sub_offlinemode) { + $offlinemode = $sub_offlinemode; + } + if (defined $sub_caching) { + $caching = $sub_caching; + } + if (defined $sub_mboxmode) { + $mboxmode = $sub_mboxmode; + } + if (defined $sub_mailreader) { + $mailreader = $sub_mailreader; + } +} + +=item B<select> [I<key>B<:>I<value> ...] + +Uses the SOAP interface to output a list of bugs which match the given +selection requirements. + +The following keys are allowed, and may be given multiple times. + +=over 8 + +=item B<package> + +Binary package name. + +=item B<source> + +Source package name. + +=item B<maintainer> + +E-mail address of the maintainer. + +=item B<submitter> + +E-mail address of the submitter. + +=item B<severity> + +Bug severity. + +=item B<status> + +Status of the bug. One of B<open>, B<done>, or B<forwarded>. + +=item B<tag> + +Tags applied to the bug. If B<users> is specified, may include +usertags in addition to the standard tags. + +=item B<owner> + +Bug's owner. + +=item B<correspondent> + +Address of someone who sent mail to the log. + +=item B<affects> + +Bugs which affect this package. + +=item B<bugs> + +List of bugs to search within. + +=item B<users> + +Users to use when looking up usertags. + +=item B<archive> + +Whether to search archived bugs or normal bugs; defaults to B<0> +(i.e. only search normal bugs). As a special case, if archive is +B<both>, both archived and unarchived bugs are returned. + +=back + +For example, to select the set of bugs submitted by +jrandomdeveloper@example.com and tagged B<wontfix>, one would use + +bts select submitter:jrandomdeveloper@example.com tag:wontfix + +If a key is used multiple times then the set of bugs selected includes +those matching any of the supplied values; for example + +bts select package:foo severity:wishlist severity:minor + +returns all bugs of package foo with either wishlist or minor severity. + +=cut + +sub bts_select { + my @args = @_; + my $bugs = Devscripts::Debbugs::select(@args); + if (not defined $bugs) { + die "Error while retrieving bugs from SOAP server"; + } + print map { qq($_\n) } @{$bugs}; +} + +=item B<status> [I<bug> | B<file:>I<file> | B<fields:>I<field>[B<,>I<field> ...] | B<verbose>] ... + +Uses the SOAP interface to output status information for the given bugs +(or as read from the listed files -- use B<-> to indicate STDIN). + +By default, all populated fields for a bug are displayed. + +If B<verbose> is given, empty fields will also be displayed. + +If B<fields> is given, only those fields will be displayed. No validity +checking is performed on any specified fields. + +=cut + +sub bts_status { + my @args = @_; + + my @bugs; + my $showempty = 0; + my %field; + for my $bug (@args) { + if (looks_like_number($bug)) { + push @bugs, $bug; + } elsif ($bug =~ m{^file:(.+)}) { + my $file = $1; + my $fh; + if ($file eq '-') { + $fh = \*STDIN; + } else { + $fh = IO::File->new($file, 'r') + or die "Unable to open $file for reading: $!"; + } + while (<$fh>) { + chomp; + next if /^\s*\#/; + s/\s//g; + next unless looks_like_number($_); + push @bugs, $_; + } + } elsif ($bug =~ m{^fields:(.+)}) { + my $fields = $1; + for my $field (split /,/, $fields) { + $field{ lc $field } = 1; + } + $showempty = 1; + } elsif ($bug =~ m{^verbose$}) { + $showempty = 1; + } + } + my $bugs + = Devscripts::Debbugs::status(map { [bug => $_, indicatesource => 1] } + @bugs); + return if ($bugs eq ""); + + my $first = 1; + for my $bug (keys %{$bugs}) { + print "\n" if not $first; + $first = 0; + my @keys = grep { $_ ne 'bug_num' } + keys %{ $bugs->{$bug} }; + for my $key ('bug_num', @keys) { + if (%field) { + next unless exists $field{$key}; + } + my $out; + if (ref($bugs->{$bug}{$key}) eq 'ARRAY') { + $out .= join(',', @{ $bugs->{$bug}{$key} }); + } elsif (ref($bugs->{$bug}{$key}) eq 'HASH') { + $out .= join(',', + map { $_ . ' => ' . ($bugs->{$bug}{$key}{$_} || '') } + keys %{ $bugs->{$bug}{$key} }); + } else { + $out .= $bugs->{$bug}{$key} || ''; + } + if ($out || $showempty) { + print "$key\t$out\n"; + } + } + } +} + +=item B<clone> I<bug> I<new_ID> [I<new_ID> ...] + +The B<clone> control command allows you to duplicate a I<bug> report. It is useful +in the case where a single report actually indicates that multiple distinct +bugs have occurred. "New IDs" are negative numbers, separated by spaces, +which may be used in subsequent control commands to refer to the newly +duplicated bugs. A new report is generated for each new ID. + +=cut + +sub bts_clone { + my $bug = checkbug(shift) or die "bts clone: clone what bug?\n"; + @_ or die "bts clone: must specify at least one new ID\n"; + foreach (@_) { + $_ =~ /^-\d+$/ or die "bts clone: new IDs must be negative numbers\n"; + $clonedbugs{$_} = 1; + } + mailbts("cloning $bug", "clone $bug " . join(" ", @_)); +} + +sub common_close { + my $bug = checkbug(shift) or die "bts $command[$index]: close what bug?\n"; + my $version = shift; + $version = "" unless defined $version; + opts_done(@_); + mailbts("closing $bug", "close $bug $version"); + return $bug; +} + +# Do not include this in the manpage - it's deprecated +# +# =item B<close> I<bug> I<version> +# +# Close a I<bug>. Remember that using this to close a bug is often bad manners, +# sending an informative mail to nnnnn-done@bugs.debian.org is much better. +# You should specify which I<version> of the package closed the I<bug>, if +# possible. +# +# =cut + +sub bts_close { + my ($bug) = common_close(@_); + warn <<"EOT"; +$progname: Closing $bug as you requested. +Please note that the "$progname close" command is deprecated! +It is usually better to email nnnnnn-done\@$btsserver with +an informative mail. +Please remember to email $bug-submitter\@$btsserver with +an explanation of why you have closed this bug. Thank you! +EOT +} + +=item B<done> I<bug> [I<version>] + +Mark a I<bug> as Done. This forces interactive mode since done messages should +include an explanation why the bug is being closed. You should specify which +I<version> of the package closed the bug, if possible. + +=cut + +sub bts_done { + my ($bug) = common_close(@_); + # Force interactive mode since done mails shouldn't be sent without an + # explanation + if (not $use_mutt) { + $interactive = 'force'; + } + + # Include the submitter in the email, so we act like a mail to -done + $ccsubmitters{"$bug-submitter"} = 1; +} + +=item B<reopen> I<bug> [I<submitter>] + +Reopen a I<bug>, with optional I<submitter>. + +=cut + +sub bts_reopen { + my $bug = checkbug(shift) or die "bts reopen: reopen what bug?\n"; + my $submitter = shift || ''; # optional + opts_done(@_); + mailbts("reopening $bug", "reopen $bug $submitter"); +} + +=item B<archive> I<bug> + +Archive a I<bug> that has previously been archived but is currently not. +The I<bug> must fulfill all of the requirements for archiving with the +exception of those that are time-based. + +=cut + +sub bts_archive { + my $bug = checkbug(shift) or die "bts archive: archive what bug?\n"; + opts_done(@_); + mailbts("archiving $bug", "archive $bug"); +} + +=item B<unarchive> I<bug> + +Unarchive a I<bug> that is currently archived. + +=cut + +sub bts_unarchive { + my $bug = checkbug(shift) or die "bts unarchive: unarchive what bug?\n"; + opts_done(@_); + mailbts("unarchiving $bug", "unarchive $bug"); +} + +=item B<retitle> I<bug> I<title> + +Change the I<title> of the I<bug>. + +=cut + +sub bts_retitle { + my $bug = checkbug(shift) or die "bts retitle: retitle what bug?\n"; + my $title = join(" ", @_); + if (!length $title) { + die "bts retitle: set title of $bug to what?\n"; + } + mailbts("retitle $bug to $title", "retitle $bug $title"); +} + +=item B<summary> I<bug> [I<messagenum>] + +Select a message number that should be used as +the summary of a I<bug>. + +If no message number is given, the summary is cleared. + +=cut + +sub bts_summary { + my $bug = checkbug(shift) + or die "bts summary: change summary of what bug?\n"; + my $msg = shift || ''; + mailbts("summary $bug $msg", "summary $bug $msg"); +} + +=item B<submitter> I<bug> [I<bug> ...] I<submitter-email> + +Change the submitter address of a I<bug> or a number of bugs, with B<!> meaning +`use the address on the current email as the new submitter address'. + +=cut + +sub bts_submitter { + @_ or die "bts submitter: change submitter of what bug?\n"; + my $submitter = checkemail(pop, 1); + if (!defined $submitter) { + die "bts submitter: change submitter to what?\n"; + } + foreach (@_) { + my $bug = checkbug($_) + or die "bts submitter: $_ is not a bug number\n"; + mailbts("submitter $bug", "submitter $bug $submitter"); + } +} + +=item B<reassign> I<bug> [I<bug> ...] I<package> [I<version>] + +Reassign a I<bug> or a number of bugs to a different I<package>. +The I<version> field is optional; see the explanation at +L<https://www.debian.org/Bugs/server-control>. + +=cut + +sub bts_reassign { + my ($bug, @bugs); + while ($_ = shift) { + $bug = checkbug($_, 1) or last; + push @bugs, $bug; + } + @bugs or die "bts reassign: reassign what bug(s)?\n"; + my $package = $_ or die "bts reassign: reassign bug(s) to what package?\n"; + my $version = shift; + $version = "" unless defined $version; + if (length $version and $version !~ /\d/) { + die "bts reassign: version number $version contains no digits!\n"; + } + opts_done(@_); + + foreach $bug (@bugs) { + mailbts("reassign $bug to $package", + "reassign $bug $package $version"); + } + + foreach my $packagename (split /,/, $package) { + $packagename =~ s/^src://; + $ccpackages{$packagename} = 1; + } +} + +=item B<found> I<bug> [I<version>] + +Indicate that a I<bug> was found to exist in a particular package version. +Without I<version>, the list of fixed versions is cleared and the bug is +reopened. + +=cut + +sub bts_found { + my $bug = checkbug(shift) or die "bts found: found what bug?\n"; + my $version = shift; + if (!defined $version) { + warn +"$progname: found has no version number, but sending to the BTS anyway\n"; + $version = ""; + } + opts_done(@_); + mailbts("found $bug in $version", "found $bug $version"); +} + +=item B<notfound> I<bug> I<version> + +Remove the record that I<bug> was encountered in the given version of the +package to which it is assigned. + +=cut + +sub bts_notfound { + my $bug = checkbug(shift) or die "bts notfound: what bug?\n"; + my $version = shift + or die "bts notfound: remove record \#$bug from which version?\n"; + opts_done(@_); + mailbts("notfound $bug in $version", "notfound $bug $version"); +} + +=item B<fixed> I<bug> I<version> + +Indicate that a I<bug> was fixed in a particular package version, without +affecting the I<bug>'s open/closed status. + +=cut + +sub bts_fixed { + my $bug = checkbug(shift) or die "bts fixed: what bug?\n"; + my $version = shift or die "bts fixed: \#$bug fixed in which version?\n"; + opts_done(@_); + mailbts("fixed $bug in $version", "fixed $bug $version"); +} + +=item B<notfixed> I<bug> I<version> + +Remove the record that a I<bug> was fixed in the given version of the +package to which it is assigned. + +This is equivalent to the sequence of commands "B<found> I<bug> I<version>", +"B<notfound> I<bug> I<version>". + +=cut + +sub bts_notfixed { + my $bug = checkbug(shift) or die "bts notfixed: what bug?\n"; + my $version = shift + or die "bts notfixed: remove record \#$bug from which version?\n"; + opts_done(@_); + mailbts("notfixed $bug in $version", "notfixed $bug $version"); +} + +=item B<block> I<bug> B<by>|B<with> I<bug> [I<bug> ...] + +Note that a I<bug> is blocked from being fixed by a set of other bugs. + +=cut + +sub bts_block { + my $bug = checkbug(shift) or die "bts block: what bug is blocked?\n"; + my $word = shift; + if (defined $word && $word ne 'by' && $word ne 'with') { + unshift @_, $word; + } + @_ or die "bts block: need to specify at least two bug numbers\n"; + my @blockers; + foreach (@_) { + my $blocker = checkbug($_) + or die "bts block: some blocking bug number(s) not valid\n"; + push @blockers, $blocker; + } + mailbts("block $bug with @blockers", "block $bug with @blockers"); +} + +=item B<unblock> I<bug> B<by>|B<with> I<bug> [I<bug> ...] + +Note that a I<bug> is no longer blocked from being fixed by a set of other bugs. + +=cut + +sub bts_unblock { + my $bug = checkbug(shift) or die "bts unblock: what bug is blocked?\n"; + my $word = shift; + if (defined $word && $word ne 'by' && $word ne 'with') { + unshift @_, $word; + } + @_ or die "bts unblock: need to specify at least two bug numbers\n"; + my @blockers; + foreach (@_) { + my $blocker = checkbug($_) + or die "bts unblock: some blocking bug number(s) not valid\n"; + push @blockers, $blocker; + } + mailbts("unblock $bug with @blockers", "unblock $bug with @blockers"); +} + +=item B<merge> I<bug> I<bug> [I<bug> ...] + +Merge a set of bugs together. + +=cut + +sub bts_merge { + my @bugs; + foreach (@_) { + my $bug = checkbug($_) + or die "bts merge: some bug number(s) not valid\n"; + push @bugs, $bug; + } + @bugs > 1 + or die + "bts merge: at least two bug numbers to be merged must be specified\n"; + mailbts("merging @bugs", "merge @bugs"); +} + +=item B<forcemerge> I<bug> I<bug> [I<bug> ...] + +Forcibly merge a set of bugs together. The first I<bug> listed is the master bug, +and its settings (those which must be equal in a normal B<merge>) are assigned to +the bugs listed next. + +=cut + +sub bts_forcemerge { + my @bugs; + foreach (@_) { + my $bug = checkbug($_) + or die "bts forcemerge: some bug number(s) not valid\n"; + push @bugs, $bug; + } + @bugs > 1 + or die +"bts forcemerge: at least two bug numbers to be merged must be specified\n"; + mailbts("forcibly merging @bugs", "forcemerge @bugs"); +} + +=item B<unmerge> I<bug> + +Unmerge a I<bug>. + +=cut + +sub bts_unmerge { + my $bug = checkbug(shift) or die "bts unmerge: unmerge what bug?\n"; + opts_done(@_); + mailbts("unmerging $bug", "unmerge $bug"); +} + +=item B<tag> I<bug> [B<+>|B<->|B<=>] I<tag> [I<tag> ...] + +=item B<tags> I<bug> [B<+>|B<->|B<=>] I<tag> [I<tag> ...] + +Set or unset a I<tag> on a I<bug>. The tag may either be the exact tag name +or it may be abbreviated to any unique tag substring. (So using +B<fixed> will set the tag B<fixed>, not B<fixed-upstream>, for example, +but B<fix> would not be acceptable.) Multiple tags may be specified as +well. The two commands (tag and tags) are identical. At least one tag +must be specified, unless the B<=> flag is used, where the command + + bts tags <bug> = + +will remove all tags from the specified I<bug>. + +Adding/removing the B<security> tag will add "team\@security.debian.org" +to the Cc list of the control email. + +The list of valid tags and their significance is available at +L<https://www.debian.org/Bugs/Developer#tags>. The current valid tags +are: + +patch, wontfix, moreinfo, unreproducible, fixed, help, security, upstream, +pending, d-i, confirmed, ipv6, lfs, fixed-upstream, l10n, newcomer, +a11y, ftbfs + +There is also a tag for each release of Debian since "potato". Note +that this list may be out of date, see the website for the most up to +date source. + +=cut + +# note that the tag list is also in the @gtag variable, look for +# "potato" above. +sub bts_tags { + my $bug = checkbug(shift) or die "bts tags: tag what bug?\n"; + if (!@_) { + die "bts tags: set what tag?\n"; + } + # Parse the rest of the command line. + my $base_command = "tags $bug"; + my $commands = []; + + my $curop; + foreach my $tag (@_) { + if ($tag =~ s/^([-+=])//) { + my $op = $1; + if ($op eq '=') { + $curop = '='; + $commands = []; + $ccsecurity = ''; + } elsif (!$curop || $curop ne $op) { + $curop = $op; + } + next unless $tag; + } + if (!$curop) { + $curop = '+'; + } + if ($tag eq 'gift') { + my $gift_flag = $curop; + if ($gift_flag eq '=') { + $gift_flag = '+'; + } + # Backward compatibility: do both gift usertagging and newcomer + # tagging. Gifting should be removed after a suitable migration + # time. See https://wiki.debian.org/qa.debian.org/GiftTag header + # for more info. + mailbts("tagging $bug", "tags $bug + newcomer"); + mailbts( + "gifting $bug", +"user debian-qa\@lists.debian.org\nusertag $bug $gift_flag gift" + ); + next; + } + if (!exists $valid_tags{$tag}) { + # Try prefixes + my @matches = grep /^\Q$tag\E/, @valid_tags; + if (@matches != 1) { + die "bts tags: \"$tag\" is not a " + . (@matches > 1 ? "unique" : "valid") + . " tag prefix. Choose from: " + . join(" ", @valid_tags) . "\n"; + } + $tag = $matches[0]; + } + if (!@$commands || $curop ne $commands->[-1]{op}) { + push(@$commands, { op => $curop, tags => [] }); + } + push(@{ $commands->[-1]{tags} }, $tag); + if ($tag eq "security") { + $ccsecurity = "team\@security.debian.org"; + } + } + + my $command = ''; + foreach my $cmd (@$commands) { + if ($cmd->{op} ne '=' && !@{ $cmd->{tags} }) { + die "bts tags: set what tag?\n"; + } + $command .= " $cmd->{op} " . join(' ', @{ $cmd->{tags} }); + } + if (!$command && $curop eq '=') { + $command = " $curop"; + } + + if ($command) { + mailbts("tagging $bug", $base_command . $command); + } +} + +=item B<affects> I<bug> [B<+>|B<->|B<=>] I<package> [I<package> ...] + +Indicates that a I<bug> affects a I<package> other than that against which it is filed, causing +the I<bug> to be listed by default in the I<package> list of the other I<package>. This should +generally be used where the I<bug> is severe enough to cause multiple reports from users to be +assigned to the wrong package. At least one I<package> must be specified, unless +the B<=> flag is used, where the command + + bts affects <bug> = + +will remove all indications that I<bug> affects other packages. + +=cut + +sub bts_affects { + my $bug = checkbug(shift) + or die "bts affects: mark what bug as affecting another package?\n"; + + if (!@_) { + die "bts affects: mark which package as affected?\n"; + } + # Parse the rest of the command line. + my $command = "affects $bug"; + my $flag = ""; + if ($_[0] =~ /^[-+=]$/) { + $flag = $_[0]; + $command .= " $flag"; + shift; + } elsif ($_[0] =~ s/^([-+=])//) { + $flag = $1; + $command .= " $flag"; + } + + if ($flag ne '=' && !@_) { + die "bts affects: mark which package as affected?\n"; + } + + foreach my $package (@_) { + $command .= " $package"; + } + + mailbts("affects $bug", $command); +} + +=item B<user> I<email> + +Specify a user I<email> address before using the B<usertags> command. + +=cut + +sub bts_user { + my $email = checkemail(shift) + or die "bts user: set user to what email address?\n"; + if (!length $email) { + die "bts user: set user to what email address?\n"; + } + opts_done(@_); + if ($email ne $last_user) { + mailbts("user $email", "user $email"); + } + $last_user = $email; +} + +=item B<usertag> I<bug> [B<+>|B<->|B<=>] I<tag> [I<tag> ...] + +=item B<usertags> I<bug> [B<+>|B<->|B<=>] I<tag> [I<tag> ...] + +Set or unset a user tag on a I<bug>. The I<tag> must be the exact tag name wanted; +there are no defaults or checking of tag names. Multiple tags may be +specified as well. The two commands (B<usertag> and B<usertags>) are identical. +At least one I<tag> must be specified, unless the B<=> flag is used, where the +command + + bts usertags <bug> = + +will remove all user tags from the specified I<bug>. + +=cut + +sub bts_usertags { + my $bug = checkbug(shift) or die "bts usertags: tag what bug?\n"; + if (!@_) { + die "bts usertags: set what user tag?\n"; + } + # Parse the rest of the command line. + my $command = "usertags $bug"; + my $flag = ""; + if ($_[0] =~ /^[-+=]$/) { + $flag = $_[0]; + $command .= " $flag"; + shift; + } elsif ($_[0] =~ s/^([-+=])//) { + $flag = $1; + $command .= " $flag"; + } + + if ($flag ne '=' && !@_) { + die "bts usertags: set what user tag?\n"; + } + + $command .= sprintf(' %s', join(' ', @_)); + + mailbts("usertagging $bug", $command); +} + +=item B<claim> I<bug> [I<claim>] + +Record that you have claimed a I<bug> (e.g. for a bug squashing party). +I<claim> should be a unique token allowing the bugs you have claimed +to be identified; an e-mail address is often used. + +If no I<claim> is specified, the environment variable B<DEBEMAIL> +or B<EMAIL> (checked in that order) is used. + +=cut + +sub bts_claim { + my $bug = checkbug(shift) or die "bts claim: claim what bug?\n"; + my $claim = checkemail(shift) || $ENV{'DEBEMAIL'} || $ENV{'EMAIL'} || ""; + if (!length $claim) { + die "bts claim: use what claim token?\n"; + } + $claim = extractemail($claim); + bts_user("bugsquash\@qa.debian.org"); + bts_usertags("$bug", "+$claim"); +} + +=item B<unclaim> I<bug> [I<claim>] + +Remove the record that you have claimed a bug. + +If no I<claim> is specified, the environment variable B<DEBEMAIL> +or B<EMAIL> (checked in that order) is used. + +=cut + +sub bts_unclaim { + my $bug = checkbug(shift) or die "bts unclaim: unclaim what bug?\n"; + my $claim = checkemail(shift) || $ENV{'DEBEMAIL'} || $ENV{'EMAIL'} || ""; + if (!length $claim) { + die "bts unclaim: use what claim token?\n"; + } + $claim = extractemail($claim); + bts_user("bugsquash\@qa.debian.org"); + bts_usertags("$bug", "-$claim"); +} + +=item B<severity> I<bug> I<severity> + +Change the I<severity> of a I<bug>. Available severities are: B<wishlist>, B<minor>, B<normal>, +B<important>, B<serious>, B<grave>, B<critical>. The severity may be abbreviated to any +unique substring. + +=cut + +sub bts_severity { + my $bug = checkbug(shift) + or die "bts severity: change the severity of what bug?\n"; + my $severity = lc(shift) + or die "bts severity: set \#$bug\'s severity to what?\n"; + my @matches = grep /^\Q$severity\E/i, @valid_severities; + if (@matches != 1) { + die +"bts severity: \"$severity\" is not a valid severity.\nChoose from: @valid_severities\n"; + } + opts_done(@_); + mailbts("severity of $bug is $matches[0]", "severity $bug $matches[0]"); +} + +=item B<forwarded> I<bug> I<address> + +Mark the I<bug> as forwarded to the given I<address> (usually an email address or +a URL for an upstream bug tracker). + +=cut + +sub bts_forwarded { + my $bug = checkbug(shift) + or die "bts forwarded: mark what bug as forwarded?\n"; + my $email = join(' ', @_); + if ($email =~ /$btsserver/) { + die +"bts forwarded: We don't forward bugs within $btsserver, use bts reassign instead\n"; + } + if (!length $email) { + die + "bts forwarded: mark bug $bug as forwarded to what email address?\n"; + } + mailbts("bug $bug is forwarded to $email", "forwarded $bug $email"); +} + +=item B<notforwarded> I<bug> + +Mark a I<bug> as not forwarded. + +=cut + +sub bts_notforwarded { + my $bug = checkbug(shift) or die "bts notforwarded: what bug?\n"; + opts_done(@_); + mailbts("bug $bug is not forwarded", "notforwarded $bug"); +} + +=item B<package> [I<package> ...] + +The following commands will only apply to bugs against the listed +I<package>s; this acts as a safety mechanism for the BTS. If no packages +are listed, this check is turned off again. + +=cut + +sub bts_package { + if (@_) { + bts_limit(map { "package:$_" } @_); + } else { + bts_limit('package'); + } +} + +=item B<limit> [I<key>[B<:>I<value>]] ... + +The following commands will only apply to bugs which meet the specified +criterion; this acts as a safety mechanism for the BTS. If no I<value>s are +listed, the limits for that I<key> are turned off again. If no I<key>s are +specified, all limits are reset. + +=over 8 + +=item B<submitter> + +E-mail address of the submitter. + +=item B<date> + +Date the bug was submitted. + +=item B<subject> + +Subject of the bug. + +=item B<msgid> + +Message-id of the initial bug report. + +=item B<package> + +Binary package name. + +=item B<source> + +Source package name. + +=item B<tag> + +Tags applied to the bug. + +=item B<severity> + +Bug severity. + +=item B<owner> + +Bug's owner. + +=item B<affects> + +Bugs affecting this package. + +=item B<archive> + +Whether to search archived bugs or normal bugs; defaults to B<0> +(i.e. only search normal bugs). As a special case, if archive is +B<both>, both archived and unarchived bugs are returned. + +=back + +For example, to limit the set of bugs affected by the subsequent control +commands to those submitted by jrandomdeveloper@example.com and tagged +B<wontfix>, one would use + +bts limit submitter:jrandomdeveloper@example.com tag:wontfix + +If a key is used multiple times then the set of bugs selected includes +those matching any of the supplied values; for example + +bts limit package:foo severity:wishlist severity:minor + +only applies the subsequent control commands to bugs of package foo with +either B<wishlist> or B<minor> severity. + +=cut + +sub bts_limit { + my @args = @_; + my %limits; + # Ensure we're using the limit fields that debbugs expects. These are the + # keys from Debbugs::Status::fields + my %valid_keys = ( + submitter => 'originator', + date => 'date', + subject => 'subject', + msgid => 'msgid', + package => 'package', + source => 'source', + src => 'source', + tag => 'keywords', + severity => 'severity', + owner => 'owner', + affects => 'affects', + archive => 'unarchived', + ); + for my $arg (@args) { + my ($key, $value) = split /:/, $arg, 2; + next unless $key; + if (!defined $value) { + die "bts limit: No value given for '$key'\n"; + } + if (exists $valid_keys{$key}) { + # Support "$key:" by making it look like "$key", i.e. no $value + # defined + undef $value unless length($value); + if ($key eq "archive") { + if (defined $value) { + # limit looks for unarchived, not archive. Verify we have + # a valid value and then switch the boolean value to match + # archive => unarchive + if ($value =~ /^yes|1|true|on$/i) { + $value = 0; + } elsif ($value =~ /^no|0|false|off$/i) { + $value = 1; + } elsif ($value ne 'both') { + die "bts limit: Invalid value ($value) for archive\n"; + } + } + } + $key = $valid_keys{$key}; + if (defined $value and $value) { + push(@{ $limits{$key} }, $value); + } else { + $limits{$key} = (); + } + } elsif ($key eq 'clear') { + %limits = (); + $limits{$key} = 1; + } else { + die "bts limit: Unrecognized key: $key\n"; + } + } + for my $key (keys %limits) { + if ($key eq 'clear') { + mailbts('clear all limit(s)', 'limit clear'); + next; + } + if (defined $limits{$key}) { + my $value = join ' ', @{ $limits{$key} }; + mailbts("limit $key to $value", "limit $key $value"); + } else { + mailbts("clear $key limit", "limit $key"); + } + } +} + +=item B<owner> I<bug> I<owner-email> + +Change the "owner" address of a I<bug>, with B<!> meaning +`use the address on the current email as the new owner address'. + +The owner of a bug accepts responsibility for dealing with it. + +=cut + +sub bts_owner { + my $bug = checkbug(shift) or die "bts owner: change owner of what bug?\n"; + my $owner = checkemail(shift, 1) + or die "bts owner: change owner to what?\n"; + opts_done(@_); + mailbts("owner $bug", "owner $bug $owner"); +} + +=item B<noowner> I<bug> + +Mark a bug as having no "owner". + +=cut + +sub bts_noowner { + my $bug = checkbug(shift) or die "bts noowner: what bug?\n"; + opts_done(@_); + mailbts("bug $bug has no owner", "noowner $bug"); +} + +=item B<subscribe> I<bug> [I<email>] + +Subscribe the given I<email> address to the specified I<bug> report. If no email +address is specified, the environment variable B<DEBEMAIL> or B<EMAIL> (in that +order) is used. If those are not set, or B<!> is given as email address, +your default address will be used. + +After executing this command, you will be sent a subscription confirmation to +which you have to reply. When subscribed to a bug report, you receive all +relevant emails and notifications. Use the unsubscribe command to unsubscribe. + +=cut + +sub bts_subscribe { + my $bug = checkbug(shift) or die "bts subscribe: subscribe to what bug?\n"; + my $email = checkemail(shift, 1); + $email = lc($email) if defined $email; + if (defined $email and $email eq '!') { $email = undef; } + else { + $email ||= $ENV{'DEBEMAIL'}; + $email ||= $ENV{'EMAIL'}; + $email = extractemail($email) if defined $email; + } + opts_done(@_); + mailto( + 'subscription request for bug #' . $bug, '', + $bug . '-subscribe@' . $btsserver, $email + ); +} + +=item B<unsubscribe> I<bug> [I<email>] + +Unsubscribe the given email address from the specified bug report. As with +subscribe above, if no email address is specified, the environment variables +B<DEBEMAIL> or B<EMAIL> (in that order) is used. If those are not set, or B<!> is +given as email address, your default address will be used. + +After executing this command, you will be sent an unsubscription confirmation +to which you have to reply. Use the B<subscribe> command to, well, subscribe. + +=cut + +sub bts_unsubscribe { + my $bug = checkbug(shift) + or die "bts unsubscribe: unsubscribe from what bug?\n"; + my $email = checkemail(shift, 1); + $email = lc($email) if defined $email; + if (defined $email and $email eq '!') { $email = undef; } + else { + $email ||= $ENV{'DEBEMAIL'}; + $email ||= $ENV{'EMAIL'}; + $email = extractemail($email) if defined $email; + } + opts_done(@_); + mailto( + 'unsubscription request for bug #' . $bug, '', + $bug . '-unsubscribe@' . $btsserver, $email + ); +} + +=item B<reportspam> I<bug> ... + +The B<reportspam> command allows you to report a I<bug> report as containing spam. +It saves one from having to go to the bug web page to do so. + +=cut + +sub bts_reportspam { + my @bugs; + + if (!have_lwp()) { + die "$progname: Couldn't run bts reportspam: $lwp_broken\n"; + } + + foreach (@_) { + my $bug = checkbug($_) + or die "bts reportspam: some bug number(s) not valid\n"; + push @bugs, $bug; + } + @bugs >= 1 + or die "bts reportspam: at least one bug number must be specified\n"; + + init_agent() unless $ua; + foreach my $bug (@bugs) { + my $url = "$btscgispamurl?bug=$bug;ok=ok"; + if ($noaction) { + print "bts reportspam: would report $bug as containing spam (URL: " + . $url . ")\n"; + } else { + my $request = HTTP::Request->new('GET', $url); + my $response = $ua->request($request); + if (!$response->is_success) { + warn "$progname: failed to report $bug as containing spam: " + . $response->status_line . "\n"; + } + } + } +} + +=item B<spamreport> I<bug> ... + +B<spamreport> is a synonym for B<reportspam>. + +=cut + +sub bts_spamreport { + goto &bts_reportspam; +} + +=item B<cache> [I<options>] [I<maint_email> | I<pkg> | B<src:>I<pkg> | B<from:>I<submitter>] + +=item B<cache> [I<options>] [B<release-critical> | B<release-critical/>... | B<RC>] + +Generate or update a cache of bug reports for the given email address +or package. By default it downloads all bugs belonging to the email +address in the B<DEBEMAIL> environment variable (or the B<EMAIL> environment +variable if B<DEBEMAIL> is unset). This command may be repeated to cache +bugs belonging to several people or packages. If multiple packages or +addresses are supplied, bugs belonging to any of the arguments will be +cached; those belonging to more than one of the arguments will only be +downloaded once. The cached bugs are stored in +F<$XDG_CACHE_HOME/devscripts/bts/> or, if B<XDG_CACHE_HOME> is not set, in +F<~/.cache/devscripts/bts/>. + +You can use the cached bugs with the B<-o> switch. For example: + + bts -o bugs + bts -o show 12345 + +Also, B<bts> will update the files in it in a piecemeal fashion as it +downloads information from the BTS using the B<show> command. You might +thus set up the cache, and update the whole thing once a week, while +letting the automatic cache updates update the bugs you frequently +refer to during the week. + +Some options affect the behaviour of the B<cache> command. The first is +the setting of B<--cache-mode>, which controls how much B<bts> downloads +of the referenced links from the bug page, including boring bits such +as the acknowledgement emails, emails to the control bot, and the mbox +version of the bug report. It can take three values: B<min> (the +minimum), B<mbox> (download the minimum plus the mbox version of the bug +report) or B<full> (the whole works). The second is B<--force-refresh> or +B<-f>, which forces the download, even if the cached bug report is +up-to-date. The B<--include-resolved> option indicates whether bug +reports marked as resolved should be downloaded during caching. + +Each of these is configurable from the configuration +file, as described below. They may also be specified after the +B<cache> command as well as at the start of the command line. + +Finally, B<-q> or B<--quiet> will suppress messages about caches being +up-to-date, and giving the option twice will suppress all cache +messages (except for error messages). + +Beware of caching RC, though: it will take a LONG time! (With 1000+ +RC bugs and a delay of 5 seconds between bugs, you're looking at a +minimum of 1.5 hours, and probably significantly more than that.) + +=cut + +sub bts_cache { + @ARGV = @_; + my ($sub_cachemode, $sub_refreshmode, $sub_updatemode); + my $sub_quiet = $quiet; + my $sub_includeresolved = $includeresolved; + GetOptions( + "cache-mode|cachemode=s" => \$sub_cachemode, + "f" => \$sub_refreshmode, + "force-refresh!" => \$sub_refreshmode, + "only-new!" => \$sub_updatemode, + "q|quiet+" => \$sub_quiet, + "include-resolved!" => \$sub_includeresolved, + ) or die "$progname: unknown options for cache command\n"; + @_ = @ARGV; # whatever's left + + if (defined $sub_refreshmode) { + ($refreshmode, $sub_refreshmode) = ($sub_refreshmode, $refreshmode); + } + if (defined $sub_updatemode) { + ($updatemode, $sub_updatemode) = ($sub_updatemode, $updatemode); + } + if (defined $sub_cachemode) { + if ($sub_cachemode =~ $cachemode_re) { + ($cachemode, $sub_cachemode) = ($sub_cachemode, $cachemode); + } else { + warn +"$progname: ignoring invalid --cache-mode $sub_cachemode;\nmust be one of min, mbox, full.\n"; + } + } + # This may be a no-op, we don't mind + ($quiet, $sub_quiet) = ($sub_quiet, $quiet); + ($includeresolved, $sub_includeresolved) + = ($sub_includeresolved, $includeresolved); + + prunecache(); + if (!have_lwp()) { + die "$progname: Couldn't run bts cache: $lwp_broken\n"; + } + + if (!-d $cachedir) { + my $err; + make_path($cachedir, { error => \$err }); + if (@$err) { + my ($path, $msg) = each(%{ $err->[0] }); + die "$progname: couldn't mkdir $path: $msg\n"; + } + } + + download("css/bugs.css"); + + my $tocache; + if (@_ > 0) { $tocache = sanitizething(shift); } + else { $tocache = ''; } + + if (!length $tocache) { + $tocache = $ENV{'DEBEMAIL'} || $ENV{'EMAIL'} || ''; + if ($tocache =~ /^.*\s<(.*)>\s*$/) { $tocache = $1; } + } + if (!length $tocache) { + die "bts cache: cache what?\n"; + } + + my $sub_thgopts = ''; + $sub_thgopts = ';pend-exc=done' + if (!$includeresolved && $tocache !~ /^release-critical/); + + my %bugs = (); + my %oldbugs = (); + + do { + %oldbugs = (%oldbugs, + map { $_ => 1 } bugs_from_thing($tocache, $sub_thgopts)); + + # download index + download($tocache, $sub_thgopts, 1); + + %bugs + = (%bugs, map { $_ => 1 } bugs_from_thing($tocache, $sub_thgopts)); + + $tocache = sanitizething(shift); + } while (defined $tocache); + + # remove old bugs from cache + if (keys %oldbugs) { + tie(%timestamp, "Devscripts::DB_File_Lock", $timestampdb, + O_RDWR() | O_CREAT(), + 0600, $DB_HASH, "write") + or die + "$progname: couldn't open DB file $timestampdb for writing: $!\n" + if !tied %timestamp; + } + + foreach my $bug (keys %oldbugs) { + if (!$bugs{$bug}) { + deletecache($bug); + } + } + + untie %timestamp; + + # download bugs + my $bugcount = 1; + my $bugtotal = scalar keys %bugs; + foreach my $bug (keys %bugs) { + if (-f cachefile($bug, '') and $updatemode) { + print "Skipping $bug as requested ... $bugcount/$bugtotal\n" + if !$quiet; + $bugcount++; + next; + } + download($bug, '', 1, 0, $bugcount, $bugtotal); + sleep $opt_cachedelay; + $bugcount++; + } + + # revert options + if (defined $sub_refreshmode) { + $refreshmode = $sub_refreshmode; + } + if (defined $sub_updatemode) { + $updatemode = $sub_updatemode; + } + if (defined $sub_cachemode) { + $cachemode = $sub_cachemode; + } + $quiet = $sub_quiet; + $includeresolved = $sub_includeresolved; +} + +=item B<cleancache> I<package> | B<src:>I<package> | I<maintainer> + +=item B<cleancache from:>I<submitter> | B<tag:>I<tag> | B<usertag:>I<tag> | I<number> | B<ALL> + +Clean the cache for the specified I<package>, I<maintainer>, etc., as +described above for the B<bugs> command, or clean the entire cache if +B<ALL> is specified. This is useful if you are going to have permanent +network access or if the database has become corrupted for some +reason. Note that for safety, this command does not default to the +value of B<DEBEMAIL> or B<EMAIL>. + +=cut + +sub bts_cleancache { + prunecache(); + my $toclean = sanitizething(shift); + if (!defined $toclean) { + die "bts cleancache: clean what?\n"; + } + if (!-d $cachedir) { + return; + } + if ($toclean eq 'ALL') { + if (system("/bin/rm", "-rf", $cachedir) >> 8 != 0) { + warn "Problems cleaning cache: $!\n"; + } + return; + } + + # clean index + tie(%timestamp, "Devscripts::DB_File_Lock", $timestampdb, + O_RDWR() | O_CREAT(), + 0600, $DB_HASH, "write") + or die "$progname: couldn't open DB file $timestampdb for writing: $!\n" + if !tied %timestamp; + + if ($toclean =~ /^\d+$/) { + # single bug only + deletecache($toclean); + } else { + my @bugs_to_clean = bugs_from_thing($toclean); + deletecache($toclean); + + # remove old bugs from cache + foreach my $bug (@bugs_to_clean) { + deletecache($bug); + } + } + + untie %timestamp; +} + +=item B<listcachedbugs> [I<number>] + +List cached bug ids (intended to support bash completion). The optional number argument +restricts the list to those bug ids that start with that number. + +=cut + +sub bts_listcachedbugs { + my $number = shift; + if (not defined $number) { + $number = ''; + } + if ($number =~ m{\D}) { + return; + } + my $untie = 0; + if (not tied %timestamp) { + tie(%timestamp, "Devscripts::DB_File_Lock", $timestampdb, + O_RDONLY(), 0600, $DB_HASH, "read") + or die + "$progname: couldn't open DB file $timestampdb for reading: $!\n"; + $untie = 1; + } + + print join "\n", grep { $_ =~ m{^$number\d+$} } sort keys %timestamp; + print "\n"; + + if ($untie) { + untie %timestamp; + } +} + +# Add any new commands here. + +=item B<version> + +Display version and copyright information. + +=cut + +sub bts_version { + print <<"EOF"; +$progname version $version +Copyright (C) 2001-2003 by Joey Hess <joeyh\@debian.org>. +Modifications Copyright (C) 2002-2004 by Julian Gilbey <jdg\@debian.org>. +Modifications Copyright (C) 2007 by Josh Triplett <josh\@freedesktop.org>. +It is licensed under the terms of the GPL, either version 2 of the +License, or (at your option) any later version. +EOF +} + +=item B<help> + +Display a short summary of commands, suspiciously similar to parts of this +man page. + +=cut + +# Other supporting subs + +# This must be the last bts_* sub +sub bts_help { + my $inlist = 0; + my $insublist = 0; + print <<"EOF"; +Usage: $progname [options] command [args] [\#comment] [.|, command ... ] +Valid options are: + -o, --offline Do not attempt to connect to BTS for show/bug + commands: use cached copy + --online, --no-offline Attempt to connect (default) + -n, --no-action Do not send emails but print them to standard output. + --no-cache Do not attempt to cache new versions of BTS + pages when performing show/bug commands + --cache Do attempt to cache new versions of BTS + pages when performing show/bug commands (default) + --cache-mode={min|mbox|full} + How much to cache when we are caching: the sensible + bare minimum (default), the mbox as well, or + everything? + --cache-delay=seconds Time to sleep between each download when caching. + -m, --mbox With show or bugs, open a mailreader to read the mbox + version instead + --mailreader=CMD Run CMD to read an mbox; default is 'mutt -f %s' + (must contain %s, which is replaced by mbox name) + --cc-addr=CC_EMAIL_ADDRESS + Send carbon copies to a list of users. + CC_EMAIL_ADDRESS should be a comma-separated list of + e-mail addresses. Multiple options add more CCs. + --use-default-cc Send carbon copies to any addresses specified in the + configuration file BTS_DEFAULT_CC (default) + --no-use-default-cc Do not do so + --sendmail=cmd Sendmail command to use (default /usr/sbin/sendmail) + --mutt Use mutt for sending of mails. + --no-mutt Do not do so (default) + --smtp-host=host SMTP host to use + --smtp-username=user } Credentials to use when connecting to an SMTP + --smtp-password=pass } server which requires authentication + --smtp-helo=helo HELO to use when connecting to the SMTP server; + (defaults to the content of /etc/mailname) + --bts-server The name of the debbugs server to use + (default https://bugs.debian.org) + -f, --force-refresh Reload all bug reports being cached, even unchanged + ones + --no-force-refresh Do not do so (default) + --only-new Download only new bugs when caching. Do not check + for updates in bugs we already have. + --include-resolved Cache bugs marked as resolved (default) + --no-include-resolved Do not cache bugs marked as resolved + --no-ack Suppress BTS acknowledgment mails + --ack Do not do so (default) + -i, --interactive Prompt for confirmation before sending e-mail + --force-interactive Same as --interactive, with the exception that an + editor is spawned before confirmation is requested + --no-interactive Do not do so (default) + -q, --quiet Only display information about newly cached pages. + If given twice, only display error messages. + --no-conf, --noconf Do not read devscripts config files; + must be the first option given + -h, --help Display this message + -v, --version Display version and copyright info + +Default settings modified by devscripts configuration files: +$modified_conf_msg + +Valid commands are: +EOF + seek DATA, 0, 0; + while (<DATA>) { + $inlist = 1 if /^=over 4/; + next unless $inlist; + $insublist = 1 if /^=over [^4]/; + $insublist = 0 if /^=back/; + if (/^=item\sB<([^->].*)>/ and !$insublist) { + if ($1 eq 'help') { + last; + } + # Strip POD markup before displaying and ensure we don't wrap + # longer lines + my $parser = Pod::BTS->new(width => 100); + $parser->no_whining(1); + $parser->output_fh(\*STDOUT); + $parser->parse_string_document($_); + } + } +} + +# Strips any leading # or Bug# and trailing : from a thing if what's left is +# a pure positive number; +# also RC is a synonym for release-critical/other/all.html +sub sanitizething { + my $bug = $_[0]; + defined $bug or return undef; + + return 'release-critical/other/all.html' if $bug eq 'RC'; + return 'release-critical/index.html' if $bug eq 'release-critical'; + $bug =~ s/^(?:(?:Bug)?\#)?(\d+):?$/$1/; + return $bug; +} + +# Perform basic validation of an argument which should be an email address, +# handling ! if allowed +sub checkemail { + my $email = $_[0] or return; + my $allowbang = $_[1]; + + if ($email !~ /\@/ && (!$allowbang || $email ne '!')) { + return; + } + + return $email; +} + +# Validate a bug number. Strips out extraneous leading junk, allowing +# for things like "#74041" and "Bug#94921" +sub checkbug { + my $bug = $_[0] or return ""; + my $quiet = $_[1] || 0; # used when we don't want warnings from checkbug + + if ($bug eq 'it') { + if (not defined $it) { + die +"$progname: You specified 'it', but no previous bug number referenced!\n"; + } + } else { + $bug =~ s/^(?:(?:bug)?\#)?(-?\d+):?$/$1/i; + if (!exists $clonedbugs{$bug} + && (!length $bug || $bug !~ /^[0-9]+$/)) { + warn "\"$_[0]\" does not look like a bug number\n" unless $quiet; + return ""; + } + + # Valid, now set $it to this so that we can refer to it by 'it' later + $it = $bug; + } + + return $it; +} + +# Stores up some extra information for a mail to the bts. +sub mailbts { + if ($subject eq '') { + $subject = $_[0]; + } elsif (length($subject) + length($_[0]) < 100) { + $subject .= ", $_[0]" if length($_[0]); + } elsif ($subject !~ / ...$/) { + $subject .= " ..."; + } + $body .= "$comment[$index]\n" if $comment[$index]; + $body .= "$_[1]\n"; +} + +# Extract an array of email addresses from a string +sub extract_addresses { + my $s = shift; + my @addresses; + + # Original regular expression from git-send-email, slightly modified + while ($s and $s =~ /([^,<>"\s\@]+\@[^.,<>"\s@]+(?:\.[^.,<>"\s\@]+)+)(.*)/) + { + push @addresses, $1; + $s = $2; + } + return @addresses; +} + +# Send one full mail message using the smtphost or sendmail. +sub send_mail { + my ($from, $to, $cc, $subject, $body) = @_; + + my @fromaddresses = extract_addresses($from); + unless (@fromaddresses) { + die "Something went wrong: no from address" unless $noaction; + @fromaddresses = ($from = '<undefined>'); + } + my $fromaddress = $fromaddresses[0]; + # Message-ID algorithm from git-send-email + my $msgid + = sprintf("%s-%s", time(), int(rand(4200))) . "-bts-$fromaddress"; + my $date = strftime "%a, %d %b %Y %T %z", localtime; + + my $message = fold_from_header("From: $from") . "\n"; + $message .= "To: $to\n" if length $to; + $message .= "Cc: $cc\n" if length $cc; + $message .= "X-Debbugs-No-Ack: Yes\n" if not $requestack; + $message + .= "Subject: $subject\n" + . "Date: $date\n" + . "User-Agent: devscripts bts/$version$toolname\n" + . "Message-ID: <$msgid>\n" . "\n"; + + $body = addfooter($body); + ($message, $body) = confirmmail($message, $body); + + return if not defined $body; + + $message .= "$body\n"; + if ($noaction) { + print "$message\n"; + } elsif ($use_mutt) { + my ($fh, $filename) = tempfile( + "btsXXXXXX", + SUFFIX => ".mail", + DIR => File::Spec->tmpdir, + UNLINK => 1 + ); + open(MAILOUT, ">&", $fh) + or die "$progname: writing to temporary file: $!\n"; + + print MAILOUT $message; + + my $mailcmd = $muttcmd; + $mailcmd =~ s/\%([%s])/$1 eq '%' ? '%' : $filename/eg; + + exec($mailcmd) or die "$progname: unable to start mailclient: $!"; + } elsif (length $smtphost) { + my $smtp; + + if ($smtphost =~ m%^(?:(?:ssmtp|smtps)://)(.*)$%) { + my ($host, $port) = split(/:/, $1); + $port ||= '465'; + + $smtp = Net::SMTP->new( + $host, + Port => $port, + Hello => $smtphelo, + SSL => 1, + ) + or die +"$progname: failed to open SMTP connection with TLS to $smtphost\n($@)\n"; + } else { + my ($host, $port) = split(/:/, $smtphost); + $port ||= '25'; + + $smtp = Net::SMTP->new( + $host, + Port => $port, + Hello => $smtphelo, + ) + or die + "$progname: failed to open SMTP connection to $smtphost\n($@)\n"; + } + if ($smtpuser) { + if (have_authen_sasl) { + $smtppass = getpass() if not $smtppass; + $smtp->auth($smtpuser, $smtppass) + or die + "$progname: failed to authenticate to $smtphost\n($@)\n"; + } else { + die +"$progname: failed to authenticate to $smtphost: $authen_sasl_broken\n"; + } + } + $smtp->mail($fromaddress) + or die + "$progname: failed to set SMTP from address $fromaddress\n($@)\n"; + my @addresses = extract_addresses($to); + push @addresses, extract_addresses($cc); + foreach my $address (@addresses) { + $smtp->recipient($address) + or die + "$progname: failed to set SMTP recipient $address\n($@)\n"; + } + $smtp->data($message) + or die "$progname: failed to send message as SMTP DATA\n($@)\n"; + $smtp->quit + or die "$progname: failed to quit SMTP connection\n($@)\n"; + } else { + my $pid = open(MAIL, "|-"); + if (!defined $pid) { + die "$progname: Couldn't fork: $!\n"; + } + $SIG{'PIPE'} = sub { die "$progname: pipe for $sendmailcmd broke\n"; }; + if ($pid) { + # parent + print MAIL $message; + close MAIL or die "$progname: $sendmailcmd error: $!\n"; + } else { + # child + if ($debug) { + exec("/bin/cat") + or die "$progname: error running cat: $!\n"; + } else { + my @mailcmd = split ' ', $sendmailcmd; + push @mailcmd, "-t" if $sendmailcmd =~ /$sendmail_t/; + exec @mailcmd + or die "$progname: error running $sendmailcmd: $!\n"; + } + } + } +} + +sub generate_packages_cc { + my @ccs; + if (keys %ccpackages && $packagesserver) { + push @ccs, map { "$_\@$packagesserver" } sort keys %ccpackages; + } + if (keys %ccsubmitters && $btsserver) { + push @ccs, map { "$_\@$btsserver" } sort keys %ccsubmitters; + } + return @ccs; +} + +# Sends all cached mail to the bts (duh). +sub mailbtsall { + my $subject = shift; + my $body = shift; + + my $charset = `locale charmap`; + chomp $charset; + $charset =~ s/^ANSI_X3\.4-19(68|86)$/US-ASCII/; + $subject = MIME_encode_mimewords($subject, 'Charset' => $charset); + + if ($interactive eq 'force' || $use_mutt) { + push @ccemails, generate_packages_cc(); + } + if ($ccsecurity) { + push @ccemails, $ccsecurity; + } + my $ccemail = join(', ', @ccemails); + if ($ENV{'DEBEMAIL'} || $ENV{'EMAIL'}) { + # We need to fake the From: line + my ($email, $name); + if (exists $ENV{'DEBFULLNAME'}) { $name = $ENV{'DEBFULLNAME'}; } + if (exists $ENV{'DEBEMAIL'}) { + $email = $ENV{'DEBEMAIL'}; + if ($email =~ /^(.*?)\s+<(.*)>\s*$/) { + $name ||= $1; + $email = $2; + } + } + if (exists $ENV{'EMAIL'}) { + if ($ENV{'EMAIL'} =~ /^(.*?)\s+<(.*)>\s*$/) { + $name ||= $1; + $email ||= $2; + } else { + $email ||= $ENV{'EMAIL'}; + } + } + if (!$name) { + # Perhaps not ideal, but it will have to do + $name = (getpwuid($<))[6]; + $name =~ s/,.*//; + } + my $from = $name ? "$name <$email>" : $email; + $from = MIME_encode_mimewords($from, 'Charset' => $charset); + + send_mail($from, $btsemail, $ccemail, $subject, $body); + } else { # No DEBEMAIL + my $header = ""; + + $header = "To: $btsemail\n"; + $header .= "Cc: $ccemail\n" if length $ccemail; + $header .= "X-Debbugs-No-Ack: Yes\n" if not $requestack; + $header .= "Subject: $subject\n" + . "User-Agent: devscripts bts/$version$toolname\n" . "\n"; + + $body = addfooter($body); + ($header, $body) = confirmmail($header, $body); + + return if not defined $body; + + if ($noaction) { + print "$header$body\n"; + return; + } + + my $pid = open(MAIL, "|-"); + if (!defined $pid) { + die "$progname: Couldn't fork: $!\n"; + } + $SIG{'PIPE'} = sub { die "$progname: pipe for $sendmailcmd broke\n"; }; + if ($pid) { + # parent + print MAIL $header; + print MAIL $body; + close MAIL or die "$progname: $sendmailcmd: $!\n"; + } else { + # child + if ($debug) { + exec("/bin/cat") + or die "$progname: error running cat: $!\n"; + } else { + my @mailcmd = split ' ', $sendmailcmd; + push @mailcmd, "-t" if $sendmailcmd =~ /$sendmail_t/; + exec @mailcmd + or die "$progname: error running $sendmailcmd: $!\n"; + } + } + } +} + +sub confirmmail { + my ($header, $body) = @_; + + return ($header, $body) if $noaction; + + $body = edit($body) if $interactive eq 'force'; + my $setHeader = 0; + if ($interactive ne 'no') { + while (1) { + print "\n", $header, "\n", $body, "\n---\n"; + print "OK to send? [Y/n/e] "; + $_ = <STDIN>; + if (/^n/i) { + $body = undef; + last; + } elsif (/^(y|$)/i) { + last; + } elsif (/^e/i) { + # Since the user has chosen to edit the message, we go ahead + # and add the $ccpackages Ccs (if they haven't already been + # added due to interactive). + if ($interactive ne 'force' && !$setHeader) { + $setHeader = 1; + my @ccemails = generate_packages_cc(); + my $ccs = join(', ', @ccemails); + if ($header =~ m/^Cc: (.*?)$/m) { + $ccs = "$1, $ccs"; + $header =~ s/^Cc: .*?$/Cc: $ccs/m; + } else { + $header =~ s/^(To: .*?)$/$1\nCc: $ccs/m; + } + } + $body = edit($body); + } + } + } + + return ($header, $body); +} + +sub addfooter() { + my $body = shift; + + $body .= "thanks\n"; + if ($interactive eq 'force') { + if (-r $ENV{'HOME'} . "/.signature") { + if (open SIG, "<", $ENV{'HOME'} . "/.signature") { + $body .= "-- \n"; + while (<SIG>) { + $body .= $_; + } + close SIG; + } + } + } + + return $body; +} + +sub getpass() { + system "stty -echo cbreak </dev/tty"; + die "$progname: error disabling stty echo\n" if $?; + print "\a${smtpuser}"; + print "\@$smtphost" if $smtpuser !~ /\@/; + print "'s SMTP password: "; + $_ = <STDIN>; + chomp; + print "\n"; + system "stty echo -cbreak </dev/tty"; + die "$progname: error enabling stty echo\n" if $?; + return $_; +} + +sub extractemail() { + my $thing = shift or die "$progname: extract e-mail from what?\n"; + + if ($thing =~ /^(.*?)\s+<(.*)>\s*$/) { + $thing = $2; + } + + return $thing; +} + +# A simplified version of mailbtsall which sends one message only to +# a specified address using the specified email From: header +sub mailto { + my ($subject, $body, $to, $from) = @_; + + if (defined($from) || $noaction) { + send_mail($from, $to, '', $subject, $body); + } else { # No $from + unless (system("command -v mailx >/dev/null 2>&1") == 0) { + die +"$progname: You need to either specify an email address (say using DEBEMAIL)\nor have the bsd-mailx package (or another package providing mailx) installed\nto send mail!\n"; + } + my $pid = open(MAIL, "|-"); + if (!defined $pid) { + die "$progname: Couldn't fork: $!\n"; + } + $SIG{'PIPE'} = sub { die "$progname: pipe for mailx broke\n"; }; + if ($pid) { + # parent + print MAIL $body; + close MAIL or die "$progname: mailx: $!\n"; + } else { + # child + if ($debug) { + exec("/bin/cat") + or die "$progname: error running cat: $!\n"; + } else { + exec("mailx", "-s", $subject, $to) + or die "$progname: error running mailx: $!\n"; + } + } + } +} + +# The following routines are taken from a patched version of MIME::Words +# posted at http://mail.nl.linux.org/linux-utf8/2002-01/msg00242.html +# by Richard Čepas (Chepas) <rch@richard.eu.org> + +sub MIME_encode_B { + my $str = shift; + require MIME::Base64; + MIME::Base64::encode_base64($str, ''); +} + +sub MIME_encode_Q { + my $str = shift; + $str + =~ s{([_\?\=\015\012\t $NONPRINT])}{$1 eq ' ' ? '_' : sprintf("=%02X", ord($1))}eog + ; # RFC-2047, Q rule 3 + $str; +} + +sub MIME_encode_mimeword { + my $word = shift; + my $encoding = uc(shift || 'Q'); + my $charset = uc(shift || 'ISO-8859-1'); + my $encfunc = (($encoding eq 'Q') ? \&MIME_encode_Q : \&MIME_encode_B); + "=?$charset?$encoding?" . &$encfunc($word) . "?="; +} + +sub MIME_encode_mimewords { + my ($rawstr, %params) = @_; + # check if we have something to encode + $rawstr !~ /[$NONPRINT]/o and $rawstr !~ /\=\?/o and return $rawstr; + my $charset = $params{Charset} || 'ISO-8859-1'; + # if there is 1/3 unsafe bytes, the Q encoded string will be 1.66 times + # longer and B encoded string will be 1.33 times longer than original one + my $encoding = lc( + $params{Encoding} + || ( + length($rawstr) > 3 * ($rawstr =~ tr/[\x00-\x1F\x7F-\xFF]//) + ? 'q' + : 'b' + )); + + # Encode any "words" with unsafe bytes. + my ($last_token, $last_word_encoded, $token) = ('', 0); + $rawstr =~ s{([^\015\012\t ]+|[\015\012\t ]+)}{ # get next "word" + $token = $1; + if ($token =~ /[\015\012\t ]+/) { # white-space + $last_token = $token; + } else { + if ($token !~ /[$NONPRINT]/o and $token !~ /\=\?/o) { + # no unsafe bytes, leave as it is + $last_word_encoded = 0; + $last_token = $token; + } else { + # has unsafe bytes, encode to one or more encoded words + # white-space between two encoded words is skipped on + # decoding, so we should encode space in that case + $_ = $last_token =~ /[\015\012\t ]+/ && $last_word_encoded ? $last_token.$token : $token; + # We limit such words to about 18 bytes, to guarantee that the + # worst-case encoding give us no more than 54 + ~10 < 75 bytes + s{(.{1,15}[\x80-\xBF]{0,4})}{ + # don't split multibyte characters - this regexp should + # work for UTF-8 characters + MIME_encode_mimeword($1, $encoding, $charset).' '; + }sxeg; + $_ = substr($_, 0, -1); # remove trailing space + $last_word_encoded = 1; + $last_token = $token; + $_; + } + } + }sxeg; + $rawstr; +} + +# This is a stripped-down version of Mail::Header::_fold_line, but is +# not as general-purpose as the original, so take care if using it elsewhere! +# The heuristics are changed to prevent splitting in the middle of an +# encoded word; we should not have any commas or semicolons! +sub fold_from_header { + my $header = shift; + chomp $header; # We assume there wasn't a newline anyhow + + my $maxlen = 76; + my $max = int($maxlen - 5); # 4 for leading spcs + 1 for [\,\;] + + if (length($header) > $maxlen) { + # Split the line up: + # first split at a whitespace, + # else we are looking at a single word and we won't try to split + # it, even though we really ought to + # But this could only happen if someone deliberately uses a really + # long name with no spaces in it. + my @x; + + push @x, $1 + while ( + $header =~ s/^\s* + ([^\"]{1,$max}\s + |[^\s\"]*(?:\"[^\"]*\"[ \t]?[^\s\"]*)+\s + |[^\s\"]+\s + ) + //x + ); + push @x, $header; + map { s/\s*$// } @x; + if (@x > 1 and length($x[-1]) + length($x[-2]) < $max) { + $x[-2] .= " $x[-1]"; + pop @x; + } + $x[0] =~ s/^\s*//; + $header = join("\n ", @x); + } + + $header =~ s/^(\S+)\n\s*(?=\S)/$1 /so; + return $header; +} + +########## Browsing and caching subroutines + +# Mirrors a given thing; if the online version is no newer than our +# cached version, then returns an empty string, otherwise returns the +# live thing as a (non-empty) string +sub download { + my $thing = shift; + my $thgopts = shift || ''; + my $manual = shift; # true="bts cache", false="bts show/bug" + my $mboxing = shift; # true="bts --mbox show/bugs", and only if $manual=0 + my $bug_current = shift; # current bug being downloaded if caching + my $bug_total = shift; # total things to download if caching + my $timestamp = 0; + my $versionstamp = ''; + my $url; + + my $oldcwd = getcwd; + + # What URL are we to download? + if ($thgopts ne '') { + # have to be intelligent here :/ + $url = thing_to_url($thing) . $thgopts; + } else { + # let the BTS be intelligent + $url = "$btsurl$thing"; + } + + if (!-d $cachedir) { + die "$progname: download() called but no cachedir!\n"; + } + + chdir($cachedir) || die "$progname: chdir $cachedir: $!\n"; + + if (-f cachefile($thing, $thgopts)) { + ($timestamp, $versionstamp) = get_timestamp($thing, $thgopts); + $timestamp ||= 0; + $versionstamp ||= 0; + # And ensure we preserve any manual setting + if (is_manual($timestamp)) { $manual = 1; } + } + + # do we actually have to do more than we might have thought? + # yes, if we've caching with --cache-mode=mbox or full and the bug had + # previously been cached in a less thorough format + my $forcedownload = 0; + if ($thing =~ /^\d+$/ and !$refreshmode) { + if (old_cache_format_version($versionstamp)) { + $forcedownload = 1; + } elsif ($cachemode ne 'min' or $mboxing) { + if (!-r mboxfile($thing)) { + $forcedownload = 1; + } elsif ($cachemode eq 'full' and -d $thing) { + opendir DIR, $thing + or die "$progname: opendir $cachedir/$thing: $!\n"; + my @htmlfiles = grep { /^\d+\.html$/ } readdir(DIR); + closedir DIR; + $forcedownload = 1 unless @htmlfiles; + } + } + } + + print "Downloading $url ... " + if !$quiet + and $manual + and $thing ne "css/bugs.css"; + IO::Handle::flush(\*STDOUT); + my ($ret, $msg, $livepage, $contenttype) + = bts_mirror($url, $timestamp, $forcedownload); + my $charset = $contenttype || ''; + if ($charset =~ m/charset=(.*?)(;|\Z)/) { + $charset = $1; + } else { + $charset = ""; + } + if ($ret == MIRROR_UP_TO_DATE) { + # we have an up-to-date version already, nothing to do + # and $timestamp is guaranteed to be well-defined + if (is_automatic($timestamp) and $manual) { + set_timestamp($thing, $thgopts, make_manual($timestamp), + $versionstamp); + } + + if (!$quiet and $manual and $thing ne "css/bugs.css") { + print "(cache already up-to-date) "; + print "$bug_current/$bug_total" if $bug_total; + print "\n"; + } + chdir $oldcwd or die "$progname: chdir $oldcwd failed: $!\n"; + return ""; + } elsif ($ret == MIRROR_DOWNLOADED) { + # Note the current timestamp, but don't record it until + # we've successfully stashed the data away + $timestamp = time; + + die "$progname: empty page downloaded\n" unless length $livepage; + + my $bug2filename = {}; + + if ($thing =~ /^\d+$/) { + # we've downloaded an individual bug, and it's been updated, + # so we need to also download all the attachments + $bug2filename + = download_attachments($thing, $livepage, $timestamp); + } + + my $data = $livepage; # work on a copy, not the original + my $cachefile = cachefile($thing, $thgopts); + open(OUT_CACHE, ">$cachefile") + or die "$progname: open $cachefile: $!\n"; + + $data = mangle_cache_file($data, $thing, $bug2filename, $timestamp, + $charset ? $contenttype : ''); + print OUT_CACHE $data; + close OUT_CACHE + or die "$progname: problems writing to $cachefile: $!\n"; + + set_timestamp($thing, $thgopts, + $manual ? make_manual($timestamp) : make_automatic($timestamp), + $version); + + if (!$quiet and $manual and $thing ne "css/bugs.css") { + print "(cached new version) "; + print "$bug_current/$bug_total" if $bug_total; + print "\n"; + } elsif ($quiet == 1 and $manual and $thing ne "css/bugs.css") { + print "Downloading $url ... (cached new version)\n"; + } elsif ($quiet > 1) { + # do nothing + } + + # Add a <base> tag to the live page content, so that relative urls + # in it work when it's passed to the web browser. + my $base = $url; + $base =~ s%/[^/]*$%%; + $livepage =~ s%<head>%<head><base href="$base">%i; + + chdir $oldcwd or die "$progname: chdir $oldcwd failed: $!\n"; + return $livepage; + } else { + die "$progname: couldn't download $url:\n$msg\n"; + } +} + +sub download_attachments { + my ($thing, $toppage, $timestamp) = @_; + my %bug2filename; + + # We search for appropriate strings in the top page, and save the + # attachments in files with names as follows: + # - if the attachment specifies a filename, save as bug#/msg#-att#/filename + # - if not, save as bug#/msg#-att# with suffix .txt if plain/text and + # .html if plain/html, no suffix otherwise (too much like hard work!) + # Since messages are never modified retrospectively, we don't download + # attachments which have already been downloaded + + # Yuck, yuck, yuck. This regex splits the $data string at every + # occurrence of either "[<a " or plain "<a ", preserving any "[". + my @data = split /(?:(?=\[<[Aa]\s)|(?<!\[)(?=<[Aa]\s))/, $toppage; + foreach (@data) { + next + unless +m%<a(?: class=\".*?\")? href="(?:/cgi(?:-bin)?/)?((bugreport\.cgi[^\"]+)"(?: .*?)?>|(version\.cgi[^\"]+)"><img[^>]* src="(?:/cgi(?:-bin)?/)?([^\"]+)">|(version\.cgi[^\"]+)">)%i; + + my $ref = $5; + $ref = $4 if not defined $ref; + $ref = $2 if not defined $ref; + + my ($msg, $filename) = href_to_filename($_); + + next unless defined $msg; + + if ($msg =~ /^\d+-\d+$/) { + # it's an attachment, must download + + if (-f dirname($filename)) { + warn +"$progname: found file where directory expected; using existing file (" + . dirname($filename) . ")\n"; + $bug2filename{$msg} = dirname($filename); + } else { + $bug2filename{$msg} = $filename; + } + + # already downloaded? + next if -f $bug2filename{$msg} and not $refreshmode; + } elsif ($cachemode eq 'full' and $msg =~ /^\d+$/) { + $bug2filename{$msg} = $filename; + # already downloaded? + next if -f $bug2filename{$msg} and not $refreshmode; + } elsif ($cachemode eq 'full' and $msg =~ /^\d+-mbox$/) { + $bug2filename{$msg} = $filename; + # already downloaded? + next if -f $bug2filename{$msg} and not $refreshmode; + } elsif (($cachemode eq 'full' or $cachemode eq 'mbox' or $mboxmode) + and $msg eq 'mbox') { + $bug2filename{$msg} = $filename; + # This always needs refreshing, as it does change as the bug + # changes + } elsif ($cachemode eq 'full' and $msg =~ /^(status|raw)mbox$/) { + $bug2filename{$msg} = $filename; + # Always need refreshing, as they could change each time the + # bug does + } elsif ($cachemode eq 'full' and $msg eq 'versions') { + $bug2filename{$msg} = $filename; + # Ensure we always download the full size images for + # version graphs, without the informational links + $ref =~ s%;info=1%;info=0%; + $ref =~ s%(;|\?)(height|width)=\d+%$1%g; + # already downloaded? + next if -f $bug2filename{$msg} and not $refreshmode; + } + + next unless exists $bug2filename{$msg}; + + warn "bts debug: downloading $btscgiurl$ref\n" if $debug; + init_agent() unless $ua; # shouldn't be necessary, but do just in case + my $request = HTTP::Request->new('GET', $btscgiurl . $ref); + my $response = $ua->request($request); + if ($response->is_success) { + my $content_length + = defined $response->content ? length($response->content) : 0; + if ($content_length == 0) { + warn + "$progname: failed to download $ref (length 0), skipping\n"; + next; + } + + my $data = $response->content; + + if ($msg =~ /^\d+$/) { + # we're dealing with a boring message, and so we must be + # in 'full' mode + $data =~ s%<HEAD>%<HEAD><BASE href="../">%; + $data = mangle_cache_file($data, $thing, 'full', $timestamp); + } + make_path(dirname($bug2filename{$msg})); + open OUT_CACHE, ">$bug2filename{$msg}" + or die "$progname: open cache $bug2filename{$msg}\n"; + print OUT_CACHE $data; + close OUT_CACHE; + } else { + my $status = $response->status_line; + warn "$progname: failed to download $ref ($status), skipping\n"; + next; + } + } + + return \%bug2filename; +} + +# Download the mailbox for a given bug, return mbox ($fh, filename) on success, +# die on failure +sub download_mbox { + my $thing = shift; + my $temp = shift; # do we wish to store it in cache or in a temp file? + my $mboxfile = mboxfile($thing); + + die "$progname: trying to download mbox for illegal bug number $thing.\n" + unless $mboxfile; + + if (!have_lwp()) { + die "$progname: couldn't run bts --mbox: $lwp_broken\n"; + } + init_agent() unless $ua; + + my $request = HTTP::Request->new('GET', + $btscgiurl . "bugreport.cgi?bug=$thing;mboxmaint=yes"); + my $response = $ua->request($request); + if ($response->is_success) { + my $content_length + = defined $response->content ? length($response->content) : 0; + if ($content_length == 0) { + die "$progname: failed to download mbox (length 0).\n"; + } + + my ($fh, $filename); + if ($temp) { + ($fh, $filename) = tempfile( + "btsXXXXXX", + SUFFIX => ".mbox", + DIR => File::Spec->tmpdir, + UNLINK => 1 + ); + # Use filehandle for security + open(OUT_MBOX, ">&", $fh) + or die "$progname: writing to temporary file: $!\n"; + } else { + $filename = $mboxfile; + open(OUT_MBOX, ">$mboxfile") + or die "$progname: writing to mbox file $mboxfile: $!\n"; + } + print OUT_MBOX $response->content; + close OUT_MBOX; + + return ($fh, $filename); + } else { + my $status = $response->status_line; + die "$progname: failed to download mbox ($status).\n"; + } +} + +# Mangle downloaded file to work in the local cache, so +# selectively modify the links +sub mangle_cache_file { + my ($data, $thing, $bug2filename, $timestamp, $ctype) = @_; + my $fullmode = !ref $bug2filename; + + # Undo unnecessary '+' encoding in URLs + while ($data =~ s!(href=\"[^\"]*)\%2b!$1+!ig) { } + my $time = localtime(abs($timestamp)); + $data + =~ s%(<BODY.*>)%$1<p><em>[Locally cached on $time by devscripts version $version]</em></p>%i; + $data =~ s%href="/css/bugs.css"%href="bugs.css"%; + if ($ctype) { + $data + =~ s%(<HEAD.*>)%$1<META HTTP-EQUIV="Content-Type" CONTENT="$ctype">%i; + } + + my @data; + # We have to distinguish between release-critical pages and normal BTS + # pages as they have a different structure + if ($thing =~ /^release-critical/) { + @data = split /(?=<[Aa])/, $data; + foreach (@data) { +s%<a href="(https?://$btsserver/cgi(?:-bin)?/bugreport\.cgi.*bug=(\d+)[^\"]*)">(.+?)</a>%<a href="$2.html">$3</a> (<a href="$1">online</a>)%i; +s%<a href="(https?://$btsserver/cgi(?:-bin)?/pkgreport\.cgi.*pkg=([^\"&;]+)[^\"]*)">(.+?)</a>%<a href="$2.html">$3</a> (<a href="$1">online</a>)%i; + # References to other bug lists on bugs.d.o/release-critical + if (m%<a href="((?:debian|other)[-a-z/]+\.html)"%i) { + my $ref = 'release-critical/' . $1; + $ref =~ s%/%_%g; +s%<a href="((?:debian|other)[-a-z/]+\.html)">(.+?)</a>%<a href="$ref">$2</a> (<a href="${btsurl}release-critical/$1">online</a>)%i; + } + # Maintainer email address - YUCK!! +s%<a href="(https?://$btsserver/([^\"?]*\@[^\"?]*))">(.+?)</a>>%<a href="$2.html">$3</a>> (<a href="$1">online</a>)%i; + # Graph - we don't download +s%<img src="graph.png" alt="Graph of RC bugs">%<img src="${btsurl}release-critical/graph.png" alt="Graph of RC bugs (online)">%; + } + } else { + # Yuck, yuck, yuck. This regex splits the $data string at every + # occurrence of either "[<a " or plain "<a ", preserving any "[". + @data = split /(?:(?=\[<[Aa]\s)|(?<!\[)(?=<[Aa]\s))/, $data; + foreach (@data) { + if ( +m%<a(?: class=\".*?\")? href=\"(?:/cgi(?:-bin)?/)?bugreport\.cgi[^\?]*\?.*?;?bug=(\d+)%i + ) { + my $bug = $1; + my ($msg, $filename) = href_to_filename($_); + if ($bug eq $thing and defined $msg) { + if ($fullmode + or (!$fullmode and exists $$bug2filename{$msg})) { +s%<a((?: class=\".*?\")?) href="(?:/cgi(?:-bin)?/)?(bugreport\.cgi[^\"]*)">(.+?)</a>%<a$1 href="$filename">$3</a> (<a$1 href="$btscgiurl$2">online</a>)%i; + } else { +s%<a((?: class=\".*?\")?) href="(?:/cgi(?:-bin)?/)?(bugreport\.cgi[^\"]*)">(.+?)</a>%$3 (<a$1 href="$btscgiurl$2">online</a>)%i; + } + } else { +s%<a((?: class=\".*?\")?) href="(?:/cgi(?:-bin)?/)?(bugreport\.cgi[^\?]*\?.*?bug=(\d+))"(.*?)>(.+?)</a>%<a$1 href="$3.html"$4>$5</a> (<a$1 href="$btscgiurl$2">online</a>)%i; + } + } else { +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>)%gi; +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; +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; +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; +s%<a((?: class=\".*?\")?) href="(?:/cgi(?:-bin)?/)?(pkgreport\.cgi\?.*?;?package=([^\"&;]+)[^\"]*)">(.+?)</a>%<a$1 href="$3.html">$4</a> (<a$1 href="$btscgiurl$2">online</a>)%gi; +s%<a((?: class=\".*?\")?) href="(?:/cgi(?:-bin)?/)?(bugspam\.cgi[^\"]+)">%<a$1 href="$btscgiurl$2">%i; +s%<a((?: class=\".*?\")?) href="/([0-9]+?)">(.+?)</a>%<a$1 href="$2.html">$3</a> (<a$1 href="$btsurl$2">online</a>)%i; + + # Version graphs + # - remove 'package=' and move the package to the front +s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi(?:-bin)?/)?version\.cgi\?)([^\"]+)package=([^;\"]+)([^\"]+\"|\")>%$1$3;$2$4>%gi; + # - replace 'found=' with '.f.' and 'fixed=' with '.fx.' + 1 while +s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi(?:-bin)?/)?version\.cgi\?)(.*?;)found=([^\"]+)\">%$1$2.f.$3">%i; + 1 while +s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi(?:-bin)?/)?version\.cgi\?)(.*?;)fixed=([^\"]+)\">%$1$2.fx.$3">%i; + 1 while +s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi(?:-bin)?/)?version\.cgi\?found=)([^\"]+)\">%$1.f.$2">%i; + 1 while +s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi(?:-bin)?/)?version\.cgi\?fixed=)([^\"]+)\">%$1.fx.$2">%i; + # - replace '%2F' or '%2C' (a URL-encoded / or ,) with '.' + 1 while +s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi(?:-bin)?/)?version\.cgi\?[^\%]*)\%2[FC]([^\"]+)\">%$1.$2">%gi; + # - display collapsed graph images at 25% +s%(<img[^>]* src=\"[^\"]+);collapse=1([^\"]+)\">%$1$2.co" width="25\%" height="25\%">%gi; + # - and link to the collapsed graph + s%(<a[^>]* href=\"[^\"]+);collapse=1([^\"]+)\">%$1$2.co">%gi; + # - remove any other parameters + 1 while +s%((?:<img[^>]* src|<a[^>]* href)=\"(?:/cgi(?:-bin)?/)?version\.cgi\?[^\"]+);(?:\w+=\d+)([^>]+)\>%$1$2>%gi; + # - remove any +s (encoded spaces) + 1 while +s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi(?:-bin)?/)?version\.cgi\?[^\+]*)\+([^\"]+)\">%$1$2">%gi; + # - remove trailing ";" and ";." from previous substitutions + 1 while +s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi(?:-bin)?/)?version\.cgi\?[^\"]+);\.(.*?)>%$1.$2>%gi; + 1 while +s%((?:<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi(?:-bin)?/)?version\.cgi\?[^\"]+);\">%$1">%gi; + # - final reference should be $package.$versions[.co].png +s%(<img[^>]* src=\"|<a[^>]* href=\")(?:/cgi(?:-bin)?/)?version\.cgi\?([^\"]+)(\"[^>]*)>%$1$2.png$3>%gi; + } + } + } + + return join("", @data); +} + +# Removes a specified thing from the cache +sub deletecache { + my $thing = shift; + my $thgopts = shift || ''; + + if (!-d $cachedir) { + die "$progname: deletecache() called but no cachedir!\n"; + } + + delete_timestamp($thing, $thgopts); + unlink cachefile($thing, $thgopts); + if ($thing =~ /^\d+$/) { + rmtree("$cachedir/$thing", 0, 1) if -d "$cachedir/$thing"; + unlink("$cachedir/$thing.mbox") if -f "$cachedir/$thing.mbox"; + unlink("$cachedir/$thing.status.mbox") + if -f "$cachedir/$thing.status.mbox"; + unlink("$cachedir/$thing.raw.mbox") if -f "$cachedir/$thing.raw.mbox"; + } +} + +# Given a thing, returns the filename for it in the cache. +sub cachefile { + my $thing = shift; + my $thgopts = shift || ''; + if ($thing eq '') { die "$progname: cachefile given empty argument\n"; } + if ($thing =~ /bugs.css$/) { return $cachedir . "bugs.css" } + $thing =~ s/^src:/src_/; + $thing =~ s/^from:/from_/; + $thing =~ s/^tag:/tag_/; + $thing =~ s/^usertag:/usertag_/; + $thing =~ s%^release-critical/index\.html$%release-critical.html%; + $thing =~ s%/%_%g; + $thgopts =~ s/;/_3B/g; + $thgopts =~ s/=/_3D/g; + return File::Spec->catfile($cachedir, + $thing . $thgopts . ($thing =~ /\.html$/ ? "" : ".html")); +} + +# Given a thing, returns the filename for its mbox in the cache. +sub mboxfile { + my $thing = shift; + return $thing =~ /^\d+$/ + ? File::Spec->catfile($cachedir, $thing . ".mbox") + : undef; +} + +# Given a bug number, returns the dirname for it in the cache. +sub cachebugdir { + my $thing = shift; + if ($thing !~ /^\d+$/) { + die "$progname: cachebugdir given faulty argument: $thing\n"; + } + return File::Spec->catdir($cachedir, $thing); +} + +# And the reverse: Given a filename in the cache, returns the corresponding +# "thing". +sub cachefile_to_thing { + my $thing = basename(shift, '.html'); + my $thgopts = ''; + $thing =~ s/^src_/src:/; + $thing =~ s/^from_/from:/; + $thing =~ s/^tag_/tag:/; + $thing =~ s/^usertag_/usertag:/; + $thing =~ s%^release-critical\.html$%release-critical/index\.html%; + $thing =~ s%_%/%g; + $thing =~ s/_3B/;/g; + $thing =~ s/_3D/=/g; + $thing =~ /^(.*?)((?:;.*)?)$/; + ($thing, $thgopts) = ($1, $2); + return ($thing, $thgopts); +} + +# Given a thing, gives the official BTS cgi page for it +sub thing_to_url { + my $thing = shift; + my $thingurl; + + # have to be intelligent here :/ + if ($thing =~ /^\d+$/) { + $thingurl = $btscgibugurl . "?bug=" . $thing; + } elsif ($thing =~ /^from:/) { + ($thingurl = $thing) =~ s/^from:/submitter=/; + $thingurl = $btscgipkgurl . '?' . $thingurl; + } elsif ($thing =~ /^src:/) { + ($thingurl = $thing) =~ s/^src:/src=/; + $thingurl = $btscgipkgurl . '?' . $thingurl; + } elsif ($thing =~ /^tag:/) { + ($thingurl = $thing) =~ s/^tag:/tag=/; + $thingurl = $btscgipkgurl . '?' . $thingurl; + } elsif ($thing =~ /^usertag:/) { + ($thingurl = $thing) =~ s/^usertag:/tag=/; + $thingurl = $btscgipkgurl . '?' . $thingurl; + } elsif ($thing =~ m%^release-critical(\.html|/(index\.html)?)?$%) { + $thingurl = $btsurl . 'release-critical/index.html'; + } elsif ($thing =~ m%^release-critical/%) { + $thingurl = $btsurl . $thing; + } elsif ($thing =~ /\@/) { # so presume it's a maint request + $thingurl = $btscgipkgurl . '?maint=' . $thing; + } else { # it's a package, or had better be... + $thingurl = $btscgipkgurl . '?pkg=' . $thing; + } + + return $thingurl; +} + +# Given a thing, reads all links to bugs from the corresponding cache file +# if there is one, and returns a list of them. +sub bugs_from_thing { + my $thing = shift; + my $thgopts = shift || ''; + my $cachefile = cachefile($thing, $thgopts); + + if (-f $cachefile) { + local $/; + open(IN, $cachefile) || die "$progname: open $cachefile: $!\n"; + my $data = <IN>; + close IN; + + return $data =~ m!href="(\d+)\.html"!g; + } else { + return (); + } +} + +# Given an <a href="bugreport.cgi?...>...</a> string, return a +# msg id and corresponding filename +sub href_to_filename { + my $href = $_[0]; + my ($msg, $filename); + + if ($href + =~ m%\[<a(?: class=\".*?\")? href="((?:/cgi(?:-bin)?/)?bugreport\.cgi([^\?]*)\?[^\"]*)">.*?\(([^,]*), .*?\)\]% + ) { + # this looks like an attachment; $4 should give the MIME-type + my $uri = URI->new($1); + my $urlfilename = $2; + my $bug = $uri->query_param_delete('bug'); + my $mimetype = $3; + + my $ref = $uri->query(); + $ref =~ s/&(?:amp;)?/;/g; # normalise all hrefs + $uri->query($ref); + + $msg = $uri->query_param('msg'); + my $att = $uri->query_param('att'); + return undef unless $msg && $att; + $msg .= "-$att"; + $urlfilename ||= $att // ''; + + my $fileext = ''; + if ($urlfilename =~ m%^/%) { + $filename = basename($urlfilename); + } else { + $filename = ''; + if ($mimetype eq 'text/plain') { $fileext = '.txt'; } + if ($mimetype eq 'text/html') { $fileext = '.html'; } + } + if (length($filename)) { + $filename = "$bug/$msg/$filename"; + } else { + $filename = "$bug/$msg$fileext"; + } + } elsif ($href + =~ m%<a(?: class=\".*?\")? href="((?:/cgi(?:-bin)?/)?bugreport\.cgi([^\?]*)\?([^"]*))".*?>% + ) { + my $uri = URI->new($1); + my $urlfilename = $2; + my $bug = $uri->query_param_delete('bug'); + $msg = $uri->query_param_delete('msg'); + + my $ref = $uri->query // ''; + $ref =~ s/&(?:amp;)?/;/g; # normalise all hrefs + $ref =~ s/;archive=(yes|no)\b//; + $ref =~ s/%3D/=/g; + $uri->query($ref); + + my %params = ( + mboxstatus => '', + mboxstat => '', + mboxmaint => '', + mbox => '', + $uri->query_form(), + ); + + if ($msg && !%params) { + $filename = File::Spec->catfile($bug, "$msg.html"); + } elsif (($params{mboxstat} || $params{mboxstatus}) eq 'yes') { + $msg = 'statusmbox'; + $filename = "$bug.status.mbox"; + } elsif ($params{mboxmaint} eq 'yes') { + $msg = 'mbox'; + $filename = "$bug.mbox"; + } elsif ($params{mbox} eq 'yes') { + if ($msg) { + $filename = "$bug/$msg.mbox"; + $msg .= '-mbox'; + } else { + $filename = "$bug.raw.mbox"; + $msg = 'rawmbox'; + } + } elsif (!$ref) { + return undef; + } else { + $href =~ s/>.*/>/s; + warn +"$progname: in href_to_filename: unrecognised BTS URL type: $href\n"; + return undef; + } + } elsif ($href + =~ m%<(?:a[^>]* href|img [^>]* src)="((?:/cgi(?:-bin)?/)?version\.cgi\?[^"]+)"[^>]*>%i + ) { + my $uri = URI->new($1); + my %params = $uri->query_form(); + + if ($params{package}) { + $filename .= $params{package}; + } + if ($params{found}) { + $filename .= ".f.$params{found}"; + } + if ($params{fixed}) { + $filename .= ".fx.$params{fixed}"; + } + if ($params{collapse}) { + $filename .= '.co'; + } + + # Replace encoded "/" and "," characters with "." + $filename =~ s@(?:%2[FC]|/|,)@.@gi; + # Remove encoded spaces + $filename =~ s/\+//g; + + $msg = 'versions'; + $filename .= '.png'; + } else { + return undef; + } + + return ($msg, $filename); +} + +# Browses a given thing, with preprocessed list of URL options such as +# ";opt1=val1;opt2=val2" with possible caching if there are no options +sub browse { + prunecache(); + my $thing = shift; + my $thgopts = shift || ''; + + if ($thing eq '') { + if ($thgopts ne '') { + die +"$progname: you can only give options for a BTS page if you specify a bug/maint/... .\n"; + } + runbrowser($btsurl); + return; + } + + my $hascache = -d $cachedir; + my $cachefile = cachefile($thing, $thgopts); + my $mboxfile = mboxfile($thing); + if ($mboxmode and !$mboxfile) { + die +"$progname: you can only request a mailbox for a single bug report.\n"; + } + + # Check that if we're requesting a tag, that it's a valid tag + if (($thing . $thgopts) =~ /(?:^|;)(?:tag|include|exclude)[:=]([^;]*)/) { + unless (exists $valid_tags{$1}) { + die +"$progname: invalid tag requested: $1\nRecognised tag names are: " + . join(" ", @valid_tags) . "\n"; + } + } + + my $livedownload = 1; + if ($offlinemode) { + $livedownload = 0; + if (!$hascache) { + die +"$progname: Sorry, you are in offline mode and have no cache.\nRun \"bts cache\" or \"bts show\" to create one.\n"; + } elsif ((!$mboxmode and !-r $cachefile) + or ($mboxmode and !-r $mboxfile)) { + die +"$progname: Sorry, you are in offline mode and that is not cached.\nUse \"bts [--cache-mode=...] cache\" to update the cache.\n"; + } + if ($mboxmode) { + runmailreader($mboxfile); + } else { + runbrowser("file://$cachefile"); + } + } + # else we're in online mode + elsif ($caching && have_lwp() && $thing ne '') { + if (!$hascache) { + if (!-d dirname($cachedir)) { + unless (make_path(dirname($cachedir))) { + warn "$progname: couldn't mkdir " + . dirname($cachedir) + . ": $!\n"; + goto LIVE; + } + } + unless (make_path($cachedir)) { + warn "$progname: couldn't mkdir $cachedir: $!\n"; + goto LIVE; + } + } + + $livedownload = 0; + my $live = download($thing, $thgopts, 0, $mboxmode); + + if ($mboxmode) { + runmailreader($mboxfile); + } else { + if (length($live)) { + my ($fh, $livefile) = tempfile( + "btsXXXXXX", + SUFFIX => ".html", + DIR => File::Spec->tmpdir, + UNLINK => 1 + ); + + # Use filehandle for security + open(OUT_LIVE, ">&", $fh) + or die "$progname: writing to temporary file: $!\n"; + # Correct relative urls to point to the bts. + $live + =~ s%\shref="(?:/cgi(?:-bin)?/)?(\w+\.cgi)% href="$btscgiurl$1%g; + print OUT_LIVE $live; + # Some browsers don't like unseekable filehandles, + # so use filename + runbrowser("file://$livefile"); + } else { + runbrowser("file://$cachefile"); + } + } + } + + LIVE: # we are not caching; just show it live + if ($livedownload) { + if ($mboxmode) { + # we appear not to be caching; OK, we'll download to a + # temporary file + warn +"bts debug: downloading ${btscgiurl}bugreport.cgi?bug=$thing;mbox=yes\n" + if $debug; + my ($fh, $fn) = download_mbox($thing, 1); + runmailreader($fn); + } else { + if ($thgopts ne '') { + my $thingurl = thing_to_url($thing); + runbrowser($thingurl . $thgopts); + } else { + # let the BTS be intelligent + runbrowser($btsurl . $thing); + } + } + } +} + +# Removes all files from the cache which were downloaded automatically +# and have not been accessed for more than 30 days. We also only run +# this at most once per day for efficiency. + +sub prunecache { + # TODO: Remove handling of $oldcache post-Stretch + my $oldcache = File::Spec->catdir($ENV{HOME}, '.devscripts_cache', 'bts'); + if (-d $oldcache && !-d $cachedir) { + my $err; + make_path(dirname($cachedir), { error => \$err }); + if (!@$err) { + system('mv', $oldcache, $cachedir); + } + } + return unless -d $cachedir; + return if -f $prunestamp and -M _ < 1; + + my $oldcwd = getcwd; + + chdir($cachedir) || die "$progname: chdir $cachedir: $!\n"; + + # remove the now-defunct live-download file + unlink "live_download.html"; + + opendir DIR, '.' or die "$progname: opendir $cachedir: $!\n"; + my @cachefiles = grep { !/^\.\.?$/ } readdir(DIR); + closedir DIR; + + # Are there any unexpected files lying around? + my @known_files = map { basename($_) } + ($timestampdb, $timestampdb . ".lock", $prunestamp); + + my %weirdfiles = map { $_ => 1 } grep { !/\.(html|css|png)$/ } @cachefiles; + foreach (@known_files) { + delete $weirdfiles{$_} if exists $weirdfiles{$_}; + } + # and bug directories + foreach (@cachefiles) { + if (/^(\d+)\.html$/) { + delete $weirdfiles{$1} if exists $weirdfiles{$1} and -d $1; + delete $weirdfiles{"$1.mbox"} + if exists $weirdfiles{"$1.mbox"} and -f "$1.mbox"; + delete $weirdfiles{"$1.raw.mbox"} + if exists $weirdfiles{"$1.raw.mbox"} and -f "$1.raw.mbox"; + delete $weirdfiles{"$1.status.mbox"} + if exists $weirdfiles{"$1.status.mbox"} and -f "$1.status.mbox"; + } + } + + warn "$progname: unexpected files/dirs in cache directory $cachedir:\n " + . join("\n ", keys %weirdfiles) . "\n" + if keys %weirdfiles; + + my @oldfiles; + foreach (@cachefiles) { + next unless /\.(html|css)$/; + push @oldfiles, $_ if -A $_ > 30; + } + + # We now remove the oldfiles if they're automatically downloaded + tie(%timestamp, "Devscripts::DB_File_Lock", $timestampdb, + O_RDWR() | O_CREAT(), + 0600, $DB_HASH, "write") + or die "$progname: couldn't open DB file $timestampdb for writing: $!\n" + if !tied %timestamp; + + my @unrecognised; + foreach my $oldfile (@oldfiles) { + my ($thing, $thgopts) = cachefile_to_thing($oldfile); + unless (defined get_timestamp($thing, $thgopts)) { + push @unrecognised, $oldfile; + next; + } + next if is_manual(get_timestamp($thing, $thgopts)); + + # Otherwise, it's automatic and we purge it + deletecache($thing, $thgopts); + } + + untie %timestamp; + + if (!-e $prunestamp) { + open PRUNESTAMP, + ">$prunestamp" || die "$progname: prune timestamp: $!\n"; + close PRUNESTAMP; + } + chdir $oldcwd || die "$progname: chdir $oldcwd: $!\n"; + utime time, time, $prunestamp; +} + +# Determines which browser to use +sub runbrowser { + my $URL = shift; + + if (system('sensible-browser', $URL) >> 8 != 0) { + warn "Problem running sensible-browser: $!\n"; + } +} + +# Determines which mailreader to use +sub runmailreader { + my $file = shift; + my $quotedfile; + die "$progname: could not read mbox file $file!\n" unless -r $file; + + if ($file !~ /\'/) { $quotedfile = qq['$file']; } + elsif ($file !~ /[\"\\\$\'\!]/) { $quotedfile = qq["$file"]; } + else { + die +"$progname: could not figure out how to quote the mbox filename \"$file\"\n"; + } + + my $reader = $mailreader; + $reader =~ s/\%([%s])/$1 eq '%' ? '%' : $quotedfile/eg; + + if (system($reader) >> 8 != 0) { + warn "Problem running mail reader: $!\n"; + } +} + +# Timestamp handling +# +# We store a +ve timestamp to represent an automatic download and +# a -ve one to represent a manual download. + +sub get_timestamp { + my $thing = shift; + my $thgopts = shift || ''; + my $timestamp = undef; + my $versionstamp = undef; + + if (tied %timestamp) { + ($timestamp, $versionstamp) = split /;/, + $timestamp{ $thing . $thgopts } + if exists $timestamp{ $thing . $thgopts }; + } else { + tie(%timestamp, "Devscripts::DB_File_Lock", $timestampdb, + O_RDONLY(), 0600, $DB_HASH, "read") + or die + "$progname: couldn't open DB file $timestampdb for reading: $!\n"; + + ($timestamp, $versionstamp) = split /;/, + $timestamp{ $thing . $thgopts } + if exists $timestamp{ $thing . $thgopts }; + + untie %timestamp; + } + + return wantarray ? ($timestamp, $versionstamp) : $timestamp; +} + +sub set_timestamp { + my $thing = shift; + my $thgopts = shift || ''; + my $timestamp = shift; + my $versionstamp = shift || $version; + + if (tied %timestamp) { + $timestamp{ $thing . $thgopts } = "$timestamp;$versionstamp"; + } else { + tie(%timestamp, "Devscripts::DB_File_Lock", $timestampdb, + O_RDWR() | O_CREAT(), + 0600, $DB_HASH, "write") + or die + "$progname: couldn't open DB file $timestampdb for writing: $!\n"; + + $timestamp{ $thing . $thgopts } = "$timestamp;$versionstamp"; + + untie %timestamp; + } +} + +sub delete_timestamp { + my $thing = shift; + my $thgopts = shift || ''; + + if (tied %timestamp) { + delete $timestamp{ $thing . $thgopts }; + } else { + tie(%timestamp, "Devscripts::DB_File_Lock", $timestampdb, + O_RDWR() | O_CREAT(), + 0600, $DB_HASH, "write") + or die + "$progname: couldn't open DB file $timestampdb for writing: $!\n"; + + delete $timestamp{ $thing . $thgopts }; + + untie %timestamp; + } +} + +sub is_manual { + return $_[0] < 0; +} + +sub make_manual { + return -abs($_[0]); +} + +sub is_automatic { + return $_[0] > 0; +} + +sub make_automatic { + return abs($_[0]); +} + +# Returns true if current cached version is older than critical version +# We're only using really simple version numbers here: a.b.c +sub old_cache_format_version { + my $cacheversion = $_[0]; + + my @cache = split /\./, $cacheversion; + my @new = split /\./, $new_cache_format_version; + + push @cache, 0, 0, 0, 0; + push @new, 0, 0; + + return + ($cache[0] < $new[0]) + || ($cache[0] == $new[0] && $cache[1] < $new[1]) + || ($cache[0] == $new[0] && $cache[1] == $new[1] && $cache[2] < $new[2]) + || ( $cache[0] == $new[0] + && $cache[1] == $new[1] + && $cache[2] == $new[2] + && $cache[3] < $new[3]); +} + +# We would love to use LWP::Simple::mirror in this script. +# Unfortunately, bugs.debian.org does not respect the +# If-Modified-Since header. For single bug reports, however, +# bugreport.cgi will return a Last-Modified header if sent a HEAD +# request. So this is a hack, based on code from the LWP modules. :-( +# Return value: +# (return value, error string) +# with return values: MIRROR_ERROR failed +# MIRROR_DOWNLOADED downloaded new version +# MIRROR_UP_TO_DATE up-to-date + +sub bts_mirror { + my ($url, $timestamp, $force) = @_; + + init_agent() unless $ua; + if ($url =~ m%/\d+$% and !$refreshmode and !$force) { + # Single bug, worth doing timestamp checks + my $request = HTTP::Request->new('HEAD', $url); + my $response = $ua->request($request); + + if ($response->is_success) { + my $lm = $response->last_modified; + if (defined $lm and $lm <= abs($timestamp)) { + return (MIRROR_UP_TO_DATE, $response->status_line); + } + } else { + return (MIRROR_ERROR, $response->status_line); + } + } + + # So now we download the full thing regardless + # We don't care if we scotch the contents of $file - it's only + # a temporary file anyway + my $request = HTTP::Request->new('GET', $url); + my $response = $ua->request($request); + + if ($response->is_success) { + # This check from LWP::UserAgent; I don't even know whether + # the BTS sends a Content-Length header... + my $nominal_content_length = $response->content_length || 0; + my $true_content_length + = defined $response->content ? length($response->content) : 0; + if ($true_content_length == 0) { + return (MIRROR_ERROR, $response->status_line); + } + if ($nominal_content_length > 0) { + if ($true_content_length < $nominal_content_length) { + return (MIRROR_ERROR, +"Transfer truncated: only $true_content_length out of $nominal_content_length bytes received" + ); + } + if ($true_content_length > $nominal_content_length) { + return (MIRROR_ERROR, +"Content-length mismatch: expected $nominal_content_length bytes, got $true_content_length" + ); + } + # else OK + } + + return ( + MIRROR_DOWNLOADED, $response->status_line, + $response->content, $response->header('Content-Type')); + } else { + return (MIRROR_ERROR, $response->status_line); + } +} + +sub init_agent { + $ua = new LWP::UserAgent; # we create a global UserAgent object + $ua->agent("LWP::UserAgent/Devscripts/$version"); + $ua->env_proxy; +} + +sub opts_done { + if (@_) { + die "$progname: unknown options to '$command[$index]': @_\n"; + } +} + +sub edit { + my $message = shift; + my ($fh, $filename); + ($fh, $filename) = tempfile( + "btsXXXX", + SUFFIX => ".mail", + DIR => File::Spec->tmpdir + ); + open(OUT_MAIL, ">$filename") + or die "$progname: writing to temporary file: $!\n"; + print OUT_MAIL $message; + close OUT_MAIL; + my $rc = system("sensible-editor $filename"); + undef $message; + + if ($rc == 0) { + open(OUT_MAIL, "<$filename") + or die "$progname: reading from temporary file: $!\n"; + while (<OUT_MAIL>) { + $message .= $_; + } + close OUT_MAIL; + } + unlink($filename); + return $message; +} + +=back + +=head1 ENVIRONMENT VARIABLES + +=over 4 + +=item B<DEBEMAIL> + +If this is set, the From: line in the email will be set to use this email +address instead of your normal email address (as would be determined by +B<mail>). + +=item B<DEBFULLNAME> + +If B<DEBEMAIL> is set, B<DEBFULLNAME> is examined to determine the full name +to use; if this is not set, B<bts> attempts to determine a name from +your F<passwd> entry. + +=item B<BROWSER> + +If set, it specifies the browser to use for the B<show> and B<bugs> +options. See the description above. + +=back + +=head1 CONFIGURATION VARIABLES + +The two configuration files F</etc/devscripts.conf> and +F<~/.devscripts> are sourced by a shell in that order to set +configuration variables. Command line options can be used to override +configuration file settings. Environment variable settings are +ignored for this purpose. The currently recognised variables are: + +=over 4 + +=item B<BTS_OFFLINE> + +If this is set to B<yes>, then it is the same as the B<--offline> command +line parameter being used. Only has an effect on the B<show> and B<bugs> +commands. The default is B<no>. See the description of the B<show> +command above for more information. + +=item B<BTS_CACHE> + +If this is set to B<no>, then it is the same as the B<--no-cache> command +line parameter being used. Only has an effect on the B<show> and B<bug> +commands. The default is B<yes>. Again, see the B<show> command above +for more information. + +=item B<BTS_CACHE_MODE=>{B<min>,B<mbox>,B<full>} + +How much of the BTS should we mirror when we are asked to cache something? +Just the minimum, or also the mbox or the whole thing? The default is +B<min>, and it has the same meaning as the B<--cache-mode> command line +parameter. Only has an effect on the cache. See the B<cache> command for more +information. + +=item B<BTS_FORCE_REFRESH> + +If this is set to B<yes>, then it is the same as the B<--force-refresh> +command line parameter being used. Only has an effect on the B<cache> +command. The default is B<no>. See the B<cache> command for more +information. + +=item B<BTS_MAIL_READER> + +If this is set, specifies a mail reader to use instead of B<mutt>. Same as +the B<--mailreader> command line option. + +=item B<BTS_SENDMAIL_COMMAND> + +If this is set, specifies a B<sendmail> command to use instead of +F</usr/sbin/sendmail>. Same as the B<--sendmail> command line option. + +=item B<BTS_ONLY_NEW> + +Download only new bugs when caching. Do not check for updates in +bugs we already have. The default is B<no>. Same as the B<--only-new> +command line option. + +=item B<BTS_SMTP_HOST> + +If this is set, specifies an SMTP host to use for sending mail rather +than using the B<sendmail> command. Same as the B<--smtp-host> command line +option. + +Note that this option takes priority over B<BTS_SENDMAIL_COMMAND> if both are +set, unless the B<--sendmail> option is used. + +=item B<BTS_SMTP_AUTH_USERNAME>, B<BTS_SMTP_AUTH_PASSWORD> + +If these options are set, then it is the same as the B<--smtp-username> and +B<--smtp-password> options being used. + +=item B<BTS_SMTP_HELO> + +Same as the B<--smtp-helo> command line option. + +=item B<BTS_INCLUDE_RESOLVED> + +If this is set to B<no>, then it is the same as the B<--no-include-resolved> +command line parameter being used. Only has an effect on the B<cache> +command. The default is B<yes>. See the B<cache> command for more +information. + +=item B<BTS_SUPPRESS_ACKS> + +If this is set to B<yes>, then it is the same as the B<--no-ack> command +line parameter being used. The default is B<no>. + +=item B<BTS_INTERACTIVE> + +If this is set to B<yes> or B<force>, then it is the same as the +B<--interactive> or B<--force-interactive> command line parameter being used. +The default is B<no>. + +=item B<BTS_DEFAULT_CC> + +Specify a list of e-mail addresses to which a carbon copy of the generated +e-mail to the control bot should automatically be sent. + +=item B<BTS_SERVER> + +Specify the name of a debbugs server which should be used instead of +https://bugs.debian.org. + +=back + +=head1 SEE ALSO + +Please see L<https://www.debian.org/Bugs/server-control> for +more details on how to control the BTS using emails and +L<https://www.debian.org/Bugs/> for more information about the BTS. + +querybts(1), reportbug(1), pts-subscribe(1), devscripts.conf(5) + +=head1 COPYRIGHT + +This program is Copyright (C) 2001-2003 by Joey Hess <joeyh@debian.org>. +Many modifications have been made, Copyright (C) 2002-2005 Julian +Gilbey <jdg@debian.org> and Copyright (C) 2007 Josh Triplett +<josh@freedesktop.org>. + +It is licensed under the terms of the GPL, either version 2 of the +License, or (at your option) any later version. + +=cut + +# Please leave this alone unless you understand the seek above. +__DATA__ |