X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FBugs.pm;fp=Debbugs%2FBugs.pm;h=0000000000000000000000000000000000000000;hb=1e6633a3780f4fd53fc4303852e84d13cdad2dc6;hp=127e4727248b11457a021c987cb74b83377e6a2e;hpb=466f7faff129a5699c7674f59900a92aa256175d;p=debbugs.git diff --git a/Debbugs/Bugs.pm b/Debbugs/Bugs.pm deleted file mode 100644 index 127e472..0000000 --- a/Debbugs/Bugs.pm +++ /dev/null @@ -1,959 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later -# version at your option. -# See the file README and COPYING for more information. -# -# Copyright 2007 by Don Armstrong . - -package Debbugs::Bugs; - -=head1 NAME - -Debbugs::Bugs -- Bug selection routines for debbugs - -=head1 SYNOPSIS - -use Debbugs::Bugs qw(get_bugs); - - -=head1 DESCRIPTION - -This module is a replacement for all of the various methods of -selecting different types of bugs. - -It implements a single function, get_bugs, which defines the master -interface for selecting bugs. - -It attempts to use subsidiary functions to actually do the selection, -in the order specified in the configuration files. [Unless you're -insane, they should be in order from fastest (and often most -incomplete) to slowest (and most complete).] - -=head1 BUGS - -=head1 FUNCTIONS - -=cut - -use warnings; -use strict; -use feature 'state'; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -BEGIN{ - $VERSION = 1.00; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (); - @EXPORT_OK = (qw(get_bugs count_bugs newest_bug bug_filter)); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -use Debbugs::Config qw(:config); -use Params::Validate qw(validate_with :types); -use IO::File; -use Debbugs::Status qw(splitpackages get_bug_status); -use Debbugs::Packages qw(getsrcpkgs getpkgsrc); -use Debbugs::Common qw(getparsedaddrs package_maintainer getmaintainers make_list hash_slice); -use Fcntl qw(O_RDONLY); -use MLDBM qw(DB_File Storable); -use List::AllUtils qw(first max); -use Carp; - -=head2 get_bugs - - get_bugs() - -=head3 Parameters - -The following parameters can either be a single scalar or a reference -to an array. The parameters are ANDed together, and the elements of -arrayrefs are a parameter are ORed. Future versions of this may allow -for limited regular expressions, and/or more complex expressions. - -=over - -=item package -- name of the binary package - -=item src -- name of the source package - -=item maint -- address of the maintainer - -=item submitter -- address of the submitter - -=item severity -- severity of the bug - -=item status -- status of the bug - -=item tag -- bug tags - -=item owner -- owner of the bug - -=item correspondent -- address of someone who sent mail to the log - -=item affects -- bugs which affect this package - -=item dist -- distribution (I don't know about this one yet) - -=item bugs -- list of bugs to search within - -=item function -- see description below - -=back - -=head3 Special options - -The following options are special options used to modulate how the -searches are performed. - -=over - -=item archive -- whether to search archived bugs or normal bugs; -defaults to false. As a special case, if archive is 'both', but -archived and unarchived bugs are returned. - -=item usertags -- set of usertags and the bugs they are applied to - -=back - - -=head3 Subsidiary routines - -All subsidiary routines get passed exactly the same set of options as -get_bugs. If for some reason they are unable to handle the options -passed (for example, they don't have the right type of index for the -type of selection) they should die as early as possible. [Using -Params::Validate and/or die when files don't exist makes this fairly -trivial.] - -This function will then immediately move on to the next subroutine, -giving it the same arguments. - -=head3 function - -This option allows you to provide an arbitrary function which will be -given the information in the index.db file. This will be super, super -slow, so only do this if there's no other way to write the search. - -You'll be given a list (which you can turn into a hash) like the -following: - - (pkg => ['a','b'], # may be a scalar (most common) - bug => 1234, - status => 'pending', - submitter => 'boo@baz.com', - severity => 'serious', - tags => ['a','b','c'], # may be an empty arrayref - ) - -The function should return 1 if the bug should be included; 0 if the -bug should not. - -=cut - -state $_non_search_key_regex = qr/^(bugs|archive|usertags|schema)$/; - -my %_get_bugs_common_options = - (package => {type => SCALAR|ARRAYREF, - optional => 1, - }, - src => {type => SCALAR|ARRAYREF, - optional => 1, - }, - maint => {type => SCALAR|ARRAYREF, - optional => 1, - }, - submitter => {type => SCALAR|ARRAYREF, - optional => 1, - }, - severity => {type => SCALAR|ARRAYREF, - optional => 1, - }, - status => {type => SCALAR|ARRAYREF, - optional => 1, - }, - tag => {type => SCALAR|ARRAYREF, - optional => 1, - }, - owner => {type => SCALAR|ARRAYREF, - optional => 1, - }, - dist => {type => SCALAR|ARRAYREF, - optional => 1, - }, - correspondent => {type => SCALAR|ARRAYREF, - optional => 1, - }, - affects => {type => SCALAR|ARRAYREF, - optional => 1, - }, - function => {type => CODEREF, - optional => 1, - }, - bugs => {type => SCALAR|ARRAYREF, - optional => 1, - }, - archive => {type => BOOLEAN|SCALAR, - default => 0, - }, - usertags => {type => HASHREF, - optional => 1, - }, - newest => {type => SCALAR|ARRAYREF, - optional => 1, - }, - schema => {type => OBJECT, - optional => 1, - }, - ); - - -state $_get_bugs_options = {%_get_bugs_common_options}; -sub get_bugs{ - my %param = validate_with(params => \@_, - spec => $_get_bugs_options, - ); - - # Normalize options - my %options = %param; - my @bugs; - if ($options{archive} eq 'both') { - push @bugs, get_bugs(%options,archive=>0); - push @bugs, get_bugs(%options,archive=>1); - my %bugs; - @bugs{@bugs} = @bugs; - return keys %bugs; - } - # A configuration option will set an array that we'll use here instead. - for my $routine (qw(Debbugs::Bugs::get_bugs_by_db Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) { - my ($package) = $routine =~ m/^(.+)\:\:/; - eval "use $package;"; - if ($@) { - # We output errors here because using an invalid function - # in the configuration file isn't something that should - # be done. - warn "use $package failed with $@"; - next; - } - @bugs = eval "${routine}(\%options)"; - if ($@) { - - # We don't output errors here, because failure here - # via die may be a perfectly normal thing. - print STDERR "$@" if $DEBUG; - next; - } - last; - } - # If no one succeeded, die - if ($@) { - die "$@"; - } - return @bugs; -} - -=head2 count_bugs - - count_bugs(function => sub {...}) - -Uses a subroutine to classify bugs into categories and return the -number of bugs which fall into those categories - -=cut - -sub count_bugs { - my %param = validate_with(params => \@_, - spec => {function => {type => CODEREF, - }, - archive => {type => BOOLEAN, - default => 0, - }, - }, - ); - my $flatfile; - if ($param{archive}) { - $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r') - or die "Unable to open $config{spool_dir}/index.archive for reading: $!"; - } - else { - $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r') - or die "Unable to open $config{spool_dir}/index.db for reading: $!"; - } - my %count = (); - while(<$flatfile>) { - if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) { - my @x = $param{function}->(pkg => $1, - bug => $2, - status => $4, - submitter => $5, - severity => $6, - tags => $7, - ); - local $_; - $count{$_}++ foreach @x; - } - } - close $flatfile; - return %count; -} - -=head2 newest_bug - - my $bug = newest_bug(); - -Returns the bug number of the newest bug, which is nextnumber-1. - -=cut - -sub newest_bug { - my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r') - or die "Unable to open $config{spool_dir}nextnumber for reading: $!"; - local $/; - my $next_number = <$nn_fh>; - close $nn_fh; - chomp $next_number; - return $next_number-1; -} - -=head2 bug_filter - - bug_filter - -Allows filtering bugs on commonly used criteria - - - -=cut - -sub bug_filter { - my %param = validate_with(params => \@_, - spec => {bug => {type => ARRAYREF|SCALAR, - optional => 1, - }, - status => {type => HASHREF|ARRAYREF, - optional => 1, - }, - seen_merged => {type => HASHREF, - optional => 1, - }, - repeat_merged => {type => BOOLEAN, - default => 1, - }, - include => {type => HASHREF, - optional => 1, - }, - exclude => {type => HASHREF, - optional => 1, - }, - min_days => {type => SCALAR, - optional => 1, - }, - max_days => {type => SCALAR, - optional => 1, - }, - }, - ); - if (exists $param{repeat_merged} and - not $param{repeat_merged} and - not defined $param{seen_merged}) { - croak "repeat_merged false requires seen_merged to be passed"; - } - if (not exists $param{bug} and not exists $param{status}) { - croak "one of bug or status must be passed"; - } - - if (not exists $param{status}) { - my $location = getbuglocation($param{bug}, 'summary'); - return 0 if not defined $location or not length $location; - $param{status} = readbug( $param{bug}, $location ); - return 0 if not defined $param{status}; - } - - if (exists $param{include}) { - return 1 if (!__bug_matches($param{include}, $param{status})); - } - if (exists $param{exclude}) { - return 1 if (__bug_matches($param{exclude}, $param{status})); - } - if (exists $param{repeat_merged} and not $param{repeat_merged}) { - my @merged = sort {$a<=>$b} $param{bug}, split(/ /, $param{status}{mergedwith}); - return 1 if first {defined $_} @{$param{seen_merged}}{@merged}; - @{$param{seen_merged}}{@merged} = (1) x @merged; - } - my $daysold = int((time - $param{status}{date}) / 86400); # seconds to days - if (exists $param{min_days}) { - return 1 unless $param{min_days} <= $daysold; - } - if (exists $param{max_days}) { - return 1 unless $param{max_days} == -1 or - $param{max_days} >= $daysold; - } - return 0; -} - - -=head2 get_bugs_by_idx - -This routine uses the by-$index.idx indicies to try to speed up -searches. - - -=cut - - -state $_get_bugs_by_idx_options = - {hash_slice(%_get_bugs_common_options, - (qw(package submitter severity tag archive), - qw(owner src maint bugs correspondent), - qw(affects usertags newest)) - ) - }; -sub get_bugs_by_idx{ - my %param = validate_with(params => \@_, - spec => $_get_bugs_by_idx_options - ); - my %bugs = (); - - # If we're given an empty maint (unmaintained packages), we can't - # handle it, so bail out here - for my $maint (make_list(exists $param{maint}?$param{maint}:[])) { - if (defined $maint and $maint eq '') { - die "Can't handle empty maint (unmaintained packages) in get_bugs_by_idx"; - } - } - if ($param{newest}) { - my $newest_bug = newest_bug(); - my @bugs = ($newest_bug - max(make_list($param{newest})) + 1) .. $newest_bug; - $param{bugs} = [exists $param{bugs}?make_list($param{bugs}):(), - @bugs, - ]; - } - # We handle src packages, maint and maintenc by mapping to the - # appropriate binary packages, then removing all packages which - # don't match all queries - my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()} - qw(package src maint) - ); - if (exists $param{package} or - exists $param{src} or - exists $param{maint}) { - delete @param{qw(maint src)}; - $param{package} = [@packages]; - } - my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param); - die "Need at least 1 key to search by" unless $keys; - my $arc = $param{archive} ? '-arc':''; - my %idx; - for my $key (grep {$_ !~ $_non_search_key_regex} keys %param) { - my $index = $key; - $index = 'submitter-email' if $key eq 'submitter'; - $index = "$config{spool_dir}/by-${index}${arc}.idx"; - tie(%idx, MLDBM => $index, O_RDONLY) - or die "Unable to open $index: $!"; - my %bug_matching = (); - for my $search (make_list($param{$key})) { - for my $bug (keys %{$idx{$search}||{}}) { - next if $bug_matching{$bug}; - # increment the number of searches that this bug matched - $bugs{$bug}++; - $bug_matching{$bug}=1; - } - if ($search ne lc($search)) { - for my $bug (keys %{$idx{lc($search)}||{}}) { - next if $bug_matching{$bug}; - # increment the number of searches that this bug matched - $bugs{$bug}++; - $bug_matching{$bug}=1; - } - } - } - if ($key eq 'tag' and exists $param{usertags}) { - for my $bug (make_list(grep {defined $_ } @{$param{usertags}}{make_list($param{tag})})) { - next if $bug_matching{$bug}; - $bugs{$bug}++; - $bug_matching{$bug}=1; - } - } - untie %idx or die 'Unable to untie %idx'; - } - if ($param{bugs}) { - $keys++; - for my $bug (make_list($param{bugs})) { - $bugs{$bug}++; - } - } - # Throw out results that do not match all of the search specifications - return map {$keys <= $bugs{$_}?($_):()} keys %bugs; -} - - -=head2 get_bugs_by_db - -This routine uses the database to try to speed up -searches. - - -=cut - -state $_get_bugs_by_db_options = - {hash_slice(%_get_bugs_common_options, - (qw(package submitter severity tag archive), - qw(owner src maint bugs correspondent), - qw(affects usertags newest)) - ), - schema => {type => OBJECT, - }, - }; -sub get_bugs_by_db{ - my %param = validate_with(params => \@_, - spec => $_get_bugs_by_db_options, - ); - my %bugs = (); - - my $s = $param{schema}; - my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param); - die "Need at least 1 key to search by" unless $keys; - my $rs = $s->resultset('Bug'); - if (exists $param{severity}) { - $rs = $rs->search({'severity.severity' => - [make_list($param{severity})], - }, - {join => 'severity'}, - ); - } - for my $key (qw(owner submitter done)) { - if (exists $param{$key}) { - $rs = $rs->search({"${key}.addr" => - [make_list($param{$key})], - }, - {join => $key}, - ); - } - } - if (exists $param{newest}) { - $rs = - $rs->search({}, - {order_by => {-desc => 'me.creation'}, - rows => max(make_list($param{newest})), - }, - ); - } - if (exists $param{correspondent}) { - my $message_rs = - $s->resultset('Message')-> - search({'correspondent.addr' => - [make_list($param{correspondent})], - }, - {join => {message_correspondents => 'correspondent'}, - columns => ['id'], - group_by => ['me.id'], - }, - ); - $rs = $rs->search({'bug_messages.message' => - {-in => $message_rs->get_column('id')->as_query()}, - }, - {join => 'bug_messages', - }, - ); - } - if (exists $param{affects}) { - my @aff_list = make_list($param{affects}); - s/^src:// foreach @aff_list; - $rs = $rs->search({-or => {'bin_pkg.pkg' => - [@aff_list], - 'src_pkg.pkg' => - [@aff_list], - 'me.unknown_affects' => - [@aff_list] - }, - }, - {join => [{bug_affects_binpackages => 'bin_pkg'}, - {bug_affects_srcpackages => 'src_pkg'}, - ], - }, - ); - } - if (exists $param{package}) { - $rs = $rs->search({-or => {'bin_pkg.pkg' => - [make_list($param{package})], - 'me.unknown_packages' => - [make_list($param{package})]}, - }, - {join => {bug_binpackages => 'bin_pkg'}}); - } - if (exists $param{maint}) { - my @maint_list = - map {$_ eq '' ? undef : $_} - make_list($param{maint}); - my $bin_pkgs_rs = - $s->resultset('BinPkg')-> - search({'correspondent.addr' => [@maint_list]}, - {join => {bin_vers => - {src_ver => - {maintainer => 'correspondent'}}}, - columns => ['id'], - group_by => ['me.id'], - }, - ); - my $src_pkgs_rs = - $s->resultset('SrcPkg')-> - search({'correspondent.addr' => [@maint_list]}, - {join => {src_vers => - {maintainer => 'correspondent'}}, - columns => ['id'], - group_by => ['me.id'], - }, - ); - $rs = $rs->search({-or => {'bug_binpackages.bin_pkg' => - { -in => $bin_pkgs_rs->get_column('id')->as_query}, - 'bug_srcpackages.src_pkg' => - { -in => $src_pkgs_rs->get_column('id')->as_query}, - }, - }, - {join => ['bug_binpackages', - 'bug_srcpackages', - ]} - ); - } - if (exists $param{src}) { - # identify all of the srcpackages and binpackages that match first - my $src_pkgs_rs = - $s->resultset('SrcPkg')-> - search({'pkg' => [make_list($param{src})], - }, - { columns => ['id'], - group_by => ['me.id'], - }, - ); - my $bin_pkgs_rs = - $s->resultset('BinPkgSrcPkg')-> - search({'src_pkg.pkg' => [make_list($param{src})], - }, - {columns => ['bin_pkg'], - join => ['src_pkg'], - group_by => ['bin_pkg'], - }); - $rs = $rs->search({-or => {'bug_binpackages.bin_pkg' => - { -in => $bin_pkgs_rs->get_column('bin_pkg')->as_query}, - 'bug_srcpackages.src_pkg' => - { -in => $src_pkgs_rs->get_column('id')->as_query}, - 'me.unknown_packages' => - [make_list($param{src})], - }, - }, - {join => ['bug_binpackages', - 'bug_srcpackages', - ]} - ); - } - # tags are very odd, because we must handle usertags. - if (exists $param{tag}) { - # bugs from usertags which matter - my %bugs_matching_usertags; - for my $bug (make_list(grep {defined $_ } - @{$param{usertags}}{make_list($param{tag})})) { - $bugs_matching_usertags{$bug} = 1; - } - # we want all bugs which either match the tag name given in - # param, or have a usertag set which matches one of the tag - # names given in param. - $rs = $rs->search({-or => {map {('tag.tag' => $_)} - make_list($param{tag}), - map {('me.id' => $_)} - keys %bugs_matching_usertags - }, - }, - {join => {bug_tags => 'tag'}}); - } - if (exists $param{bugs}) { - $rs = $rs->search({-or => {map {('me.id' => $_)} - make_list($param{bugs})} - }); - } - # handle archive - if (defined $param{archive} and $param{archive} ne 'both') { - $rs = $rs->search({'me.archived' => $param{archive}}); - } - return $rs->get_column('id')->all(); -} - - -=head2 get_bugs_flatfile - -This is the fallback search routine. It should be able to complete all -searches. [Or at least, that's the idea.] - -=cut - -state $_get_bugs_flatfile_options = - {hash_slice(%_get_bugs_common_options, - map {$_ eq 'dist'?():($_)} keys %_get_bugs_common_options - ) - }; - -sub get_bugs_flatfile{ - my %param = validate_with(params => \@_, - spec => $_get_bugs_flatfile_options - ); - my $flatfile; - if ($param{newest}) { - my $newest_bug = newest_bug(); - my @bugs = ($newest_bug - max(make_list($param{newest})) + 1) .. $newest_bug; - $param{bugs} = [exists $param{bugs}?make_list($param{bugs}):(), - @bugs, - ]; - } - if ($param{archive}) { - $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r') - or die "Unable to open $config{spool_dir}/index.archive for reading: $!"; - } - else { - $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r') - or die "Unable to open $config{spool_dir}/index.db for reading: $!"; - } - my %usertag_bugs; - if (exists $param{tag} and exists $param{usertags}) { - # This complex slice makes a hash with the bugs which have the - # usertags passed in $param{tag} set. - @usertag_bugs{make_list(@{$param{usertags}}{make_list($param{tag})}) - } = (1) x make_list(@{$param{usertags}}{make_list($param{tag})}); - } - my $unmaintained_packages = 0; - # unmaintained packages is a special case - my @maints = make_list(exists $param{maint}?$param{maint}:[]); - $param{maint} = []; - for my $maint (@maints) { - if (defined $maint and $maint eq '' and not $unmaintained_packages) { - $unmaintained_packages = 1; - our %maintainers = %{getmaintainers()}; - $param{function} = [(exists $param{function}? - (ref $param{function}?@{$param{function}}:$param{function}):()), - sub {my %d=@_; - foreach my $try (make_list($d{"pkg"})) { - next unless length $try; - ($try) = $try =~ m/^(?:src:)?(.+)/; - return 1 if not exists $maintainers{$try}; - } - return 0; - } - ]; - } - elsif (defined $maint and $maint ne '') { - push @{$param{maint}},$maint; - } - } - # We handle src packages, maint and maintenc by mapping to the - # appropriate binary packages, then removing all packages which - # don't match all queries - my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()} - qw(package src maint) - ); - if (exists $param{package} or - exists $param{src} or - exists $param{maint}) { - delete @param{qw(maint src)}; - $param{package} = [@packages] if @packages; - } - my $grep_bugs = 0; - my %bugs; - if (exists $param{bugs}) { - $bugs{$_} = 1 for make_list($param{bugs}); - $grep_bugs = 1; - } - # These queries have to be handled by get_bugs_by_idx - if (exists $param{owner} - or exists $param{correspondent} - or exists $param{affects}) { - $bugs{$_} = 1 for get_bugs_by_idx(map {exists $param{$_}?($_,$param{$_}):()} - qw(owner correspondent affects), - ); - $grep_bugs = 1; - } - my @bugs; - BUG: while (<$flatfile>) { - next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*(.*)\s*\]\s+(\w+)\s+(.*)$/; - my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7); - next if $grep_bugs and not exists $bugs{$bug}; - if (exists $param{package}) { - my @packages = splitpackages($pkg); - next unless grep { my $pkg_list = $_; - grep {$pkg_list eq $_} make_list($param{package}) - } @packages; - } - if (exists $param{src}) { - my @src_packages = map { getsrcpkgs($_)} make_list($param{src}); - my @packages = splitpackages($pkg); - next unless grep { my $pkg_list = $_; - grep {$pkg_list eq $_} @packages - } @src_packages; - } - if (exists $param{submitter}) { - my @p_addrs = map {lc($_->address)} - map {getparsedaddrs($_)} - make_list($param{submitter}); - my @f_addrs = map {$_->address} - getparsedaddrs($submitter||''); - next unless grep { my $f_addr = $_; - grep {$f_addr eq $_} @p_addrs - } @f_addrs; - } - next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity}); - next if exists $param{status} and not grep {$status eq $_} make_list($param{status}); - if (exists $param{tag}) { - my $bug_ok = 0; - # either a normal tag, or a usertag must be set - $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug}; - my @bug_tags = split ' ', $tags; - $bug_ok = 1 if grep {my $bug_tag = $_; - grep {$bug_tag eq $_} make_list($param{tag}); - } @bug_tags; - next unless $bug_ok; - } - # We do this last, because a function may be slow... - if (exists $param{function}) { - my @bug_tags = split ' ', $tags; - my @packages = splitpackages($pkg); - my $package = (@packages > 1)?\@packages:$packages[0]; - for my $function (make_list($param{function})) { - next BUG unless - $function->(pkg => $package, - bug => $bug, - status => $status, - submitter => $submitter, - severity => $severity, - tags => \@bug_tags, - ); - } - } - push @bugs, $bug; - } - return @bugs; -} - -=head1 PRIVATE FUNCTIONS - -=head2 __handle_pkg_src_and_maint - - my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()} - qw(package src maint) - ); - -Turn package/src/maint into a list of packages - -=cut - -sub __handle_pkg_src_and_maint{ - my %param = validate_with(params => \@_, - spec => {package => {type => SCALAR|ARRAYREF, - optional => 1, - }, - src => {type => SCALAR|ARRAYREF, - optional => 1, - }, - maint => {type => SCALAR|ARRAYREF, - optional => 1, - }, - }, - allow_extra => 1, - ); - - my @packages; - @packages = make_list($param{package}) if exists $param{package}; - my $package_keys = @packages?1:0; - my %packages; - @packages{@packages} = (1) x @packages; - if (exists $param{src}) { - # We only want to increment the number of keys if there is - # something to match - my $key_inc = 0; - # in case there are binaries with the same name as the - # source - my %_temp_p = (); - for my $package ((map {getsrcpkgs($_)} make_list($param{src}))) { - $packages{$package}++ unless exists $_temp_p{$package}; - $_temp_p{$package} = 1; - $key_inc=1; - } - for my $package (make_list($param{src})) { - $packages{"src:$package"}++ unless exists $_temp_p{"src:$package"}; - $_temp_p{"src:$package"} = 1; - $key_inc=1; - # As a temporary hack, we will also include $param{src} - # in this list for packages passed which do not have a - # corresponding binary package - if (not exists getpkgsrc()->{$package}) { - $packages{$package}++ unless exists $_temp_p{$package}; - $_temp_p{$package} = 1; - } - } - $package_keys += $key_inc; - } - if (exists $param{maint}) { - my $key_inc = 0; - my %_temp_p = (); - for my $package (package_maintainer(maintainer=>$param{maint})) { - $packages{$package}++ unless exists $_temp_p{$package}; - $_temp_p{$package} = 1; - $key_inc = 1; - } - $package_keys += $key_inc; - } - return grep {$packages{$_} >= $package_keys} keys %packages; -} - -state $field_match = { - 'subject' => \&__contains_field_match, - 'tags' => sub { - my ($field, $values, $status) = @_; - my %values = map {$_=>1} @$values; - foreach my $t (split /\s+/, $status->{$field}) { - return 1 if (defined $values{$t}); - } - return 0; - }, - 'severity' => \&__exact_field_match, - 'pending' => \&__exact_field_match, - 'package' => \&__exact_field_match, - 'originator' => \&__contains_field_match, - 'forwarded' => \&__contains_field_match, - 'owner' => \&__contains_field_match, -}; - -sub __bug_matches { - my ($hash, $status) = @_; - foreach my $key( keys( %$hash ) ) { - my $value = $hash->{$key}; - next unless exists $field_match->{$key}; - my $sub = $field_match->{$key}; - if (not defined $sub) { - die "No defined subroutine for key: $key"; - } - return 1 if ($sub->($key, $value, $status)); - } - return 0; -} - -sub __exact_field_match { - my ($field, $values, $status) = @_; - my @values = @$values; - my @ret = grep {$_ eq $status->{$field} } @values; - $#ret != -1; -} - -sub __contains_field_match { - my ($field, $values, $status) = @_; - foreach my $data (@$values) { - return 1 if (index($status->{$field}, $data) > -1); - } - return 0; -} - - - - - -1; - -__END__