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 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 $_non_search_key_regex = qr/^(bugs|archive|usertags|schema)$/;
157 my %_get_bugs_common_options =
158 (package => {type => SCALAR|ARRAYREF,
161 src => {type => SCALAR|ARRAYREF,
164 maint => {type => SCALAR|ARRAYREF,
167 submitter => {type => SCALAR|ARRAYREF,
170 severity => {type => SCALAR|ARRAYREF,
173 status => {type => SCALAR|ARRAYREF,
176 tag => {type => SCALAR|ARRAYREF,
179 owner => {type => SCALAR|ARRAYREF,
182 dist => {type => SCALAR|ARRAYREF,
185 correspondent => {type => SCALAR|ARRAYREF,
188 affects => {type => SCALAR|ARRAYREF,
191 function => {type => CODEREF,
194 bugs => {type => SCALAR|ARRAYREF,
197 archive => {type => BOOLEAN|SCALAR,
200 usertags => {type => HASHREF,
203 schema => {type => OBJECT,
209 my $_get_bugs_options = {%_get_bugs_common_options};
211 my %param = validate_with(params => \@_,
212 spec => $_get_bugs_options,
216 my %options = %param;
218 if ($options{archive} eq 'both') {
219 push @bugs, get_bugs(%options,archive=>0);
220 push @bugs, get_bugs(%options,archive=>1);
222 @bugs{@bugs} = @bugs;
225 # A configuration option will set an array that we'll use here instead.
226 for my $routine (qw(Debbugs::Bugs::get_bugs_by_db Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) {
227 my ($package) = $routine =~ m/^(.+)\:\:/;
228 eval "use $package;";
230 # We output errors here because using an invalid function
231 # in the configuration file isn't something that should
233 warn "use $package failed with $@";
236 @bugs = eval "${routine}(\%options)";
239 # We don't output errors here, because failure here
240 # via die may be a perfectly normal thing.
241 print STDERR "$@" if $DEBUG;
246 # If no one succeeded, die
255 count_bugs(function => sub {...})
257 Uses a subroutine to classify bugs into categories and return the
258 number of bugs which fall into those categories
263 my %param = validate_with(params => \@_,
264 spec => {function => {type => CODEREF,
266 archive => {type => BOOLEAN,
272 if ($param{archive}) {
273 $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
274 or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
277 $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
278 or die "Unable to open $config{spool_dir}/index.db for reading: $!";
282 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
283 my @x = $param{function}->(pkg => $1,
291 $count{$_}++ foreach @x;
300 my $bug = newest_bug();
302 Returns the bug number of the newest bug, which is nextnumber-1.
307 my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r')
308 or die "Unable to open $config{spool_dir}nextnumber for reading: $!";
310 my $next_number = <$nn_fh>;
313 return $next_number-1;
320 Allows filtering bugs on commonly used criteria
327 my %param = validate_with(params => \@_,
328 spec => {bug => {type => ARRAYREF|SCALAR,
331 status => {type => HASHREF|ARRAYREF,
334 seen_merged => {type => HASHREF,
337 repeat_merged => {type => BOOLEAN,
340 include => {type => HASHREF,
343 exclude => {type => HASHREF,
346 min_days => {type => SCALAR,
349 max_days => {type => SCALAR,
354 if (exists $param{repeat_merged} and
355 not $param{repeat_merged} and
356 not defined $param{seen_merged}) {
357 croak "repeat_merged false requires seen_merged to be passed";
359 if (not exists $param{bug} and not exists $param{status}) {
360 croak "one of bug or status must be passed";
363 if (not exists $param{status}) {
364 my $location = getbuglocation($param{bug}, 'summary');
365 return 0 if not defined $location or not length $location;
366 $param{status} = readbug( $param{bug}, $location );
367 return 0 if not defined $param{status};
370 if (exists $param{include}) {
371 return 1 if (!__bug_matches($param{include}, $param{status}));
373 if (exists $param{exclude}) {
374 return 1 if (__bug_matches($param{exclude}, $param{status}));
376 if (exists $param{repeat_merged} and not $param{repeat_merged}) {
377 my @merged = sort {$a<=>$b} $param{bug}, split(/ /, $param{status}{mergedwith});
378 return 1 if first {defined $_} @{$param{seen_merged}}{@merged};
379 @{$param{seen_merged}}{@merged} = (1) x @merged;
381 my $daysold = int((time - $param{status}{date}) / 86400); # seconds to days
382 if (exists $param{min_days}) {
383 return 1 unless $param{min_days} <= $daysold;
385 if (exists $param{max_days}) {
386 return 1 unless $param{max_days} == -1 or
387 $param{max_days} >= $daysold;
393 =head2 get_bugs_by_idx
395 This routine uses the by-$index.idx indicies to try to speed up
402 my $_get_bugs_by_idx_options =
403 {hash_slice(%_get_bugs_common_options,
404 (qw(package submitter severity tag archive),
405 qw(owner src maint bugs correspondent),
406 qw(affects usertags))
410 my %param = validate_with(params => \@_,
411 spec => $_get_bugs_by_idx_options
415 # If we're given an empty maint (unmaintained packages), we can't
416 # handle it, so bail out here
417 for my $maint (make_list(exists $param{maint}?$param{maint}:[])) {
418 if (defined $maint and $maint eq '') {
419 die "Can't handle empty maint (unmaintained packages) in get_bugs_by_idx";
423 # We handle src packages, maint and maintenc by mapping to the
424 # appropriate binary packages, then removing all packages which
425 # don't match all queries
426 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
427 qw(package src maint)
429 if (exists $param{package} or
430 exists $param{src} or
431 exists $param{maint}) {
432 delete @param{qw(maint src)};
433 $param{package} = [@packages];
435 my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param);
436 die "Need at least 1 key to search by" unless $keys;
437 my $arc = $param{archive} ? '-arc':'';
439 for my $key (grep {$_ !~ $_non_search_key_regex} keys %param) {
441 $index = 'submitter-email' if $key eq 'submitter';
442 $index = "$config{spool_dir}/by-${index}${arc}.idx";
443 tie(%idx, MLDBM => $index, O_RDONLY)
444 or die "Unable to open $index: $!";
445 my %bug_matching = ();
446 for my $search (make_list($param{$key})) {
447 for my $bug (keys %{$idx{$search}||{}}) {
448 next if $bug_matching{$bug};
449 # increment the number of searches that this bug matched
451 $bug_matching{$bug}=1;
453 if ($search ne lc($search)) {
454 for my $bug (keys %{$idx{lc($search)}||{}}) {
455 next if $bug_matching{$bug};
456 # increment the number of searches that this bug matched
458 $bug_matching{$bug}=1;
462 if ($key eq 'tag' and exists $param{usertags}) {
463 for my $bug (make_list(grep {defined $_ } @{$param{usertags}}{make_list($param{tag})})) {
464 next if $bug_matching{$bug};
466 $bug_matching{$bug}=1;
469 untie %idx or die 'Unable to untie %idx';
473 for my $bug (make_list($param{bugs})) {
477 # Throw out results that do not match all of the search specifications
478 return map {$keys <= $bugs{$_}?($_):()} keys %bugs;
482 =head2 get_bugs_by_db
484 This routine uses the database to try to speed up
490 my $_get_bugs_by_db_options =
491 {hash_slice(%_get_bugs_common_options,
492 (qw(package submitter severity tag archive),
493 qw(owner src maint bugs correspondent),
494 qw(affects usertags))
496 schema => {type => OBJECT,
500 my %param = validate_with(params => \@_,
501 spec => $_get_bugs_by_db_options,
505 # If we're given an empty maint (unmaintained packages), we can't
506 # handle it, so bail out here
507 for my $maint (make_list(exists $param{maint}?$param{maint}:[])) {
508 if (defined $maint and $maint eq '') {
509 die "Can't handle empty maint (unmaintained packages) in get_bugs_by_db";
513 # We handle src packages, maint and maintenc by mapping to the
514 # appropriate binary packages, then removing all packages which
515 # don't match all queries
516 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
517 qw(package src maint)
519 if (exists $param{package} or
520 exists $param{src} or
521 exists $param{maint}) {
522 delete @param{qw(maint src)};
523 $param{package} = [@packages];
525 my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param);
526 die "Need at least 1 key to search by" unless $keys;
527 my $rs = $param{schema}->resultset('Bug');
528 if (exists $param{severity}) {
529 $rs = $rs->search([map {('severity.severity' => $_)} make_list($param{severity})],
530 {join => 'severity'},
533 for my $key (qw(owner submitter done)) {
534 if (exists $param{$key}) {
535 $rs = $rs->search([map {("${key}.addr" => $_)} make_list($param{$key})],
540 if (exists $param{correspondent}) {
541 $rs = $rs->search([map {('message_correspondents.addr' => $_)} make_list($param{correspondent})],
542 {join => {correspondent =>
544 {message => 'message_correspondents'}}}},
547 if (exists $param{affects}) {
548 $rs = $rs->search([map {('bin_pkg.pkg' => $_)} make_list($param{affects}),
549 map {('src_pkg.pkg' => $_)} make_list($param{affects}),
551 {join => [{bug_affects_binpackages => 'bin_pkg'},
552 {bug_affects_srcpackages => 'src_pkg'},
557 if (exists $param{package}) {
558 $rs = $rs->search([map {('bin_pkg.pkg' => $_)} make_list($param{package})],
559 {join => {bug_binpackages => 'bin_pkg'}});
561 if (exists $param{src}) {
562 $rs = $rs->search([map {('src_pkg.pkg' => $_)} make_list($param{src})],
563 {join => {bug_srcpackages => 'src_pkg'}});
565 # tags are very odd, because we must handle usertags.
566 if (exists $param{tag}) {
567 # bugs from usertags which matter
568 my %bugs_matching_usertags;
569 for my $bug (make_list(grep {defined $_ } @{$param{usertags}}{make_list($param{tag})})) {
570 $bugs_matching_usertags{$bug} = 1;
572 # we want all bugs which either match the tag name given in
573 # param, or have a usertag set which matches one of the tag
574 # names given in param.
575 $rs = $rs->search([map {('tag.tag' => $_)} make_list($param{tag}),
576 map {('me.id' => $_)} keys %bugs_matching_usertags
578 {join => {bug_tags => 'tag'}});
580 if (exists $param{bugs}) {
581 $rs = $rs->search([map {('me.id' => $_)} make_list($param{bugs})]);
584 if (defined $param{archive} and $param{archive} ne 'both') {
585 $rs = $rs->search({'me.archived' => $param{archive}})
587 return $rs->get_column('id')->all();
591 =head2 get_bugs_flatfile
593 This is the fallback search routine. It should be able to complete all
594 searches. [Or at least, that's the idea.]
598 my $_get_bugs_flatfile_options =
599 {hash_slice(%_get_bugs_common_options,
600 map {$_ eq 'dist'?():($_)} keys %_get_bugs_common_options
604 sub get_bugs_flatfile{
605 my %param = validate_with(params => \@_,
606 spec => $_get_bugs_flatfile_options
609 if ($param{archive}) {
610 $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
611 or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
614 $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
615 or die "Unable to open $config{spool_dir}/index.db for reading: $!";
618 if (exists $param{tag} and exists $param{usertags}) {
619 # This complex slice makes a hash with the bugs which have the
620 # usertags passed in $param{tag} set.
621 @usertag_bugs{make_list(@{$param{usertags}}{make_list($param{tag})})
622 } = (1) x make_list(@{$param{usertags}}{make_list($param{tag})});
624 my $unmaintained_packages = 0;
625 # unmaintained packages is a special case
626 my @maints = make_list(exists $param{maint}?$param{maint}:[]);
628 for my $maint (@maints) {
629 if (defined $maint and $maint eq '' and not $unmaintained_packages) {
630 $unmaintained_packages = 1;
631 our %maintainers = %{getmaintainers()};
632 $param{function} = [(exists $param{function}?
633 (ref $param{function}?@{$param{function}}:$param{function}):()),
635 foreach my $try (make_list($d{"pkg"})) {
636 next unless length $try;
637 ($try) = $try =~ m/^(?:src:)?(.+)/;
638 return 1 if not exists $maintainers{$try};
644 elsif (defined $maint and $maint ne '') {
645 push @{$param{maint}},$maint;
648 # We handle src packages, maint and maintenc by mapping to the
649 # appropriate binary packages, then removing all packages which
650 # don't match all queries
651 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
652 qw(package src maint)
654 if (exists $param{package} or
655 exists $param{src} or
656 exists $param{maint}) {
657 delete @param{qw(maint src)};
658 $param{package} = [@packages] if @packages;
662 if (exists $param{bugs}) {
663 $bugs{$_} = 1 for make_list($param{bugs});
666 # These queries have to be handled by get_bugs_by_idx
667 if (exists $param{owner}
668 or exists $param{correspondent}
669 or exists $param{affects}) {
670 $bugs{$_} = 1 for get_bugs_by_idx(map {exists $param{$_}?($_,$param{$_}):()}
671 qw(owner correspondent affects),
676 BUG: while (<$flatfile>) {
677 next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*(.*)\s*\]\s+(\w+)\s+(.*)$/;
678 my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7);
679 next if $grep_bugs and not exists $bugs{$bug};
680 if (exists $param{package}) {
681 my @packages = splitpackages($pkg);
682 next unless grep { my $pkg_list = $_;
683 grep {$pkg_list eq $_} make_list($param{package})
686 if (exists $param{src}) {
687 my @src_packages = map { getsrcpkgs($_)} make_list($param{src});
688 my @packages = splitpackages($pkg);
689 next unless grep { my $pkg_list = $_;
690 grep {$pkg_list eq $_} @packages
693 if (exists $param{submitter}) {
694 my @p_addrs = map {lc($_->address)}
695 map {getparsedaddrs($_)}
696 make_list($param{submitter});
697 my @f_addrs = map {$_->address}
698 getparsedaddrs($submitter||'');
699 next unless grep { my $f_addr = $_;
700 grep {$f_addr eq $_} @p_addrs
703 next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity});
704 next if exists $param{status} and not grep {$status eq $_} make_list($param{status});
705 if (exists $param{tag}) {
707 # either a normal tag, or a usertag must be set
708 $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug};
709 my @bug_tags = split ' ', $tags;
710 $bug_ok = 1 if grep {my $bug_tag = $_;
711 grep {$bug_tag eq $_} make_list($param{tag});
715 # We do this last, because a function may be slow...
716 if (exists $param{function}) {
717 my @bug_tags = split ' ', $tags;
718 my @packages = splitpackages($pkg);
719 my $package = (@packages > 1)?\@packages:$packages[0];
720 for my $function (make_list($param{function})) {
722 $function->(pkg => $package,
725 submitter => $submitter,
726 severity => $severity,
736 =head1 PRIVATE FUNCTIONS
738 =head2 __handle_pkg_src_and_maint
740 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
741 qw(package src maint)
744 Turn package/src/maint into a list of packages
748 sub __handle_pkg_src_and_maint{
749 my %param = validate_with(params => \@_,
750 spec => {package => {type => SCALAR|ARRAYREF,
753 src => {type => SCALAR|ARRAYREF,
756 maint => {type => SCALAR|ARRAYREF,
764 @packages = make_list($param{package}) if exists $param{package};
765 my $package_keys = @packages?1:0;
767 @packages{@packages} = (1) x @packages;
768 if (exists $param{src}) {
769 # We only want to increment the number of keys if there is
772 # in case there are binaries with the same name as the
775 for my $package ((map {getsrcpkgs($_)} make_list($param{src}))) {
776 $packages{$package}++ unless exists $_temp_p{$package};
777 $_temp_p{$package} = 1;
780 for my $package (make_list($param{src})) {
781 $packages{"src:$package"}++ unless exists $_temp_p{"src:$package"};
782 $_temp_p{"src:$package"} = 1;
784 # As a temporary hack, we will also include $param{src}
785 # in this list for packages passed which do not have a
786 # corresponding binary package
787 if (not exists getpkgsrc()->{$package}) {
788 $packages{$package}++ unless exists $_temp_p{$package};
789 $_temp_p{$package} = 1;
792 $package_keys += $key_inc;
794 if (exists $param{maint}) {
797 for my $package (package_maintainer(maintainer=>$param{maint})) {
798 $packages{$package}++ unless exists $_temp_p{$package};
799 $_temp_p{$package} = 1;
802 $package_keys += $key_inc;
804 return grep {$packages{$_} >= $package_keys} keys %packages;
808 'subject' => \&__contains_field_match,
810 my ($field, $values, $status) = @_;
811 my %values = map {$_=>1} @$values;
812 foreach my $t (split /\s+/, $status->{$field}) {
813 return 1 if (defined $values{$t});
817 'severity' => \&__exact_field_match,
818 'pending' => \&__exact_field_match,
819 'package' => \&__exact_field_match,
820 'originator' => \&__contains_field_match,
821 'forwarded' => \&__contains_field_match,
822 'owner' => \&__contains_field_match,
826 my ($hash, $status) = @_;
827 foreach my $key( keys( %$hash ) ) {
828 my $value = $hash->{$key};
829 next unless exists $field_match{$key};
830 my $sub = $field_match{$key};
831 if (not defined $sub) {
832 die "No defined subroutine for key: $key";
834 return 1 if ($sub->($key, $value, $status));
839 sub __exact_field_match {
840 my ($field, $values, $status) = @_;
841 my @values = @$values;
842 my @ret = grep {$_ eq $status->{$field} } @values;
846 sub __contains_field_match {
847 my ($field, $values, $status) = @_;
848 foreach my $data (@$values) {
849 return 1 if (index($status->{$field}, $data) > -1);