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;
109 =item usertags -- set of usertags and the bugs they are applied to
114 =head3 Subsidiary routines
116 All subsidiary routines get passed exactly the same set of options as
117 get_bugs. If for some reason they are unable to handle the options
118 passed (for example, they don't have the right type of index for the
119 type of selection) they should die as early as possible. [Using
120 Params::Validate and/or die when files don't exist makes this fairly
123 This function will then immediately move on to the next subroutine,
124 giving it the same arguments.
128 This option allows you to provide an arbitrary function which will be
129 given the information in the index.db file. This will be super, super
130 slow, so only do this if there's no other way to write the search.
132 You'll be given a list (which you can turn into a hash) like the
135 (pkg => ['a','b'], # may be a scalar (most common)
138 submitter => 'boo@baz.com',
139 severity => 'serious',
140 tags => ['a','b','c'], # may be an empty arrayref
143 The function should return 1 if the bug should be included; 0 if the
149 my %param = validate_with(params => \@_,
150 spec => {package => {type => SCALAR|ARRAYREF,
153 src => {type => SCALAR|ARRAYREF,
156 maint => {type => SCALAR|ARRAYREF,
159 submitter => {type => SCALAR|ARRAYREF,
162 severity => {type => SCALAR|ARRAYREF,
165 status => {type => SCALAR|ARRAYREF,
168 tag => {type => SCALAR|ARRAYREF,
171 owner => {type => SCALAR|ARRAYREF,
174 dist => {type => SCALAR|ARRAYREF,
177 function => {type => CODEREF,
180 bugs => {type => SCALAR|ARRAYREF,
183 archive => {type => BOOLEAN,
186 usertags => {type => HASHREF,
193 my %options = %param;
195 # A configuration option will set an array that we'll use here instead.
196 for my $routine (qw(Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) {
197 my ($package) = $routine =~ m/^(.+)\:\:/;
198 eval "use $package;";
200 # We output errors here because using an invalid function
201 # in the configuration file isn't something that should
203 warn "use $package failed with $@";
206 @bugs = eval "${routine}(\%options)";
209 # We don't output errors here, because failure here
210 # via die may be a perfectly normal thing.
211 print STDERR "$@" if $DEBUG;
216 # If no one succeeded, die
225 count_bugs(function => sub {...})
227 Uses a subroutine to classify bugs into categories and return the
228 number of bugs which fall into those categories
233 my %param = validate_with(params => \@_,
234 spec => {function => {type => CODEREF,
236 archive => {type => BOOLEAN,
242 if ($param{archive}) {
243 $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
244 or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
247 $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
248 or die "Unable to open $config{spool_dir}/index.db for reading: $!";
252 if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
253 my @x = $param{function}->(pkg => $1,
261 $count{$_}++ foreach @x;
270 my $bug = newest_bug();
272 Returns the bug number of the newest bug, which is nextnumber-1.
277 my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r')
278 or die "Unable to open $config{spool_dir}nextnumber for reading: $!";
280 my $next_number = <$nn_fh>;
283 return $next_number+0;
287 =head2 get_bugs_by_idx
289 This routine uses the by-$index.idx indicies to try to speed up
296 my %param = validate_with(params => \@_,
297 spec => {package => {type => SCALAR|ARRAYREF,
300 submitter => {type => SCALAR|ARRAYREF,
303 severity => {type => SCALAR|ARRAYREF,
306 tag => {type => SCALAR|ARRAYREF,
309 archive => {type => BOOLEAN,
312 owner => {type => SCALAR|ARRAYREF,
315 src => {type => SCALAR|ARRAYREF,
318 maint => {type => SCALAR|ARRAYREF,
325 # We handle src packages, maint and maintenc by mapping to the
326 # appropriate binary packages, then removing all packages which
327 # don't match all queries
328 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
329 qw(package src maint)
331 if (exists $param{package} or
332 exists $param{src} or
333 exists $param{maint}) {
334 delete @param{qw(maint src)};
335 $param{package} = [@packages];
337 my $keys = keys(%param) - 1;
338 die "Need at least 1 key to search by" unless $keys;
339 my $arc = $param{archive} ? '-arc':'';
341 for my $key (grep {$_ ne 'archive'} keys %param) {
343 $index = 'submitter-email' if $key eq 'submitter';
344 $index = "$config{spool_dir}/by-${index}${arc}.idx";
345 tie(%idx, MLDBM => $index, O_RDONLY)
346 or die "Unable to open $index: $!";
347 for my $search (make_list($param{$key})) {
348 next unless defined $idx{$search};
349 for my $bug (keys %{$idx{$search}}) {
350 # increment the number of searches that this bug matched
354 untie %idx or die 'Unable to untie %idx';
356 # Throw out results that do not match all of the search specifications
357 return map {$keys <= $bugs{$_}?($_):()} keys %bugs;
361 =head2 get_bugs_flatfile
363 This is the fallback search routine. It should be able to complete all
364 searches. [Or at least, that's the idea.]
368 sub get_bugs_flatfile{
369 my %param = validate_with(params => \@_,
370 spec => {package => {type => SCALAR|ARRAYREF,
373 src => {type => SCALAR|ARRAYREF,
376 maint => {type => SCALAR|ARRAYREF,
379 submitter => {type => SCALAR|ARRAYREF,
382 severity => {type => SCALAR|ARRAYREF,
385 status => {type => SCALAR|ARRAYREF,
388 tag => {type => SCALAR|ARRAYREF,
392 # owner => {type => SCALAR|ARRAYREF,
395 # dist => {type => SCALAR|ARRAYREF,
398 archive => {type => BOOLEAN,
401 usertags => {type => HASHREF,
404 function => {type => CODEREF,
410 if ($param{archive}) {
411 $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
412 or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
415 $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
416 or die "Unable to open $config{spool_dir}/index.db for reading: $!";
419 if (exists $param{tag} and exists $param{usertags}) {
421 # This complex slice makes a hash with the bugs which have the
422 # usertags passed in $param{tag} set.
423 @usertag_bugs{map {@{$_}}
424 @{$param{usertags}}{make_list($param{tag})}
425 } = (1) x @{$param{usertags}}{make_list($param{tag})}
427 # We handle src packages, maint and maintenc by mapping to the
428 # appropriate binary packages, then removing all packages which
429 # don't match all queries
430 my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
431 qw(package src maint)
433 if (exists $param{package} or
434 exists $param{src} or
435 exists $param{maint}) {
436 delete @param{qw(maint src)};
437 $param{package} = [@packages];
440 while (<$flatfile>) {
441 next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/;
442 my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7);
443 next if exists $param{bugs} and not grep {$bug == $_} make_list($param{bugs});
444 if (exists $param{package}) {
445 my @packages = splitpackages($pkg);
446 next unless grep { my $pkg_list = $_;
447 grep {$pkg_list eq $_} make_list($param{package})
450 if (exists $param{src}) {
451 my @src_packages = map { getsrcpkgs($_)} make_list($param{src});
452 my @packages = splitpackages($pkg);
453 next unless grep { my $pkg_list = $_;
454 grep {$pkg_list eq $_} @packages
457 if (exists $param{submitter}) {
458 my @p_addrs = map {lc($_->address)}
459 map {getparsedaddrs($_)}
460 make_list($param{submitter});
461 my @f_addrs = map {$_->address}
462 getparsedaddrs($submitter||'');
463 next unless grep { my $f_addr = $_;
464 grep {$f_addr eq $_} @p_addrs
467 next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity});
468 next if exists $param{status} and not grep {$status eq $_} make_list($param{status});
469 if (exists $param{tag}) {
471 # either a normal tag, or a usertag must be set
472 $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug};
473 my @bug_tags = split ' ', $tags;
474 $bug_ok = 1 if grep {my $bug_tag = $_;
475 grep {$bug_tag eq $_} make_list($param{tag});
479 # We do this last, because a function may be slow...
480 if (exists $param{function}) {
481 my @bug_tags = split ' ', $tags;
482 my @packages = splitpackages($pkg);
483 my $package = (@packages > 1)?\@packages:$packages[0];
485 $param{function}->(pkg => $package,
488 submitter => $submitter,
489 severity => $severity,
498 sub __handle_pkg_src_and_maint{
499 my %param = validate_with(params => \@_,
500 spec => {package => {type => SCALAR|ARRAYREF,
503 src => {type => SCALAR|ARRAYREF,
506 maint => {type => SCALAR|ARRAYREF,
514 @packages = make_list($param{package}) if exists $param{package};
515 my $package_keys = @packages?1:0;
517 @packages{@packages} = (1) x @packages;
518 if (exists $param{src}) {
519 # We only want to increment the number of keys if there is
522 for my $package ((map { getsrcpkgs($_)} make_list($param{src})),make_list($param{src})) {
523 $packages{$package}++;
526 $package_keys += $key_inc;
528 if (exists $param{maint}) {
530 my $maint_rev = getmaintainers_reverse();
531 for my $package (map { exists $maint_rev->{$_}?@{$maint_rev->{$_}}:()}
532 make_list($param{maint})) {
533 $packages{$package}++;
536 $package_keys += $key_inc;
538 return grep {$packages{$_} >= $package_keys} keys %packages;