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));
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);
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);
68 The following parameters can either be a single scalar or a reference
69 to an array. The parameters are ANDed together, and the elements of
70 arrayrefs are a parameter are ORed. Future versions of this may allow
71 for limited regular expressions, and/or more complex expressions.
75 =item package -- name of the binary package
77 =item src -- name of the source package
79 =item maint -- address of the maintainer
81 =item submitter -- address of the submitter
83 =item severity -- severity of the bug
85 =item status -- status of the bug
89 =item owner -- owner of the bug
91 =item dist -- distribution (I don't know about this one yet)
93 =item bugs -- list of bugs to search within
95 =item function -- see description below
99 =head3 Special options
101 The following options are special options used to modulate how the
102 searches are performed.
106 =item archive -- whether to search archived bugs or normal bugs;
107 defaults to false. As a special case, if archive is 'both', but
108 archived and unarchived bugs are returned.
110 =item usertags -- set of usertags and the bugs they are applied to
115 =head3 Subsidiary routines
117 All subsidiary routines get passed exactly the same set of options as
118 get_bugs. If for some reason they are unable to handle the options
119 passed (for example, they don't have the right type of index for the
120 type of selection) they should die as early as possible. [Using
121 Params::Validate and/or die when files don't exist makes this fairly
124 This function will then immediately move on to the next subroutine,
125 giving it the same arguments.
129 This option allows you to provide an arbitrary function which will be
130 given the information in the index.db file. This will be super, super
131 slow, so only do this if there's no other way to write the search.
133 You'll be given a list (which you can turn into a hash) like the
136 (pkg => ['a','b'], # may be a scalar (most common)
139 submitter => 'boo@baz.com',
140 severity => 'serious',
141 tags => ['a','b','c'], # may be an empty arrayref
144 The function should return 1 if the bug should be included; 0 if the
150 my %param = validate_with(params => \@_,
151 spec => {package => {type => SCALAR|ARRAYREF,
154 src => {type => SCALAR|ARRAYREF,
157 maint => {type => SCALAR|ARRAYREF,
160 submitter => {type => SCALAR|ARRAYREF,
163 severity => {type => SCALAR|ARRAYREF,
166 status => {type => SCALAR|ARRAYREF,
169 tag => {type => SCALAR|ARRAYREF,
172 owner => {type => SCALAR|ARRAYREF,
175 dist => {type => SCALAR|ARRAYREF,
178 function => {type => CODEREF,
181 bugs => {type => SCALAR|ARRAYREF,
184 archive => {type => BOOLEAN|SCALAR,
187 usertags => {type => HASHREF,
194 my %options = %param;
196 if ($options{archive} eq 'both') {
197 push @bugs, get_bugs(%options,archive=>0);
198 push @bugs, get_bugs(%options,archive=>1);
200 @bugs{@bugs} = @bugs;
203 # A configuration option will set an array that we'll use here instead.
204 for my $routine (qw(Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) {
205 my ($package) = $routine =~ m/^(.+)\:\:/;
206 eval "use $package;";
208 # We output errors here because using an invalid function
209 # in the configuration file isn't something that should
211 warn "use $package failed with $@";
214 @bugs = eval "${routine}(\%options)";
217 # We don't output errors here, because failure here
218 # via die may be a perfectly normal thing.
219 print STDERR "$@" if $DEBUG;
224 # If no one succeeded, die
233 count_bugs(function => sub {...})
235 Uses a subroutine to classify bugs into categories and return the
236 number of bugs which fall into those categories
241 my %param = validate_with(params => \@_,
242 spec => {function => {type => CODEREF,
244 archive => {type => BOOLEAN,
250 if ($param{archive}) {
251 $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
252 or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
255 $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
256 or die "Unable to open $config{spool_dir}/index.db for reading: $!";
260 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
261 my @x = $param{function}->(pkg => $1,
269 $count{$_}++ foreach @x;
278 my $bug = newest_bug();
280 Returns the bug number of the newest bug, which is nextnumber-1.
285 my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r')
286 or die "Unable to open $config{spool_dir}nextnumber for reading: $!";
288 my $next_number = <$nn_fh>;
291 return $next_number+0;
295 =head2 get_bugs_by_idx
297 This routine uses the by-$index.idx indicies to try to speed up
304 my %param = validate_with(params => \@_,
305 spec => {package => {type => SCALAR|ARRAYREF,
308 submitter => {type => SCALAR|ARRAYREF,
311 severity => {type => SCALAR|ARRAYREF,
314 tag => {type => SCALAR|ARRAYREF,
317 archive => {type => BOOLEAN,
320 owner => {type => SCALAR|ARRAYREF,
323 src => {type => SCALAR|ARRAYREF,
326 maint => {type => SCALAR|ARRAYREF,
329 bugs => {type => SCALAR|ARRAYREF,
332 usertags => {type => HASHREF,
339 # We handle src packages, maint and maintenc by mapping to the
340 # appropriate binary packages, then removing all packages which
341 # don't match all queries
342 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
343 qw(package src maint)
346 if (exists $param{tag} and exists $param{usertags}) {
347 # This complex slice makes a hash with the bugs which have the
348 # usertags passed in $param{tag} set.
349 @usertag_bugs{make_list(@{$param{usertags}}{make_list($param{tag})})
350 } = (1) x make_list(@{$param{usertags}}{make_list($param{tag})});
352 if (exists $param{package} or
353 exists $param{src} or
354 exists $param{maint}) {
355 delete @param{qw(maint src)};
356 $param{package} = [@packages];
358 my $keys = keys(%param) - 1;
359 die "Need at least 1 key to search by" unless $keys;
360 my $arc = $param{archive} ? '-arc':'';
362 for my $key (grep {$_ !~ /^(archive|usertags|bugs)$/} keys %param) {
364 $index = 'submitter-email' if $key eq 'submitter';
365 $index = "$config{spool_dir}/by-${index}${arc}.idx";
366 tie(%idx, MLDBM => $index, O_RDONLY)
367 or die "Unable to open $index: $!";
368 my %bug_matching = ();
369 for my $search (make_list($param{$key})) {
370 next unless defined $idx{$search};
371 for my $bug (keys %{$idx{$search}}) {
372 next if $bug_matching{$bug};
373 # increment the number of searches that this bug matched
375 $bug_matching{$bug}=1;
378 if ($key eq 'tag' and exists $param{usertags}) {
379 for my $bug (make_list(grep {defined $_ } @{$param{usertags}}{make_list($param{tag})})) {
380 next if $bug_matching{$bug};
382 $bug_matching{$bug}=1;
385 untie %idx or die 'Unable to untie %idx';
389 for my $bug (make_list($param{bugs})) {
393 # Throw out results that do not match all of the search specifications
394 return map {$keys <= $bugs{$_}?($_):()} keys %bugs;
398 =head2 get_bugs_flatfile
400 This is the fallback search routine. It should be able to complete all
401 searches. [Or at least, that's the idea.]
405 sub get_bugs_flatfile{
406 my %param = validate_with(params => \@_,
407 spec => {package => {type => SCALAR|ARRAYREF,
410 src => {type => SCALAR|ARRAYREF,
413 maint => {type => SCALAR|ARRAYREF,
416 submitter => {type => SCALAR|ARRAYREF,
419 severity => {type => SCALAR|ARRAYREF,
422 status => {type => SCALAR|ARRAYREF,
425 tag => {type => SCALAR|ARRAYREF,
429 # owner => {type => SCALAR|ARRAYREF,
432 # dist => {type => SCALAR|ARRAYREF,
435 archive => {type => BOOLEAN,
438 usertags => {type => HASHREF,
441 function => {type => CODEREF,
447 if ($param{archive}) {
448 $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
449 or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
452 $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
453 or die "Unable to open $config{spool_dir}/index.db for reading: $!";
456 if (exists $param{tag} and exists $param{usertags}) {
457 # This complex slice makes a hash with the bugs which have the
458 # usertags passed in $param{tag} set.
459 @usertag_bugs{make_list(@{$param{usertags}}{make_list($param{tag})})
460 } = (1) x make_list(@{$param{usertags}}{make_list($param{tag})});
462 # We handle src packages, maint and maintenc by mapping to the
463 # appropriate binary packages, then removing all packages which
464 # don't match all queries
465 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
466 qw(package src maint)
468 if (exists $param{package} or
469 exists $param{src} or
470 exists $param{maint}) {
471 delete @param{qw(maint src)};
472 $param{package} = [@packages];
475 while (<$flatfile>) {
476 next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/;
477 my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7);
478 next if exists $param{bugs} and not grep {$bug == $_} make_list($param{bugs});
479 if (exists $param{package}) {
480 my @packages = splitpackages($pkg);
481 next unless grep { my $pkg_list = $_;
482 grep {$pkg_list eq $_} make_list($param{package})
485 if (exists $param{src}) {
486 my @src_packages = map { getsrcpkgs($_)} make_list($param{src});
487 my @packages = splitpackages($pkg);
488 next unless grep { my $pkg_list = $_;
489 grep {$pkg_list eq $_} @packages
492 if (exists $param{submitter}) {
493 my @p_addrs = map {lc($_->address)}
494 map {getparsedaddrs($_)}
495 make_list($param{submitter});
496 my @f_addrs = map {$_->address}
497 getparsedaddrs($submitter||'');
498 next unless grep { my $f_addr = $_;
499 grep {$f_addr eq $_} @p_addrs
502 next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity});
503 next if exists $param{status} and not grep {$status eq $_} make_list($param{status});
504 if (exists $param{tag}) {
506 # either a normal tag, or a usertag must be set
507 $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug};
508 my @bug_tags = split ' ', $tags;
509 $bug_ok = 1 if grep {my $bug_tag = $_;
510 grep {$bug_tag eq $_} make_list($param{tag});
514 # We do this last, because a function may be slow...
515 if (exists $param{function}) {
516 my @bug_tags = split ' ', $tags;
517 my @packages = splitpackages($pkg);
518 my $package = (@packages > 1)?\@packages:$packages[0];
520 $param{function}->(pkg => $package,
523 submitter => $submitter,
524 severity => $severity,
533 sub __handle_pkg_src_and_maint{
534 my %param = validate_with(params => \@_,
535 spec => {package => {type => SCALAR|ARRAYREF,
538 src => {type => SCALAR|ARRAYREF,
541 maint => {type => SCALAR|ARRAYREF,
549 @packages = make_list($param{package}) if exists $param{package};
550 my $package_keys = @packages?1:0;
552 @packages{@packages} = (1) x @packages;
553 if (exists $param{src}) {
554 # We only want to increment the number of keys if there is
557 for my $package ((map { getsrcpkgs($_)} make_list($param{src})),make_list($param{src})) {
558 $packages{$package}++;
561 $package_keys += $key_inc;
563 if (exists $param{maint}) {
565 my $maint_rev = getmaintainers_reverse();
566 for my $package (map { exists $maint_rev->{$_}?@{$maint_rev->{$_}}:()}
567 make_list($param{maint})) {
568 $packages{$package}++;
571 $package_keys += $key_inc;
573 return grep {$packages{$_} >= $package_keys} keys %packages;