push @{$exclude{$key}}, split /\s*,\s*/, $value;
}
+ my $binary_to_source_cache = {};
foreach my $bug (@bugs) {
- my %status = %{get_bug_status(bug=>$bug,
- (exists $param{dist}?(dist => $param{dist}):()),
- bugusertags => $param{bugusertags},
- (exists $param{version}?(version => $param{version}):()),
+ my %status = %{get_bug_status(bug=>$bug,
+ (map {exists $param{$_}?($_,$param{$_}):()}
+ qw(dist version schema bugusertags)
+ ),
(exists $param{arch}?(arch => $param{arch}):(arch => $config{default_architectures})),
+ binary_to_source_cache => $binary_to_source_cache,
)};
next unless %status;
next if bug_filter(bug => $bug,
if (@_ == 1) {
unshift @_, 'bug';
}
+ state $spec =
+ {bug => {type => SCALAR,
+ regex => qr/^\d+$/,
+ },
+ status => {type => HASHREF,
+ optional => 1,
+ },
+ bug_index => {type => OBJECT,
+ optional => 1,
+ },
+ version => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ dist => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ arch => {type => SCALAR|ARRAYREF,
+ optional => 1,
+ },
+ bugusertags => {type => HASHREF,
+ optional => 1,
+ },
+ sourceversions => {type => ARRAYREF,
+ optional => 1,
+ },
+ indicatesource => {type => BOOLEAN,
+ default => 1,
+ },
+ binary_to_source_cache => {type => HASHREF,
+ optional => 1,
+ },
++ schema => {type => OBJECT,
++ optional => 1,
++ },
+ };
my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- regex => qr/^\d+$/,
- },
- status => {type => HASHREF,
- optional => 1,
- },
- bug_index => {type => OBJECT,
- optional => 1,
- },
- version => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- dist => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- arch => {type => SCALAR|ARRAYREF,
- optional => 1,
- },
- bugusertags => {type => HASHREF,
- optional => 1,
- },
- sourceversions => {type => ARRAYREF,
- optional => 1,
- },
- indicatesource => {type => BOOLEAN,
- default => 1,
- },
- schema => {type => OBJECT,
- optional => 1,
- },
- },
+ spec => $spec,
);
my %status;
libmailtools-perl, libmime-tools-perl, libio-stringy-perl, libmldbm-perl,
liburi-perl, libsoap-lite-perl, libcgi-simple-perl,
libhttp-server-simple-perl, libtest-www-mechanize-perl,
- libmail-rfc822-address-perl, libsafe-hole-perl, libuser-perl,
+ libmail-rfc822-address-perl, libuser-perl,
libconfig-simple-perl, libtest-pod-perl, liblist-allutils-perl,
- # used by Debbugs::Libravatar and libravatar.cgi
libfile-libmagic-perl, libgravatar-url-perl, libwww-perl, imagemagick,
- libdbix-class-perl, libdatetime-format-pg-perl,
++ libdbix-class-perl, libdatetime-format-pg-perl, libtest-postgresql-perl,
+ libdatetime-format-mail-perl,
- libtext-template-perl, graphviz, libtext-iconv-perl, libnet-server-perl,
- libtest-postgresql-perl
-Homepage: http://wiki.debian.org/Teams/Debbugs
+ libtext-xslate-perl, graphviz, libtext-iconv-perl, libnet-server-perl,
+# used to make the logo
+ inkscape
+Homepage: https://salsa.debian.org/debbugs-team
+Testsuite: autopkgtest-pkg-perl
Package: debbugs
Architecture: all
Package: libdebbugs-perl
Architecture: all
Depends:
- ${misc:Depends},
- ${perl:Depends}, libmailtools-perl, ed, libmime-tools-perl,
+ ${misc:Depends}, ${perl:Depends}, libmailtools-perl, ed, libmime-tools-perl,
libio-stringy-perl, libmldbm-perl, liburi-perl, libsoap-lite-perl,
- libcgi-simple-perl, libparams-validate-perl, libtext-template-perl,
- libsafe-hole-perl, libmail-rfc822-address-perl, liblist-moreutils-perl,
- libtext-template-perl,
- # used by Debbugs::Libravatar and libravatar.cgi
- libfile-libmagic-perl,
- libgravatar-url-perl, libwww-perl, imagemagick,
+ libcgi-simple-perl, libparams-validate-perl, libtext-xslate-perl,
+ libmail-rfc822-address-perl, liblist-allutils-perl,
+ graphviz, libtext-iconv-perl, libuser-perl,
+# used by Debbugs::Libravatar and libravatar.cgi
+ libfile-libmagic-perl, libgravatar-url-perl, libwww-perl, imagemagick
+ # used by the database
+ libdatetime-format-mail-perl, libdbix-class-perl, libdatetime-format-pg-perl
Section: perl
Description: modules used by the active Debian BTS
Debian has a bug tracking system which files details of bugs reported by
@EXPORT = ();
%EXPORT_TAGS = (configuration => [qw(dirsize create_debbugs_configuration send_message)],
mail => [qw(num_messages_sent)],
+ control => [qw(test_control_commands)],
+ database => [qw(create_postgresql_database update_postgresql_database)]
);
@EXPORT_OK = ();
- Exporter::export_ok_tags(qw(configuration mail control));
+ Exporter::export_ok_tags(keys %EXPORT_TAGS);
$EXPORT_TAGS{all} = [@EXPORT_OK];
}
}
}
- $SIG{CHLD} = sub {};
-
+=item test_control_commands
+
+ test_control_commands(\%config,
+ forcemerge => {command => 'forcemerge',
+ value => '1 2',
+ status_key => 'mergedwith',
+ status_value => '2',
+ expect_error => 0,
+ });
+
+Test a set of control commands to see if they will fail or not. Takes
+SCALAR/HASHREF pairs, where the scalar should be unique, and the HASHREF
+contains the following keys:
+
+=over
+
+=item command -- control command to issue
+
+=item value -- value to pass to control command
+
+=item status_key -- bug status key to check
+
+=item status_value -- value of status key
+
+=item expect_error -- whether to expect the control command to error or not
+
+=back
+
+=cut
+
+sub test_control_commands {
+ my ($config,@commands) = @_;
+
+ # now we need to check to make sure that the control message actually did anything
+ # This is an eval because $ENV{DEBBUGS_CONFIG_FILE} isn't set at BEGIN{} time
+ eval "use Debbugs::Status qw(read_bug writebug);";
+ while (my ($command,$control_command) = splice(@commands,0,2)) {
+ # just check to see that control doesn't explode
+ $control_command->{value} = " $control_command->{value}" if length $control_command->{value}
+ and $control_command->{value} !~ /^\s/;
+ send_message(to => 'control@bugs.something',
+ headers => [To => 'control@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => "Munging a bug with $command",
+ ],
+ body => <<EOF) or fail 'message to control@bugs.something failed';
+debug 10
+$control_command->{command} $control_command->{value}
+thanks
+EOF
+ ;
+ # now we need to check to make sure the control message was processed without errors
+ if (not ($control_command->{expect_error} // 0)) {
+ ok(system('sh','-c','find '.$config->{sendmail_dir}.
+ q( -type f | xargs grep -q "Subject: Processed: Munging a bug with $command")
+ ) == 0,
+ 'control@bugs.something'. "$command message was parsed without errors");
+ }
+ # now we need to check to make sure that the control message actually did anything
+ my $status;
+ $status = read_bug(exists $control_command->{bug}?(bug => $control_command->{bug}):(bug=>1),
+ exists $control_command->{location}?(location => $control_command->{location}):(),
+ );
+ is_deeply($status->{$control_command->{status_key}},
+ $control_command->{status_value},
+ "bug " .
+ (exists $control_command->{bug}?$control_command->{bug}:1).
+ " $command"
+ )
+ or fail(Data::Dumper->Dump([$status],[qw(status)]));
+ }
+}
+
+
{
package DebbugsTest::HTTPServer;
use base qw(HTTP::Server::Simple::CGI HTTP::Server::Simple::CGI::Environment);
projects / debbugs.git / commitdiff