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 Exporter qw(import);
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);
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
156 my %param = validate_with(params => \@_,
157 spec => {package => {type => SCALAR|ARRAYREF,
160 src => {type => SCALAR|ARRAYREF,
163 maint => {type => SCALAR|ARRAYREF,
166 submitter => {type => SCALAR|ARRAYREF,
169 severity => {type => SCALAR|ARRAYREF,
172 status => {type => SCALAR|ARRAYREF,
175 tag => {type => SCALAR|ARRAYREF,
178 owner => {type => SCALAR|ARRAYREF,
181 dist => {type => SCALAR|ARRAYREF,
184 correspondent => {type => SCALAR|ARRAYREF,
187 affects => {type => SCALAR|ARRAYREF,
190 function => {type => CODEREF,
193 bugs => {type => SCALAR|ARRAYREF,
196 archive => {type => BOOLEAN|SCALAR,
199 usertags => {type => HASHREF,
206 my %options = %param;
208 if ($options{archive} eq 'both') {
209 push @bugs, get_bugs(%options,archive=>0);
210 push @bugs, get_bugs(%options,archive=>1);
212 @bugs{@bugs} = @bugs;
215 # A configuration option will set an array that we'll use here instead.
216 for my $routine (qw(Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) {
217 my ($package) = $routine =~ m/^(.+)\:\:/;
218 eval "use $package;";
220 # We output errors here because using an invalid function
221 # in the configuration file isn't something that should
223 warn "use $package failed with $@";
226 @bugs = eval "${routine}(\%options)";
229 # We don't output errors here, because failure here
230 # via die may be a perfectly normal thing.
231 print STDERR "$@" if $DEBUG;
236 # If no one succeeded, die
245 count_bugs(function => sub {...})
247 Uses a subroutine to classify bugs into categories and return the
248 number of bugs which fall into those categories
253 my %param = validate_with(params => \@_,
254 spec => {function => {type => CODEREF,
256 archive => {type => BOOLEAN,
262 if ($param{archive}) {
263 $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
264 or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
267 $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
268 or die "Unable to open $config{spool_dir}/index.db for reading: $!";
272 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
273 my @x = $param{function}->(pkg => $1,
281 $count{$_}++ foreach @x;
290 my $bug = newest_bug();
292 Returns the bug number of the newest bug, which is nextnumber-1.
297 my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r')
298 or die "Unable to open $config{spool_dir}nextnumber for reading: $!";
300 my $next_number = <$nn_fh>;
303 return $next_number-1;
310 Allows filtering bugs on commonly used criteria
317 my %param = validate_with(params => \@_,
318 spec => {bug => {type => ARRAYREF|SCALAR,
321 status => {type => HASHREF|ARRAYREF,
324 seen_merged => {type => HASHREF,
327 repeat_merged => {type => BOOLEAN,
330 include => {type => HASHREF,
333 exclude => {type => HASHREF,
336 min_days => {type => SCALAR,
339 max_days => {type => SCALAR,
344 if (exists $param{repeat_merged} and
345 not $param{repeat_merged} and
346 not defined $param{seen_merged}) {
347 croak "repeat_merged false requires seen_merged to be passed";
349 if (not exists $param{bug} and not exists $param{status}) {
350 croak "one of bug or status must be passed";
353 if (not exists $param{status}) {
354 my $location = getbuglocation($param{bug}, 'summary');
355 return 0 if not defined $location or not length $location;
356 $param{status} = readbug( $param{bug}, $location );
357 return 0 if not defined $param{status};
360 if (exists $param{include}) {
361 return 1 if (!__bug_matches($param{include}, $param{status}));
363 if (exists $param{exclude}) {
364 return 1 if (__bug_matches($param{exclude}, $param{status}));
366 if (exists $param{repeat_merged} and not $param{repeat_merged}) {
367 my @merged = sort {$a<=>$b} $param{bug}, split(/ /, $param{status}{mergedwith});
368 return 1 if first {defined $_} @{$param{seen_merged}}{@merged};
369 @{$param{seen_merged}}{@merged} = (1) x @merged;
371 my $daysold = int((time - $param{status}{date}) / 86400); # seconds to days
372 if (exists $param{min_days}) {
373 return 1 unless $param{min_days} <= $daysold;
375 if (exists $param{max_days}) {
376 return 1 unless $param{max_days} == -1 or
377 $param{max_days} >= $daysold;
383 =head2 get_bugs_by_idx
385 This routine uses the by-$index.idx indicies to try to speed up
392 my %param = validate_with(params => \@_,
393 spec => {package => {type => SCALAR|ARRAYREF,
396 submitter => {type => SCALAR|ARRAYREF,
399 severity => {type => SCALAR|ARRAYREF,
402 tag => {type => SCALAR|ARRAYREF,
405 archive => {type => BOOLEAN,
408 owner => {type => SCALAR|ARRAYREF,
411 src => {type => SCALAR|ARRAYREF,
414 maint => {type => SCALAR|ARRAYREF,
417 bugs => {type => SCALAR|ARRAYREF,
420 correspondent => {type => SCALAR|ARRAYREF,
423 affects => {type => SCALAR|ARRAYREF,
426 usertags => {type => HASHREF,
433 # If we're given an empty maint (unmaintained packages), we can't
434 # handle it, so bail out here
435 for my $maint (make_list(exists $param{maint}?$param{maint}:[])) {
436 if (defined $maint and $maint eq '') {
437 die "Can't handle empty maint (unmaintained packages) in get_bugs_by_idx";
441 # We handle src packages, maint and maintenc by mapping to the
442 # appropriate binary packages, then removing all packages which
443 # don't match all queries
444 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
445 qw(package src maint)
447 if (exists $param{package} or
448 exists $param{src} or
449 exists $param{maint}) {
450 delete @param{qw(maint src)};
451 $param{package} = [@packages];
453 my $keys = grep {$_ !~ /^(archive|usertags|bugs)$/} keys(%param);
454 die "Need at least 1 key to search by" unless $keys;
455 my $arc = $param{archive} ? '-arc':'';
457 for my $key (grep {$_ !~ /^(archive|usertags|bugs)$/} keys %param) {
459 $index = 'submitter-email' if $key eq 'submitter';
460 $index = "$config{spool_dir}/by-${index}${arc}.idx";
461 tie(%idx, MLDBM => $index, O_RDONLY)
462 or die "Unable to open $index: $!";
463 my %bug_matching = ();
464 for my $search (make_list($param{$key})) {
465 for my $bug (keys %{$idx{$search}||{}}) {
466 next if $bug_matching{$bug};
467 # increment the number of searches that this bug matched
469 $bug_matching{$bug}=1;
471 if ($search ne lc($search)) {
472 for my $bug (keys %{$idx{lc($search)}||{}}) {
473 next if $bug_matching{$bug};
474 # increment the number of searches that this bug matched
476 $bug_matching{$bug}=1;
480 if ($key eq 'tag' and exists $param{usertags}) {
481 for my $bug (make_list(grep {defined $_ } @{$param{usertags}}{make_list($param{tag})})) {
482 next if $bug_matching{$bug};
484 $bug_matching{$bug}=1;
487 untie %idx or die 'Unable to untie %idx';
491 for my $bug (make_list($param{bugs})) {
495 # Throw out results that do not match all of the search specifications
496 return map {$keys <= $bugs{$_}?($_):()} keys %bugs;
500 =head2 get_bugs_flatfile
502 This is the fallback search routine. It should be able to complete all
503 searches. [Or at least, that's the idea.]
507 sub get_bugs_flatfile{
508 my %param = validate_with(params => \@_,
509 spec => {package => {type => SCALAR|ARRAYREF,
512 src => {type => SCALAR|ARRAYREF,
515 maint => {type => SCALAR|ARRAYREF,
518 submitter => {type => SCALAR|ARRAYREF,
521 severity => {type => SCALAR|ARRAYREF,
524 status => {type => SCALAR|ARRAYREF,
527 tag => {type => SCALAR|ARRAYREF,
530 owner => {type => SCALAR|ARRAYREF,
533 correspondent => {type => SCALAR|ARRAYREF,
536 affects => {type => SCALAR|ARRAYREF,
540 # dist => {type => SCALAR|ARRAYREF,
543 bugs => {type => SCALAR|ARRAYREF,
546 archive => {type => BOOLEAN,
549 usertags => {type => HASHREF,
552 function => {type => CODEREF,
558 if ($param{archive}) {
559 $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
560 or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
563 $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
564 or die "Unable to open $config{spool_dir}/index.db for reading: $!";
567 if (exists $param{tag} and exists $param{usertags}) {
568 # This complex slice makes a hash with the bugs which have the
569 # usertags passed in $param{tag} set.
570 @usertag_bugs{make_list(@{$param{usertags}}{make_list($param{tag})})
571 } = (1) x make_list(@{$param{usertags}}{make_list($param{tag})});
573 my $unmaintained_packages = 0;
574 # unmaintained packages is a special case
575 my @maints = make_list(exists $param{maint}?$param{maint}:[]);
577 for my $maint (@maints) {
578 if (defined $maint and $maint eq '' and not $unmaintained_packages) {
579 $unmaintained_packages = 1;
580 our %maintainers = %{getmaintainers()};
581 $param{function} = [(exists $param{function}?
582 (ref $param{function}?@{$param{function}}:$param{function}):()),
584 foreach my $try (make_list($d{"pkg"})) {
585 next unless length $try;
586 ($try) = $try =~ m/^(?:src:)?(.+)/;
587 return 1 if not exists $maintainers{$try};
593 elsif (defined $maint and $maint ne '') {
594 push @{$param{maint}},$maint;
597 # We handle src packages, maint and maintenc by mapping to the
598 # appropriate binary packages, then removing all packages which
599 # don't match all queries
600 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
601 qw(package src maint)
603 if (exists $param{package} or
604 exists $param{src} or
605 exists $param{maint}) {
606 delete @param{qw(maint src)};
607 $param{package} = [@packages] if @packages;
611 if (exists $param{bugs}) {
612 $bugs{$_} = 1 for make_list($param{bugs});
615 # These queries have to be handled by get_bugs_by_idx
616 if (exists $param{owner}
617 or exists $param{correspondent}
618 or exists $param{affects}) {
619 $bugs{$_} = 1 for get_bugs_by_idx(map {exists $param{$_}?($_,$param{$_}):()}
620 qw(owner correspondent affects),
625 BUG: while (<$flatfile>) {
626 next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*(.*)\s*\]\s+(\w+)\s+(.*)$/;
627 my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7);
628 next if $grep_bugs and not exists $bugs{$bug};
629 if (exists $param{package}) {
630 my @packages = splitpackages($pkg);
631 next unless grep { my $pkg_list = $_;
632 grep {$pkg_list eq $_} make_list($param{package})
635 if (exists $param{src}) {
636 my @src_packages = map { getsrcpkgs($_)} make_list($param{src});
637 my @packages = splitpackages($pkg);
638 next unless grep { my $pkg_list = $_;
639 grep {$pkg_list eq $_} @packages
642 if (exists $param{submitter}) {
643 my @p_addrs = map {lc($_->address)}
644 map {getparsedaddrs($_)}
645 make_list($param{submitter});
646 my @f_addrs = map {$_->address}
647 getparsedaddrs($submitter||'');
648 next unless grep { my $f_addr = $_;
649 grep {$f_addr eq $_} @p_addrs
652 next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity});
653 next if exists $param{status} and not grep {$status eq $_} make_list($param{status});
654 if (exists $param{tag}) {
656 # either a normal tag, or a usertag must be set
657 $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug};
658 my @bug_tags = split ' ', $tags;
659 $bug_ok = 1 if grep {my $bug_tag = $_;
660 grep {$bug_tag eq $_} make_list($param{tag});
664 # We do this last, because a function may be slow...
665 if (exists $param{function}) {
666 my @bug_tags = split ' ', $tags;
667 my @packages = splitpackages($pkg);
668 my $package = (@packages > 1)?\@packages:$packages[0];
669 for my $function (make_list($param{function})) {
671 $function->(pkg => $package,
674 submitter => $submitter,
675 severity => $severity,
685 =head1 PRIVATE FUNCTIONS
687 =head2 __handle_pkg_src_and_maint
689 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
690 qw(package src maint)
693 Turn package/src/maint into a list of packages
697 sub __handle_pkg_src_and_maint{
698 my %param = validate_with(params => \@_,
699 spec => {package => {type => SCALAR|ARRAYREF,
702 src => {type => SCALAR|ARRAYREF,
705 maint => {type => SCALAR|ARRAYREF,
713 @packages = make_list($param{package}) if exists $param{package};
714 my $package_keys = @packages?1:0;
716 @packages{@packages} = (1) x @packages;
717 if (exists $param{src}) {
718 # We only want to increment the number of keys if there is
721 # in case there are binaries with the same name as the
724 for my $package ((map {getsrcpkgs($_)} make_list($param{src}))) {
725 $packages{$package}++ unless exists $_temp_p{$package};
726 $_temp_p{$package} = 1;
729 for my $package (make_list($param{src})) {
730 $packages{"src:$package"}++ unless exists $_temp_p{"src:$package"};
731 $_temp_p{"src:$package"} = 1;
733 # As a temporary hack, we will also include $param{src}
734 # in this list for packages passed which do not have a
735 # corresponding binary package
736 if (not exists getpkgsrc()->{$package}) {
737 $packages{$package}++ unless exists $_temp_p{$package};
738 $_temp_p{$package} = 1;
741 $package_keys += $key_inc;
743 if (exists $param{maint}) {
746 for my $package (package_maintainer(maintainer=>$param{maint})) {
747 $packages{$package}++ unless exists $_temp_p{$package};
748 $_temp_p{$package} = 1;
751 $package_keys += $key_inc;
753 return grep {$packages{$_} >= $package_keys} keys %packages;
757 'subject' => \&__contains_field_match,
759 my ($field, $values, $status) = @_;
760 my %values = map {$_=>1} @$values;
761 foreach my $t (split /\s+/, $status->{$field}) {
762 return 1 if (defined $values{$t});
766 'severity' => \&__exact_field_match,
767 'pending' => \&__exact_field_match,
768 'package' => \&__exact_field_match,
769 'originator' => \&__contains_field_match,
770 'forwarded' => \&__contains_field_match,
771 'owner' => \&__contains_field_match,
775 my ($hash, $status) = @_;
776 foreach my $key( keys( %$hash ) ) {
777 my $value = $hash->{$key};
778 next unless exists $field_match{$key};
779 my $sub = $field_match{$key};
780 if (not defined $sub) {
781 die "No defined subroutine for key: $key";
783 return 1 if ($sub->($key, $value, $status));
788 sub __exact_field_match {
789 my ($field, $values, $status) = @_;
790 my @values = @$values;
791 my @ret = grep {$_ eq $status->{$field} } @values;
795 sub __contains_field_match {
796 my ($field, $values, $status) = @_;
797 foreach my $data (@$values) {
798 return 1 if (index($status->{$field}, $data) > -1);