print {$output} '<p>';
print {$output} (($maint =~ /,/)? "Maintainer for $showpkg is "
: "Maintainers for $showpkg are ") .
- package_links(maint => $maint);
+ package_links(maintainer => $maint);
print {$output} ".</p>\n";
}
else {
push @references, sprintf "to the <a href=\"%s\">%s package page</a>",
html_escape("$config{package_pages}/$package"), html_escape("$package");
}
- if (defined $config{subscription_domain} and
- length $config{subscription_domain}) {
+ if (defined $config{package_tracking_domain} and
+ length $config{package_tracking_domain}) {
my $ptslink = $param{binary} ? $srcforpkg : $package;
# the pts only wants the source, and doesn't care about src: (#566089)
$ptslink =~ s/^src://;
dist => {type => SCALAR,
optional => 1,
},
+ schema => {type => OBJECT,
+ optional => 1,
+ },
}
);
my @bugs = @{$param{bugs}};
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,
use warnings;
use strict;
+use feature 'state';
+
use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
use Exporter qw(import);
use Encode qw(decode encode is_utf8);
use Storable qw(dclone);
- use List::AllUtils qw(min max);
+ use List::AllUtils qw(min max uniq);
+ use DateTime::Format::Pg;
use Carp qw(croak);
if (@_ == 1) {
unshift @_, 'bug';
}
+ state $spec =
+ {bug => {type => SCALAR,
+ optional => 1,
+ # something really stupid passes negative bugnumbers
+ regex => qr/^-?\d+/,
+ },
+ location => {type => SCALAR|UNDEF,
+ optional => 1,
+ },
+ summary => {type => SCALAR,
+ optional => 1,
+ },
+ lock => {type => BOOLEAN,
+ optional => 1,
+ },
+ locks => {type => HASHREF,
+ optional => 1,
+ },
+ };
my %param = validate_with(params => \@_,
- spec => {bug => {type => SCALAR,
- optional => 1,
- # something really
- # stupid passes
- # negative bugnumbers
- regex => qr/^-?\d+/,
- },
- location => {type => SCALAR|UNDEF,
- optional => 1,
- },
- summary => {type => SCALAR,
- optional => 1,
- },
- lock => {type => BOOLEAN,
- optional => 1,
- },
- locks => {type => HASHREF,
- optional => 1,
- },
- },
+ spec => $spec,
);
die "One of bug or summary must be passed to read_bug"
if not exists $param{bug} and not exists $param{summary};
my $status;
my $log;
my $location;
+ my $report;
if (not defined $param{summary}) {
my $lref;
($lref,$location) = @param{qw(bug location)};
}
$status = getbugcomponent($lref, 'summary', $location);
$log = getbugcomponent($lref, 'log' , $location);
+ $report = getbugcomponent($lref, 'report' , $location);
return undef unless defined $status;
return undef if not -e $status;
}
else {
$status = $param{summary};
$log = $status;
+ $report = $status;
$log =~ s/\.summary$/.log/;
+ $report =~ s/\.summary$/.report/;
($location) = $status =~ m/(db-h|db|archive)/;
($param{bug}) = $status =~ m/(\d+)\.summary$/;
}
my %data;
my @lines;
- my $version = 2;
+ my $version;
local $_;
while (<$status_fh>) {
chomp;
push @lines, $_;
- $version = $1 if /^Format-Version: ([0-9]+)/i;
+ if (not defined $version and
+ /^Format-Version: ([0-9]+)/i
+ ) {
+ $version = $1;
+ }
}
-
+ $version = 2 if not defined $version;
# Version 3 is the latest format version currently supported.
if ($version > 3) {
warn "Unsupported status version '$version'";
return undef;
}
- my %namemap = reverse %fields;
+ state $namemap = {reverse %fields};
for my $line (@lines) {
if ($line =~ /(\S+?): (.*)/) {
my ($name, $value) = (lc $1, $2);
# or \n in the fields of status. Kill them off here.
# [Eventually, this should be superfluous.]
$value =~ s/[\r\n]//g;
- $data{$namemap{$name}} = $value if exists $namemap{$name};
+ $data{$namemap->{$name}} = $value if exists $namemap->{$name};
}
}
for my $field (keys %fields) {
my $status_modified = (stat($status))[9];
# Add log last modified time
$data{log_modified} = (stat($log))[9] // (stat("${log}.gz"))[9];
+ my $report_modified = (stat($report))[9] // $data{log_modified};
$data{last_modified} = max($status_modified,$data{log_modified});
+ # if the date isn't set (ancient bug), use the smallest of any of the modified
+ if (not defined $data{date} or not length($data{date})) {
+ $data{date} = min($report_modified,$status_modified,$data{log_modified});
+ }
$data{location} = $location;
$data{archived} = (defined($location) and ($location eq 'archive'))?1:0;
$data{bug_num} = $param{bug};
return grep {length $_} map {split $splitter} @t;
};
- my $ditch_empty_space = sub {return &{$ditch_empty}(' ',@_)};
+ our $sort_and_unique = sub {
+ my @v;
+ my %u;
+ my $all_numeric = 1;
+ for my $v (@_) {
+ if ($all_numeric and $v =~ /\D/) {
+ $all_numeric = 0;
+ }
+ next if exists $u{$v};
+ $u{$v} = 1;
+ push @v, $v;
+ }
+ if ($all_numeric) {
+ return sort {$a <=> $b} @v;
+ } else {
+ return sort @v;
+ }
+ };
+
+ my $ditch_space_unique_and_sort = sub {return &{$sort_and_unique}(&{$ditch_empty}(' ',@_))};
my %split_fields =
(package => \&splitpackages,
affects => \&splitpackages,
# Ideally we won't have to split source, but because some consumers of
# get_bug_status cannot handle arrayref, we will split it here.
source => \&splitpackages,
- blocks => $ditch_empty_space,
- blockedby => $ditch_empty_space,
+ blocks => $ditch_space_unique_and_sort,
+ blockedby => $ditch_space_unique_and_sort,
# this isn't strictly correct, but we'll split both of them for
# the time being until we ditch all use of keywords everywhere
# from the code
- keywords => $ditch_empty_space,
- tags => $ditch_empty_space,
- found_versions => $ditch_empty_space,
- fixed_versions => $ditch_empty_space,
- mergedwith => $ditch_empty_space,
+ keywords => $ditch_space_unique_and_sort,
+ tags => $ditch_space_unique_and_sort,
+ found_versions => $ditch_space_unique_and_sort,
+ fixed_versions => $ditch_space_unique_and_sort,
+ mergedwith => $ditch_space_unique_and_sort,
);
sub split_status_fields {
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;
return \%status;
}
if (defined $param{status}) {
- %status = %{$param{status}};
+ %status = %{$param{status}};
+ }
+ elsif (defined $param{schema}) {
+ my $b = $param{schema}->resultset('Bug')->
+ search_rs({'me.id' => $param{bug}},
+ {prefetch => [{'bug_tags'=>'tag'},
+ 'severity',
+ {'bug_binpackages'=> 'bin_pkg'},
+ {'bug_srcpackages'=> 'src_pkg'},
+ {'bug_user_tags'=>{'user_tag'=>'correspondent'}},
+ {owner => 'correspondent_full_names'},
+ {submitter => 'correspondent_full_names'},
+ 'bug_merged_bugs',
+ 'bug_mergeds_merged',
+ 'bug_blocks_blocks',
+ 'bug_blocks_bugs',
+ {'bug_vers' => ['src_pkg','src_ver']},
+ ],
+ '+columns' => [qw(subject log_modified creation last_modified)],
+ collapse => 1,
+ result_class => 'DBIx::Class::ResultClass::HashRefInflator',
+ })->first();
+ $status{keywords} =
+ join(' ',map {$_->{tag}{tag}} @{$b->{bug_tags}});
+ $status{tags} = $status{keywords};
+ $status{subject} = $b->{subject};
+ $status{bug_num} = $b->{id};
+ $status{severity} = $b->{severity}{severity};
+ $status{package} =
+ join(' ',
+ (map {$_->{bin_pkg}{pkg}} @{$b->{bug_binpackages}//[]}),
+ (map {$_->{src_pkg}{pkg}} @{$b->{bug_srcpackages}//[]}));
+ $status{originator} = $b->{submitter_full};
+ $status{log_modified} =
+ DateTime::Format::Pg->parse_datetime($b->{log_modified})->epoch;
+ $status{date} =
+ DateTime::Format::Pg->parse_datetime($b->{creation})->epoch;
+ $status{last_modified} =
+ DateTime::Format::Pg->parse_datetime($b->{last_modified})->epoch;
+ $status{blocks} =
+ join(' ',
+ uniq(sort(map {$_->{block}}
+ @{$b->{bug_blocks_block}},
+ )));
+ $status{blockedby} =
+ join(' ',
+ uniq(sort(map {$_->{bug}}
+ @{$b->{bug_blocks_bug}},
+ )));
+ $status{mergedwith} =
+ join(' ',uniq(sort(map {$_->{bug},$_->{merged}}
+ @{$b->{bug_merged_bugs}},
+ @{$b->{bug_mergeds_merged}},
+ )));
+ $status{fixed_versions} =
+ [map {$_->{found}?():$_->{ver_string}} @{$b->{bug_vers}}];
+ $status{found_versions} =
+ [map {$_->{found}?$_->{ver_string}:()} @{$b->{bug_vers}}];
}
else {
my $location = getbuglocation($param{bug}, 'summary');
$status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
source_only => 1,
+ exists $param{binary_to_source_cache}?
+ (cache =>$param{binary_to_source_cache}):(),
);
$status{"package"} = 'unknown' if ($status{"package"} eq '');
Source: debbugs
Section: misc
-Priority: extra
+Priority: optional
Maintainer: Debbugs developers <debian-debbugs@lists.debian.org>
Uploaders: Colin Watson <cjwatson@debian.org>, Don Armstrong <don@debian.org>
-Standards-Version: 3.9.4
-Vcs-Browser: http://bugs.debian.org/debbugs-source/mainline
-Vcs-Git: http://bugs.debian.org/debbugs-source/debbugs.git
+Standards-Version: 4.1.3
+Vcs-Browser: https://salsa.debian.org/debbugs-team/debbugs
+Vcs-Git: https://salsa.debian.org/debbugs-team/debbugs.git
Build-Depends: debhelper (>= 9)
Build-Depends-Indep: libparams-validate-perl,
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
use IPC::Open3;
use IO::Handle;
use Test::More;
+ use Test::PostgreSQL;
use Params::Validate qw(validate_with :types);
@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);
return $cur_size;
}
+ =head2 create_postgresql_database
+
+ C<my $pgsql = create_postgresql_database();>
+
+ Create a postgresql database for testing; when the L<Test::PostgreSQL> object it
+ returns is destroyed (or goes out of scope) the database will be removed.
+
+ =cut
+
+ sub create_postgresql_database {
+ my $pgsql = Test::PostgreSQL->new(use_socket => 1) or
+ return undef;
+ my $installsql =
+ File::Spec->rel2abs(dirname(__FILE__).'/../..').
+ '/bin/debbugs-installsql';
+ # create the debversion extension
+ my $dbh = DBI->connect($pgsql->dsn);
+ $dbh->do(<<END) or die "Unable to create extension";
+ CREATE EXTENSION IF NOT EXISTS debversion;
+ END
+ # create the schema for the bug tracking system
+ my $dep_dir = File::Temp::tempdir(CLEANUP=>1);
+ system($installsql,
+ '--dsn',$pgsql->dsn,
+ '--install',
+ '--deployment-dir',$dep_dir);
+
+ initialize_postgresql_database($pgsql,@_);
+ return $pgsql;
+ }
+
+ =item iniitalize_postgresql_database
+
+ C<initialize_postgresql_database();>
+
+ Initialize postgresql database by calling debbugs-loadsql appropriately.
+
+ =cut
+
+ sub initialize_postgresql_database {
+ my ($pgsql,@options) = @_;
+ my $loadsql =
+ File::Spec->rel2abs(dirname(__FILE__).'/../..').
+ '/bin/debbugs-loadsql';
+
+ my $ftpdists =
+ File::Spec->rel2abs(dirname(__FILE__).'/../debian/dist');
+ my $debinfo_dir =
+ File::Spec->rel2abs(dirname(__FILE__).'/../debian/debinfo');
+ my %loadsql_commands =
+ (configuration => [],
+ suites => ['--ftpdists',$ftpdists],
+ debinfo => ['--debinfo-dir',$debinfo_dir],
+ packages => ['--ftpdists',$ftpdists],
+ maintainers => [],
+ );
+ for my $command (keys %loadsql_commands) {
+ system($loadsql,$command,
+ '--dsn',$pgsql->dsn,
+ @options,
+ @{$loadsql_commands{$command}}) == 0 or
+ die "Unable to load $command";
+ }
+ }
+
+
+ =item update_postgresql_database
+
+ C<update_postgresql_database();>
+
+ Update the postgresql database by calling debbugs-loadsql appropriately.
+
+ =cut
+ sub update_postgresql_database {
+ my ($pgsql,@options) = @_;
+ my $loadsql =
+ File::Spec->rel2abs(dirname(__FILE__).'/../..').
+ '/bin/debbugs-loadsql';
+
+ my %loadsql_commands =
+ (bugs_and_logs => [],
+ );
+ for my $command (keys %loadsql_commands) {
+ system($loadsql,$command,
+ '--dsn',$pgsql->dsn,
+ @options,
+ @{$loadsql_commands{$command}}) == 0 or
+ die "Unable to load $command";
+ }
+ }
+
+
1;
projects / debbugs.git / commitdiff