1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later
3 # version at your option.
4 # See the file README and COPYING for more information.
6 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
12 Debbugs::Bugs -- Bug selection routines for debbugs
16 use Debbugs::Bugs qw(get_bugs);
21 This module is a replacement for all of the various methods of
22 selecting different types of bugs.
24 It implements a single function, get_bugs, which defines the master
25 interface for selecting bugs.
27 It attempts to use subsidiary functions to actually do the selection,
28 in the order specified in the configuration files. [Unless you're
29 insane, they should be in order from fastest (and often most
30 incomplete) to slowest (and most complete).]
40 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
41 use base qw(Exporter);
45 $DEBUG = 0 unless defined $DEBUG;
49 @EXPORT_OK = (qw(get_bugs count_bugs newest_bug bug_filter));
50 $EXPORT_TAGS{all} = [@EXPORT_OK];
53 use Debbugs::Config qw(:config);
54 use Params::Validate qw(validate_with :types);
56 use Debbugs::Status qw(splitpackages get_bug_status);
57 use Debbugs::Packages qw(getsrcpkgs getpkgsrc);
58 use Debbugs::Common qw(getparsedaddrs package_maintainer getmaintainers make_list hash_slice);
59 use Fcntl qw(O_RDONLY);
60 use MLDBM qw(DB_File Storable);
61 use List::Util qw(first);
70 The following parameters can either be a single scalar or a reference
71 to an array. The parameters are ANDed together, and the elements of
72 arrayrefs are a parameter are ORed. Future versions of this may allow
73 for limited regular expressions, and/or more complex expressions.
77 =item package -- name of the binary package
79 =item src -- name of the source package
81 =item maint -- address of the maintainer
83 =item submitter -- address of the submitter
85 =item severity -- severity of the bug
87 =item status -- status of the bug
91 =item owner -- owner of the bug
93 =item correspondent -- address of someone who sent mail to the log
95 =item affects -- bugs which affect this package
97 =item dist -- distribution (I don't know about this one yet)
99 =item bugs -- list of bugs to search within
101 =item function -- see description below
105 =head3 Special options
107 The following options are special options used to modulate how the
108 searches are performed.
112 =item archive -- whether to search archived bugs or normal bugs;
113 defaults to false. As a special case, if archive is 'both', but
114 archived and unarchived bugs are returned.
116 =item usertags -- set of usertags and the bugs they are applied to
121 =head3 Subsidiary routines
123 All subsidiary routines get passed exactly the same set of options as
124 get_bugs. If for some reason they are unable to handle the options
125 passed (for example, they don't have the right type of index for the
126 type of selection) they should die as early as possible. [Using
127 Params::Validate and/or die when files don't exist makes this fairly
130 This function will then immediately move on to the next subroutine,
131 giving it the same arguments.
135 This option allows you to provide an arbitrary function which will be
136 given the information in the index.db file. This will be super, super
137 slow, so only do this if there's no other way to write the search.
139 You'll be given a list (which you can turn into a hash) like the
142 (pkg => ['a','b'], # may be a scalar (most common)
145 submitter => 'boo@baz.com',
146 severity => 'serious',
147 tags => ['a','b','c'], # may be an empty arrayref
150 The function should return 1 if the bug should be included; 0 if the
155 my %_get_bugs_common_options =
156 (package => {type => SCALAR|ARRAYREF,
159 src => {type => SCALAR|ARRAYREF,
162 maint => {type => SCALAR|ARRAYREF,
165 submitter => {type => SCALAR|ARRAYREF,
168 severity => {type => SCALAR|ARRAYREF,
171 status => {type => SCALAR|ARRAYREF,
174 tag => {type => SCALAR|ARRAYREF,
177 owner => {type => SCALAR|ARRAYREF,
180 dist => {type => SCALAR|ARRAYREF,
183 correspondent => {type => SCALAR|ARRAYREF,
186 affects => {type => SCALAR|ARRAYREF,
189 function => {type => CODEREF,
192 bugs => {type => SCALAR|ARRAYREF,
195 archive => {type => BOOLEAN|SCALAR,
198 usertags => {type => HASHREF,
204 my $_get_bugs_options = {%_get_bugs_common_options};
206 my %param = validate_with(params => \@_,
207 spec => $_get_bugs_options,
211 my %options = %param;
213 if ($options{archive} eq 'both') {
214 push @bugs, get_bugs(%options,archive=>0);
215 push @bugs, get_bugs(%options,archive=>1);
217 @bugs{@bugs} = @bugs;
220 # A configuration option will set an array that we'll use here instead.
221 for my $routine (qw(Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) {
222 my ($package) = $routine =~ m/^(.+)\:\:/;
223 eval "use $package;";
225 # We output errors here because using an invalid function
226 # in the configuration file isn't something that should
228 warn "use $package failed with $@";
231 @bugs = eval "${routine}(\%options)";
234 # We don't output errors here, because failure here
235 # via die may be a perfectly normal thing.
236 print STDERR "$@" if $DEBUG;
241 # If no one succeeded, die
250 count_bugs(function => sub {...})
252 Uses a subroutine to classify bugs into categories and return the
253 number of bugs which fall into those categories
258 my %param = validate_with(params => \@_,
259 spec => {function => {type => CODEREF,
261 archive => {type => BOOLEAN,
267 if ($param{archive}) {
268 $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
269 or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
272 $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
273 or die "Unable to open $config{spool_dir}/index.db for reading: $!";
277 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
278 my @x = $param{function}->(pkg => $1,
286 $count{$_}++ foreach @x;
295 my $bug = newest_bug();
297 Returns the bug number of the newest bug, which is nextnumber-1.
302 my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r')
303 or die "Unable to open $config{spool_dir}nextnumber for reading: $!";
305 my $next_number = <$nn_fh>;
308 return $next_number-1;
315 Allows filtering bugs on commonly used criteria
322 my %param = validate_with(params => \@_,
323 spec => {bug => {type => ARRAYREF|SCALAR,
326 status => {type => HASHREF|ARRAYREF,
329 seen_merged => {type => HASHREF,
332 repeat_merged => {type => BOOLEAN,
335 include => {type => HASHREF,
338 exclude => {type => HASHREF,
341 min_days => {type => SCALAR,
344 max_days => {type => SCALAR,
349 if (exists $param{repeat_merged} and
350 not $param{repeat_merged} and
351 not defined $param{seen_merged}) {
352 croak "repeat_merged false requires seen_merged to be passed";
354 if (not exists $param{bug} and not exists $param{status}) {
355 croak "one of bug or status must be passed";
358 if (not exists $param{status}) {
359 my $location = getbuglocation($param{bug}, 'summary');
360 return 0 if not defined $location or not length $location;
361 $param{status} = readbug( $param{bug}, $location );
362 return 0 if not defined $param{status};
365 if (exists $param{include}) {
366 return 1 if (!__bug_matches($param{include}, $param{status}));
368 if (exists $param{exclude}) {
369 return 1 if (__bug_matches($param{exclude}, $param{status}));
371 if (exists $param{repeat_merged} and not $param{repeat_merged}) {
372 my @merged = sort {$a<=>$b} $param{bug}, split(/ /, $param{status}{mergedwith});
373 return 1 if first {defined $_} @{$param{seen_merged}}{@merged};
374 @{$param{seen_merged}}{@merged} = (1) x @merged;
376 my $daysold = int((time - $param{status}{date}) / 86400); # seconds to days
377 if (exists $param{min_days}) {
378 return 1 unless $param{min_days} <= $daysold;
380 if (exists $param{max_days}) {
381 return 1 unless $param{max_days} == -1 or
382 $param{max_days} >= $daysold;
388 =head2 get_bugs_by_idx
390 This routine uses the by-$index.idx indicies to try to speed up
397 my $_get_bugs_by_idx_options =
398 {hash_slice(%_get_bugs_common_options,
399 (qw(package submitter severity tag archive),
400 qw(owner src maint bugs correspondent),
401 qw(affects usertags))
405 my %param = validate_with(params => \@_,
406 spec => $_get_bugs_by_idx_options
410 # If we're given an empty maint (unmaintained packages), we can't
411 # handle it, so bail out here
412 for my $maint (make_list(exists $param{maint}?$param{maint}:[])) {
413 if (defined $maint and $maint eq '') {
414 die "Can't handle empty maint (unmaintained packages) in get_bugs_by_idx";
418 # We handle src packages, maint and maintenc by mapping to the
419 # appropriate binary packages, then removing all packages which
420 # don't match all queries
421 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
422 qw(package src maint)
424 if (exists $param{package} or
425 exists $param{src} or
426 exists $param{maint}) {
427 delete @param{qw(maint src)};
428 $param{package} = [@packages];
430 my $keys = grep {$_ !~ /^(archive|usertags|bugs)$/} keys(%param);
431 die "Need at least 1 key to search by" unless $keys;
432 my $arc = $param{archive} ? '-arc':'';
434 for my $key (grep {$_ !~ /^(archive|usertags|bugs)$/} keys %param) {
436 $index = 'submitter-email' if $key eq 'submitter';
437 $index = "$config{spool_dir}/by-${index}${arc}.idx";
438 tie(%idx, MLDBM => $index, O_RDONLY)
439 or die "Unable to open $index: $!";
440 my %bug_matching = ();
441 for my $search (make_list($param{$key})) {
442 for my $bug (keys %{$idx{$search}||{}}) {
443 next if $bug_matching{$bug};
444 # increment the number of searches that this bug matched
446 $bug_matching{$bug}=1;
448 if ($search ne lc($search)) {
449 for my $bug (keys %{$idx{lc($search)}||{}}) {
450 next if $bug_matching{$bug};
451 # increment the number of searches that this bug matched
453 $bug_matching{$bug}=1;
457 if ($key eq 'tag' and exists $param{usertags}) {
458 for my $bug (make_list(grep {defined $_ } @{$param{usertags}}{make_list($param{tag})})) {
459 next if $bug_matching{$bug};
461 $bug_matching{$bug}=1;
464 untie %idx or die 'Unable to untie %idx';
468 for my $bug (make_list($param{bugs})) {
472 # Throw out results that do not match all of the search specifications
473 return map {$keys <= $bugs{$_}?($_):()} keys %bugs;
477 =head2 get_bugs_flatfile
479 This is the fallback search routine. It should be able to complete all
480 searches. [Or at least, that's the idea.]
484 my $_get_bugs_flatfile_options =
485 {hash_slice(%_get_bugs_common_options,
486 map {$_ eq 'dist'?():($_)} keys %_get_bugs_common_options
490 sub get_bugs_flatfile{
491 my %param = validate_with(params => \@_,
492 spec => $_get_bugs_flatfile_options
495 if ($param{archive}) {
496 $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
497 or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
500 $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
501 or die "Unable to open $config{spool_dir}/index.db for reading: $!";
504 if (exists $param{tag} and exists $param{usertags}) {
505 # This complex slice makes a hash with the bugs which have the
506 # usertags passed in $param{tag} set.
507 @usertag_bugs{make_list(@{$param{usertags}}{make_list($param{tag})})
508 } = (1) x make_list(@{$param{usertags}}{make_list($param{tag})});
510 my $unmaintained_packages = 0;
511 # unmaintained packages is a special case
512 my @maints = make_list(exists $param{maint}?$param{maint}:[]);
514 for my $maint (@maints) {
515 if (defined $maint and $maint eq '' and not $unmaintained_packages) {
516 $unmaintained_packages = 1;
517 our %maintainers = %{getmaintainers()};
518 $param{function} = [(exists $param{function}?
519 (ref $param{function}?@{$param{function}}:$param{function}):()),
521 foreach my $try (make_list($d{"pkg"})) {
522 next unless length $try;
523 ($try) = $try =~ m/^(?:src:)?(.+)/;
524 return 1 if not exists $maintainers{$try};
530 elsif (defined $maint and $maint ne '') {
531 push @{$param{maint}},$maint;
534 # We handle src packages, maint and maintenc by mapping to the
535 # appropriate binary packages, then removing all packages which
536 # don't match all queries
537 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
538 qw(package src maint)
540 if (exists $param{package} or
541 exists $param{src} or
542 exists $param{maint}) {
543 delete @param{qw(maint src)};
544 $param{package} = [@packages] if @packages;
548 if (exists $param{bugs}) {
549 $bugs{$_} = 1 for make_list($param{bugs});
552 # These queries have to be handled by get_bugs_by_idx
553 if (exists $param{owner}
554 or exists $param{correspondent}
555 or exists $param{affects}) {
556 $bugs{$_} = 1 for get_bugs_by_idx(map {exists $param{$_}?($_,$param{$_}):()}
557 qw(owner correspondent affects),
562 BUG: while (<$flatfile>) {
563 next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*(.*)\s*\]\s+(\w+)\s+(.*)$/;
564 my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7);
565 next if $grep_bugs and not exists $bugs{$bug};
566 if (exists $param{package}) {
567 my @packages = splitpackages($pkg);
568 next unless grep { my $pkg_list = $_;
569 grep {$pkg_list eq $_} make_list($param{package})
572 if (exists $param{src}) {
573 my @src_packages = map { getsrcpkgs($_)} make_list($param{src});
574 my @packages = splitpackages($pkg);
575 next unless grep { my $pkg_list = $_;
576 grep {$pkg_list eq $_} @packages
579 if (exists $param{submitter}) {
580 my @p_addrs = map {lc($_->address)}
581 map {getparsedaddrs($_)}
582 make_list($param{submitter});
583 my @f_addrs = map {$_->address}
584 getparsedaddrs($submitter||'');
585 next unless grep { my $f_addr = $_;
586 grep {$f_addr eq $_} @p_addrs
589 next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity});
590 next if exists $param{status} and not grep {$status eq $_} make_list($param{status});
591 if (exists $param{tag}) {
593 # either a normal tag, or a usertag must be set
594 $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug};
595 my @bug_tags = split ' ', $tags;
596 $bug_ok = 1 if grep {my $bug_tag = $_;
597 grep {$bug_tag eq $_} make_list($param{tag});
601 # We do this last, because a function may be slow...
602 if (exists $param{function}) {
603 my @bug_tags = split ' ', $tags;
604 my @packages = splitpackages($pkg);
605 my $package = (@packages > 1)?\@packages:$packages[0];
606 for my $function (make_list($param{function})) {
608 $function->(pkg => $package,
611 submitter => $submitter,
612 severity => $severity,
622 =head1 PRIVATE FUNCTIONS
624 =head2 __handle_pkg_src_and_maint
626 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
627 qw(package src maint)
630 Turn package/src/maint into a list of packages
634 sub __handle_pkg_src_and_maint{
635 my %param = validate_with(params => \@_,
636 spec => {package => {type => SCALAR|ARRAYREF,
639 src => {type => SCALAR|ARRAYREF,
642 maint => {type => SCALAR|ARRAYREF,
650 @packages = make_list($param{package}) if exists $param{package};
651 my $package_keys = @packages?1:0;
653 @packages{@packages} = (1) x @packages;
654 if (exists $param{src}) {
655 # We only want to increment the number of keys if there is
658 # in case there are binaries with the same name as the
661 for my $package ((map {getsrcpkgs($_)} make_list($param{src}))) {
662 $packages{$package}++ unless exists $_temp_p{$package};
663 $_temp_p{$package} = 1;
666 for my $package (make_list($param{src})) {
667 $packages{"src:$package"}++ unless exists $_temp_p{"src:$package"};
668 $_temp_p{"src:$package"} = 1;
670 # As a temporary hack, we will also include $param{src}
671 # in this list for packages passed which do not have a
672 # corresponding binary package
673 if (not exists getpkgsrc()->{$package}) {
674 $packages{$package}++ unless exists $_temp_p{$package};
675 $_temp_p{$package} = 1;
678 $package_keys += $key_inc;
680 if (exists $param{maint}) {
683 for my $package (package_maintainer(maintainer=>$param{maint})) {
684 $packages{$package}++ unless exists $_temp_p{$package};
685 $_temp_p{$package} = 1;
688 $package_keys += $key_inc;
690 return grep {$packages{$_} >= $package_keys} keys %packages;
694 'subject' => \&__contains_field_match,
696 my ($field, $values, $status) = @_;
697 my %values = map {$_=>1} @$values;
698 foreach my $t (split /\s+/, $status->{$field}) {
699 return 1 if (defined $values{$t});
703 'severity' => \&__exact_field_match,
704 'pending' => \&__exact_field_match,
705 'package' => \&__exact_field_match,
706 'originator' => \&__contains_field_match,
707 'forwarded' => \&__contains_field_match,
708 'owner' => \&__contains_field_match,
712 my ($hash, $status) = @_;
713 foreach my $key( keys( %$hash ) ) {
714 my $value = $hash->{$key};
715 next unless exists $field_match{$key};
716 my $sub = $field_match{$key};
717 if (not defined $sub) {
718 die "No defined subroutine for key: $key";
720 return 1 if ($sub->($key, $value, $status));
725 sub __exact_field_match {
726 my ($field, $values, $status) = @_;
727 my @values = @$values;
728 my @ret = grep {$_ eq $status->{$field} } @values;
732 sub __contains_field_match {
733 my ($field, $values, $status) = @_;
734 foreach my $data (@$values) {
735 return 1 if (index($status->{$field}, $data) > -1);