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);
58 use Debbugs::Common qw(getparsedaddrs getmaintainers getmaintainers_reverse 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 dist -- distribution (I don't know about this one yet)
95 =item bugs -- list of bugs to search within
97 =item function -- see description below
101 =head3 Special options
103 The following options are special options used to modulate how the
104 searches are performed.
108 =item archive -- whether to search archived bugs or normal bugs;
109 defaults to false. As a special case, if archive is 'both', but
110 archived and unarchived bugs are returned.
112 =item usertags -- set of usertags and the bugs they are applied to
117 =head3 Subsidiary routines
119 All subsidiary routines get passed exactly the same set of options as
120 get_bugs. If for some reason they are unable to handle the options
121 passed (for example, they don't have the right type of index for the
122 type of selection) they should die as early as possible. [Using
123 Params::Validate and/or die when files don't exist makes this fairly
126 This function will then immediately move on to the next subroutine,
127 giving it the same arguments.
131 This option allows you to provide an arbitrary function which will be
132 given the information in the index.db file. This will be super, super
133 slow, so only do this if there's no other way to write the search.
135 You'll be given a list (which you can turn into a hash) like the
138 (pkg => ['a','b'], # may be a scalar (most common)
141 submitter => 'boo@baz.com',
142 severity => 'serious',
143 tags => ['a','b','c'], # may be an empty arrayref
146 The function should return 1 if the bug should be included; 0 if the
152 my %param = validate_with(params => \@_,
153 spec => {package => {type => SCALAR|ARRAYREF,
156 src => {type => SCALAR|ARRAYREF,
159 maint => {type => SCALAR|ARRAYREF,
162 submitter => {type => SCALAR|ARRAYREF,
165 severity => {type => SCALAR|ARRAYREF,
168 status => {type => SCALAR|ARRAYREF,
171 tag => {type => SCALAR|ARRAYREF,
174 owner => {type => SCALAR|ARRAYREF,
177 dist => {type => SCALAR|ARRAYREF,
180 function => {type => CODEREF,
183 bugs => {type => SCALAR|ARRAYREF,
186 archive => {type => BOOLEAN|SCALAR,
189 usertags => {type => HASHREF,
196 my %options = %param;
198 if ($options{archive} eq 'both') {
199 push @bugs, get_bugs(%options,archive=>0);
200 push @bugs, get_bugs(%options,archive=>1);
202 @bugs{@bugs} = @bugs;
205 # A configuration option will set an array that we'll use here instead.
206 for my $routine (qw(Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) {
207 my ($package) = $routine =~ m/^(.+)\:\:/;
208 eval "use $package;";
210 # We output errors here because using an invalid function
211 # in the configuration file isn't something that should
213 warn "use $package failed with $@";
216 @bugs = eval "${routine}(\%options)";
219 # We don't output errors here, because failure here
220 # via die may be a perfectly normal thing.
221 print STDERR "$@" if $DEBUG;
226 # If no one succeeded, die
235 count_bugs(function => sub {...})
237 Uses a subroutine to classify bugs into categories and return the
238 number of bugs which fall into those categories
243 my %param = validate_with(params => \@_,
244 spec => {function => {type => CODEREF,
246 archive => {type => BOOLEAN,
252 if ($param{archive}) {
253 $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
254 or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
257 $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
258 or die "Unable to open $config{spool_dir}/index.db for reading: $!";
262 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
263 my @x = $param{function}->(pkg => $1,
271 $count{$_}++ foreach @x;
280 my $bug = newest_bug();
282 Returns the bug number of the newest bug, which is nextnumber-1.
287 my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r')
288 or die "Unable to open $config{spool_dir}nextnumber for reading: $!";
290 my $next_number = <$nn_fh>;
293 return $next_number-1;
300 Allows filtering bugs on commonly used criteria
305 my %param = validate_with(params => \@_,
306 spec => {bug => {type => SCALAR,
309 status => {type => HASHREF,
312 seen_merged => {type => HASHREF,
315 repeat_merged => {type => BOOLEAN,
318 include => {type => HASHREF,
321 exclude => {type => HASHREF,
324 min_days => {type => SCALAR,
327 max_days => {type => SCALAR,
332 if (exists $param{repeat_merged} and
333 not $param{repeat_merged} and
334 not defined $param{seen_merged}) {
335 croak "repeat_merged false requires seen_merged to be passed";
338 if (not exists $param{status}) {
339 my $location = getbuglocation($param{bug}, 'summary');
340 return 0 if not defined $location or not length $location;
341 $param{status} = readbug( $param{bug}, $location );
342 return 0 if not defined $param{status};
345 if (exists $param{include}) {
346 return 1 if (!__bug_matches($param{include}, $param{status}));
348 if (exists $param{exclude}) {
349 return 1 if (__bug_matches($param{exclude}, $param{status}));
351 if (exists $param{repeat_merged} and not $param{repeat_merged}) {
352 my @merged = sort {$a<=>$b} $param{bug}, split(/ /, $param{status}{mergedwith});
353 return 1 if first {defined $_} @{$param{seen_merged}}{@merged};
354 @{$param{seen_merged}}{@merged} = (1) x @merged;
356 my $daysold = int((time - $param{status}{date}) / 86400); # seconds to days
357 if (exists $param{min_days}) {
358 return 1 unless $param{min_days} <= $daysold;
360 if (exists $param{max_days}) {
361 return 1 unless $param{max_days} == -1 or
362 $param{max_days} >= $daysold;
368 =head2 get_bugs_by_idx
370 This routine uses the by-$index.idx indicies to try to speed up
377 my %param = validate_with(params => \@_,
378 spec => {package => {type => SCALAR|ARRAYREF,
381 submitter => {type => SCALAR|ARRAYREF,
384 severity => {type => SCALAR|ARRAYREF,
387 tag => {type => SCALAR|ARRAYREF,
390 archive => {type => BOOLEAN,
393 owner => {type => SCALAR|ARRAYREF,
396 src => {type => SCALAR|ARRAYREF,
399 maint => {type => SCALAR|ARRAYREF,
402 bugs => {type => SCALAR|ARRAYREF,
405 usertags => {type => HASHREF,
412 # We handle src packages, maint and maintenc by mapping to the
413 # appropriate binary packages, then removing all packages which
414 # don't match all queries
415 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
416 qw(package src maint)
418 if (exists $param{package} or
419 exists $param{src} or
420 exists $param{maint}) {
421 delete @param{qw(maint src)};
422 $param{package} = [@packages];
424 my $keys = grep {$_ !~ /^(archive|usertags|bugs)$/} keys(%param);
425 die "Need at least 1 key to search by" unless $keys;
426 my $arc = $param{archive} ? '-arc':'';
428 for my $key (grep {$_ !~ /^(archive|usertags|bugs)$/} keys %param) {
430 $index = 'submitter-email' if $key eq 'submitter';
431 $index = "$config{spool_dir}/by-${index}${arc}.idx";
432 tie(%idx, MLDBM => $index, O_RDONLY)
433 or die "Unable to open $index: $!";
434 my %bug_matching = ();
435 for my $search (make_list($param{$key})) {
436 for my $bug (keys %{$idx{$search}||{}}) {
437 next if $bug_matching{$bug};
438 # increment the number of searches that this bug matched
440 $bug_matching{$bug}=1;
442 if ($search ne lc($search)) {
443 for my $bug (keys %{$idx{lc($search)}||{}}) {
444 next if $bug_matching{$bug};
445 # increment the number of searches that this bug matched
447 $bug_matching{$bug}=1;
451 if ($key eq 'tag' and exists $param{usertags}) {
452 for my $bug (make_list(grep {defined $_ } @{$param{usertags}}{make_list($param{tag})})) {
453 next if $bug_matching{$bug};
455 $bug_matching{$bug}=1;
458 untie %idx or die 'Unable to untie %idx';
462 for my $bug (make_list($param{bugs})) {
466 # Throw out results that do not match all of the search specifications
467 return map {$keys <= $bugs{$_}?($_):()} keys %bugs;
471 =head2 get_bugs_flatfile
473 This is the fallback search routine. It should be able to complete all
474 searches. [Or at least, that's the idea.]
478 sub get_bugs_flatfile{
479 my %param = validate_with(params => \@_,
480 spec => {package => {type => SCALAR|ARRAYREF,
483 src => {type => SCALAR|ARRAYREF,
486 maint => {type => SCALAR|ARRAYREF,
489 submitter => {type => SCALAR|ARRAYREF,
492 severity => {type => SCALAR|ARRAYREF,
495 status => {type => SCALAR|ARRAYREF,
498 tag => {type => SCALAR|ARRAYREF,
502 # owner => {type => SCALAR|ARRAYREF,
505 # dist => {type => SCALAR|ARRAYREF,
508 archive => {type => BOOLEAN,
511 usertags => {type => HASHREF,
514 function => {type => CODEREF,
520 if ($param{archive}) {
521 $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
522 or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
525 $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
526 or die "Unable to open $config{spool_dir}/index.db for reading: $!";
529 if (exists $param{tag} and exists $param{usertags}) {
530 # This complex slice makes a hash with the bugs which have the
531 # usertags passed in $param{tag} set.
532 @usertag_bugs{make_list(@{$param{usertags}}{make_list($param{tag})})
533 } = (1) x make_list(@{$param{usertags}}{make_list($param{tag})});
535 # We handle src packages, maint and maintenc by mapping to the
536 # appropriate binary packages, then removing all packages which
537 # don't match all queries
538 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
539 qw(package src maint)
541 if (exists $param{package} or
542 exists $param{src} or
543 exists $param{maint}) {
544 delete @param{qw(maint src)};
545 $param{package} = [@packages];
548 while (<$flatfile>) {
549 next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/;
550 my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7);
551 next if exists $param{bugs} and not grep {$bug == $_} make_list($param{bugs});
552 if (exists $param{package}) {
553 my @packages = splitpackages($pkg);
554 next unless grep { my $pkg_list = $_;
555 grep {$pkg_list eq $_} make_list($param{package})
558 if (exists $param{src}) {
559 my @src_packages = map { getsrcpkgs($_)} make_list($param{src});
560 my @packages = splitpackages($pkg);
561 next unless grep { my $pkg_list = $_;
562 grep {$pkg_list eq $_} @packages
565 if (exists $param{submitter}) {
566 my @p_addrs = map {lc($_->address)}
567 map {getparsedaddrs($_)}
568 make_list($param{submitter});
569 my @f_addrs = map {$_->address}
570 getparsedaddrs($submitter||'');
571 next unless grep { my $f_addr = $_;
572 grep {$f_addr eq $_} @p_addrs
575 next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity});
576 next if exists $param{status} and not grep {$status eq $_} make_list($param{status});
577 if (exists $param{tag}) {
579 # either a normal tag, or a usertag must be set
580 $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug};
581 my @bug_tags = split ' ', $tags;
582 $bug_ok = 1 if grep {my $bug_tag = $_;
583 grep {$bug_tag eq $_} make_list($param{tag});
587 # We do this last, because a function may be slow...
588 if (exists $param{function}) {
589 my @bug_tags = split ' ', $tags;
590 my @packages = splitpackages($pkg);
591 my $package = (@packages > 1)?\@packages:$packages[0];
593 $param{function}->(pkg => $package,
596 submitter => $submitter,
597 severity => $severity,
606 =head1 PRIVATE FUNCTIONS
608 =head2 __handle_pkg_src_and_maint
610 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
611 qw(package src maint)
614 Turn package/src/maint into a list of packages
618 sub __handle_pkg_src_and_maint{
619 my %param = validate_with(params => \@_,
620 spec => {package => {type => SCALAR|ARRAYREF,
623 src => {type => SCALAR|ARRAYREF,
626 maint => {type => SCALAR|ARRAYREF,
634 @packages = make_list($param{package}) if exists $param{package};
635 my $package_keys = @packages?1:0;
637 @packages{@packages} = (1) x @packages;
638 if (exists $param{src}) {
639 # We only want to increment the number of keys if there is
642 for my $package ((map { getsrcpkgs($_)} make_list($param{src})),make_list($param{src})) {
643 $packages{$package}++;
646 $package_keys += $key_inc;
648 if (exists $param{maint}) {
650 my $maint_rev = getmaintainers_reverse();
651 for my $package (map { exists $maint_rev->{$_}?@{$maint_rev->{$_}}:()}
652 make_list($param{maint})) {
653 $packages{$package}++;
656 $package_keys += $key_inc;
658 return grep {$packages{$_} >= $package_keys} keys %packages;
662 'subject' => \&__contains_field_match,
664 my ($field, $values, $status) = @_;
665 my %values = map {$_=>1} @$values;
666 foreach my $t (split /\s+/, $status->{$field}) {
667 return 1 if (defined $values{$t});
671 'severity' => \&__exact_field_match,
672 'pending' => \&__exact_field_match,
673 'originator' => \&__contains_field_match,
674 'forwarded' => \&__contains_field_match,
675 'owner' => \&__contains_field_match,
679 my ($hash, $status) = @_;
680 foreach my $key( keys( %$hash ) ) {
681 my $value = $hash->{$key};
682 my $sub = $field_match{$key};
683 return 1 if ($sub->($key, $value, $status));
688 sub __exact_field_match {
689 my ($field, $values, $status) = @_;
690 my @values = @$values;
691 my @ret = grep {$_ eq $status->{$field} } @values;
695 sub __contains_field_match {
696 my ($field, $values, $status) = @_;
697 foreach my $data (@$values) {
698 return 1 if (index($status->{$field}, $data) > -1);