Debbugs/Bugs.pm

   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.
   5 #
   6 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
   7
   8 package Debbugs::Bugs;
   9
  10 =head1 NAME
  11
  12 Debbugs::Bugs -- Bug selection routines for debbugs
  13
  14 =head1 SYNOPSIS
  15
  16 use Debbugs::Bugs qw(get_bugs);
  17
  18
  19 =head1 DESCRIPTION
  20
  21 This module is a replacement for all of the various methods of
  22 selecting different types of bugs.
  23
  24 It implements a single function, get_bugs, which defines the master
  25 interface for selecting bugs.
  26
  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).]
  31
  32 =head1 BUGS
  33
  34 =head1 FUNCTIONS
  35
  36 =cut
  37
  38 use warnings;
  39 use strict;
  40 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  41 use base qw(Exporter);
  42
  43 BEGIN{
  44      $VERSION = 1.00;
  45      $DEBUG = 0 unless defined $DEBUG;
  46
  47      @EXPORT = ();
  48      %EXPORT_TAGS = ();
  49      @EXPORT_OK = (qw(get_bugs count_bugs newest_bug bug_filter));
  50      $EXPORT_TAGS{all} = [@EXPORT_OK];
  51 }
  52
  53 use Debbugs::Config qw(:config);
  54 use Params::Validate qw(validate_with :types);
  55 use IO::File;
  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);
  62 use Carp;
  63
  64 =head2 get_bugs
  65
  66      get_bugs()
  67
  68 =head3 Parameters
  69
  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.
  74
  75 =over
  76
  77 =item package -- name of the binary package
  78
  79 =item src -- name of the source package
  80
  81 =item maint -- address of the maintainer
  82
  83 =item submitter -- address of the submitter
  84
  85 =item severity -- severity of the bug
  86
  87 =item status -- status of the bug
  88
  89 =item tag -- bug tags
  90
  91 =item owner -- owner of the bug
  92
  93 =item correspondent -- address of someone who sent mail to the log
  94
  95 =item affects -- bugs which affect this package
  96
  97 =item dist -- distribution (I don't know about this one yet)
  98
  99 =item bugs -- list of bugs to search within
 100
 101 =item function -- see description below
 102
 103 =back
 104
 105 =head3 Special options
 106
 107 The following options are special options used to modulate how the
 108 searches are performed.
 109
 110 =over
 111
 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.
 115
 116 =item usertags -- set of usertags and the bugs they are applied to
 117
 118 =back
 119
 120
 121 =head3 Subsidiary routines
 122
 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
 128 trivial.]
 129
 130 This function will then immediately move on to the next subroutine,
 131 giving it the same arguments.
 132
 133 =head3 function
 134
 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.
 138
 139 You'll be given a list (which you can turn into a hash) like the
 140 following:
 141
 142  (pkg => ['a','b'], # may be a scalar (most common)
 143   bug => 1234,
 144   status => 'pending',
 145   submitter => 'boo@baz.com',
 146   severity => 'serious',
 147   tags => ['a','b','c'], # may be an empty arrayref
 148  )
 149
 150 The function should return 1 if the bug should be included; 0 if the
 151 bug should not.
 152
 153 =cut
 154
 155 my $_non_search_key_regex = qr/^(bugs|archive|usertags|schema)$/;
 156
 157 my %_get_bugs_common_options =
 158     (package   => {type => SCALAR|ARRAYREF,
 159                    optional => 1,
 160                   },
 161      src       => {type => SCALAR|ARRAYREF,
 162                    optional => 1,
 163                   },
 164      maint     => {type => SCALAR|ARRAYREF,
 165                    optional => 1,
 166                   },
 167      submitter => {type => SCALAR|ARRAYREF,
 168                    optional => 1,
 169                   },
 170      severity  => {type => SCALAR|ARRAYREF,
 171                    optional => 1,
 172                   },
 173      status    => {type => SCALAR|ARRAYREF,
 174                    optional => 1,
 175                   },
 176      tag       => {type => SCALAR|ARRAYREF,
 177                    optional => 1,
 178                   },
 179      owner     => {type => SCALAR|ARRAYREF,
 180                    optional => 1,
 181                   },
 182      dist      => {type => SCALAR|ARRAYREF,
 183                    optional => 1,
 184                   },
 185      correspondent => {type => SCALAR|ARRAYREF,
 186                        optional => 1,
 187                       },
 188      affects   => {type => SCALAR|ARRAYREF,
 189                    optional => 1,
 190                   },
 191      function  => {type => CODEREF,
 192                    optional => 1,
 193                   },
 194      bugs      => {type => SCALAR|ARRAYREF,
 195                    optional => 1,
 196                   },
 197      archive   => {type => BOOLEAN|SCALAR,
 198                    default => 0,
 199                   },
 200      usertags  => {type => HASHREF,
 201                    optional => 1,
 202                   },
 203      schema => {type     => OBJECT,
 204                 optional => 1,
 205                },
 206     );
 207
 208
 209 my $_get_bugs_options = {%_get_bugs_common_options};
 210 sub get_bugs{
 211      my %param = validate_with(params => \@_,
 212                                spec   => $_get_bugs_options,
 213                               );
 214
 215      # Normalize options
 216      my %options = %param;
 217      my @bugs;
 218      if ($options{archive} eq 'both') {
 219           push @bugs, get_bugs(%options,archive=>0);
 220           push @bugs, get_bugs(%options,archive=>1);
 221           my %bugs;
 222           @bugs{@bugs} = @bugs;
 223           return keys %bugs;
 224      }
 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;";
 229           if ($@) {
 230                # We output errors here because using an invalid function
 231                # in the configuration file isn't something that should
 232                # be done.
 233                warn "use $package failed with $@";
 234                next;
 235           }
 236           @bugs = eval "${routine}(\%options)";
 237           if ($@) {
 238
 239                # We don't output errors here, because failure here
 240                # via die may be a perfectly normal thing.
 241                print STDERR "$@" if $DEBUG;
 242                next;
 243           }
 244           last;
 245      }
 246      # If no one succeeded, die
 247      if ($@) {
 248           die "$@";
 249      }
 250      return @bugs;
 251 }
 252
 253 =head2 count_bugs
 254
 255      count_bugs(function => sub {...})
 256
 257 Uses a subroutine to classify bugs into categories and return the
 258 number of bugs which fall into those categories
 259
 260 =cut
 261
 262 sub count_bugs {
 263      my %param = validate_with(params => \@_,
 264                                spec   => {function => {type => CODEREF,
 265                                                       },
 266                                           archive  => {type => BOOLEAN,
 267                                                        default => 0,
 268                                                       },
 269                                          },
 270                               );
 271      my $flatfile;
 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: $!";
 275      }
 276      else {
 277           $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
 278                or die "Unable to open $config{spool_dir}/index.db for reading: $!";
 279      }
 280      my %count = ();
 281      while(<$flatfile>) {
 282           if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
 283                my @x = $param{function}->(pkg       => $1,
 284                                           bug       => $2,
 285                                           status    => $4,
 286                                           submitter => $5,
 287                                           severity  => $6,
 288                                           tags      => $7,
 289                                          );
 290                local $_;
 291                $count{$_}++ foreach @x;
 292           }
 293      }
 294      close $flatfile;
 295      return %count;
 296 }
 297
 298 =head2 newest_bug
 299
 300      my $bug = newest_bug();
 301
 302 Returns the bug number of the newest bug, which is nextnumber-1.
 303
 304 =cut
 305
 306 sub newest_bug {
 307      my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r')
 308           or die "Unable to open $config{spool_dir}nextnumber for reading: $!";
 309      local $/;
 310      my $next_number = <$nn_fh>;
 311      close $nn_fh;
 312      chomp $next_number;
 313      return $next_number-1;
 314 }
 315
 316 =head2 bug_filter
 317
 318      bug_filter
 319
 320 Allows filtering bugs on commonly used criteria
 321
 322
 323
 324 =cut
 325
 326 sub bug_filter {
 327      my %param = validate_with(params => \@_,
 328                                spec   => {bug    => {type => ARRAYREF|SCALAR,
 329                                                      optional => 1,
 330                                                     },
 331                                           status => {type => HASHREF|ARRAYREF,
 332                                                      optional => 1,
 333                                                     },
 334                                           seen_merged => {type => HASHREF,
 335                                                           optional => 1,
 336                                                          },
 337                                           repeat_merged => {type => BOOLEAN,
 338                                                             default => 1,
 339                                                            },
 340                                           include => {type => HASHREF,
 341                                                       optional => 1,
 342                                                      },
 343                                           exclude => {type => HASHREF,
 344                                                       optional => 1,
 345                                                      },
 346                                           min_days => {type => SCALAR,
 347                                                        optional => 1,
 348                                                       },
 349                                           max_days => {type => SCALAR,
 350                                                        optional => 1,
 351                                                       },
 352                                          },
 353                               );
 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";
 358      }
 359      if (not exists $param{bug} and not exists $param{status}) {
 360          croak "one of bug or status must be passed";
 361      }
 362
 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};
 368      }
 369
 370      if (exists $param{include}) {
 371           return 1 if (!__bug_matches($param{include}, $param{status}));
 372      }
 373      if (exists $param{exclude}) {
 374           return 1 if (__bug_matches($param{exclude}, $param{status}));
 375      }
 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;
 380      }
 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;
 384      }
 385      if (exists $param{max_days}) {
 386           return 1 unless $param{max_days} == -1 or
 387                $param{max_days} >= $daysold;
 388      }
 389      return 0;
 390 }
 391
 392
 393 =head2 get_bugs_by_idx
 394
 395 This routine uses the by-$index.idx indicies to try to speed up
 396 searches.
 397
 398
 399 =cut
 400
 401
 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))
 407               )
 408    };
 409 sub get_bugs_by_idx{
 410      my %param = validate_with(params => \@_,
 411                                spec   => $_get_bugs_by_idx_options
 412                               );
 413      my %bugs = ();
 414
 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";
 420           }
 421      }
 422
 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)
 428                                               );
 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];
 434      }
 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':'';
 438      my %idx;
 439      for my $key (grep {$_ !~ $_non_search_key_regex} keys %param) {
 440           my $index = $key;
 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
 450                     $bugs{$bug}++;
 451                     $bug_matching{$bug}=1;
 452                }
 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
 457                          $bugs{$bug}++;
 458                          $bug_matching{$bug}=1;
 459                     }
 460                }
 461           }
 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};
 465                     $bugs{$bug}++;
 466                     $bug_matching{$bug}=1;
 467                }
 468           }
 469           untie %idx or die 'Unable to untie %idx';
 470      }
 471      if ($param{bugs}) {
 472           $keys++;
 473           for my $bug (make_list($param{bugs})) {
 474                $bugs{$bug}++;
 475           }
 476      }
 477      # Throw out results that do not match all of the search specifications
 478      return map {$keys <= $bugs{$_}?($_):()} keys %bugs;
 479 }
 480
 481
 482 =head2 get_bugs_by_db
 483
 484 This routine uses the database to try to speed up
 485 searches.
 486
 487
 488 =cut
 489
 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))
 495               ),
 496     schema => {type     => OBJECT,
 497               },
 498    };
 499 sub get_bugs_by_db{
 500      my %param = validate_with(params => \@_,
 501                                spec   => $_get_bugs_by_db_options,
 502                               );
 503      my %bugs = ();
 504
 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_idx";
 510           }
 511      }
 512
 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)
 518                                               );
 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];
 524      }
 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'},
 531                           );
 532      }
 533      for my $key (qw(owner submitter done)) {
 534          if (exists $param{$key}) {
 535              $rs = $rs->search([map {("${key}.addr" => $_)} make_list($param{$key})],
 536                               {join => $key},
 537                               );
 538          }
 539      }
 540      if (exists $param{correspondent}) {
 541          $rs = $rs->search([map {('message_correspondents.addr' => $_)} make_list($param{correspondent})],
 542                           {join => {correspondent =>
 543                                    {bug_messages =>
 544                                    {message => 'message_correspondents'}}}},
 545                           );
 546      }
 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}),
 550                            ],
 551                           {join => [{bug_affects_binpackages => 'bin_pkg'},
 552                                    {bug_affects_srcpackages => 'src_pkg'},
 553                                    ],
 554                           },
 555                           );
 556      }
 557      if (exists $param{package}) {
 558          $rs = $rs->search([map {('bin_pkg.pkg' => $_)} make_list($param{package})],
 559                           {join => {bug_binpackages => 'bin_pkg'}});
 560      }
 561      if (exists $param{src}) {
 562          $rs = $rs->search([map {('src_pkg.pkg' => $_)} make_list($param{src})],
 563                           {join => {bug_srcpackages => 'src_pkg'}});
 564      }
 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;
 571          }
 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
 577                            ],
 578                           {join => {bug_tags => 'tag'}});
 579      }
 580      if (exists $param{bugs}) {
 581          $rs = $rs->search([map {('me.id' => $_)} make_list($param{bugs})]);
 582      }
 583      # handle archive
 584      if (defined $param{archive} and $param{archive} ne 'both') {
 585          $rs = $rs->search('me.archived' => $param{archive})
 586      }
 587      return $rs->get_column('id')->all();
 588 }
 589
 590
 591 =head2 get_bugs_flatfile
 592
 593 This is the fallback search routine. It should be able to complete all
 594 searches. [Or at least, that's the idea.]
 595
 596 =cut
 597
 598 my $_get_bugs_flatfile_options =
 599    {hash_slice(%_get_bugs_common_options,
 600                map {$_ eq 'dist'?():($_)} keys %_get_bugs_common_options
 601               )
 602    };
 603
 604 sub get_bugs_flatfile{
 605      my %param = validate_with(params => \@_,
 606                                spec   => $_get_bugs_flatfile_options
 607                               );
 608      my $flatfile;
 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: $!";
 612      }
 613      else {
 614           $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
 615                or die "Unable to open $config{spool_dir}/index.db for reading: $!";
 616      }
 617      my %usertag_bugs;
 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})});
 623      }
 624      my $unmaintained_packages = 0;
 625      # unmaintained packages is a special case
 626      my @maints = make_list(exists $param{maint}?$param{maint}:[]);
 627      $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}):()),
 634                                    sub {my %d=@_;
 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};
 639                                         }
 640                                         return 0;
 641                                    }
 642                                   ];
 643           }
 644           elsif (defined $maint and $maint ne '') {
 645                push @{$param{maint}},$maint;
 646           }
 647      }
 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)
 653                                               );
 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;
 659      }
 660      my $grep_bugs = 0;
 661      my %bugs;
 662      if (exists $param{bugs}) {
 663           $bugs{$_} = 1 for make_list($param{bugs});
 664           $grep_bugs = 1;
 665      }
 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),
 672                                            );
 673           $grep_bugs = 1;
 674      }
 675      my @bugs;
 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})
 684                              } @packages;
 685           }
 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
 691                              } @src_packages;
 692           }
 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
 701                              } @f_addrs;
 702           }
 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}) {
 706                my $bug_ok = 0;
 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});
 712                                } @bug_tags;
 713                next unless $bug_ok;
 714           }
 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})) {
 721                     next BUG unless
 722                          $function->(pkg       => $package,
 723                                      bug       => $bug,
 724                                      status    => $status,
 725                                      submitter => $submitter,
 726                                      severity  => $severity,
 727                                      tags      => \@bug_tags,
 728                                     );
 729                }
 730           }
 731           push @bugs, $bug;
 732      }
 733      return @bugs;
 734 }
 735
 736 =head1 PRIVATE FUNCTIONS
 737
 738 =head2 __handle_pkg_src_and_maint
 739
 740      my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
 741                                                qw(package src maint)
 742                                               );
 743
 744 Turn package/src/maint into a list of packages
 745
 746 =cut
 747
 748 sub __handle_pkg_src_and_maint{
 749      my %param = validate_with(params => \@_,
 750                                spec   => {package   => {type => SCALAR|ARRAYREF,
 751                                                         optional => 1,
 752                                                        },
 753                                           src       => {type => SCALAR|ARRAYREF,
 754                                                         optional => 1,
 755                                                        },
 756                                           maint     => {type => SCALAR|ARRAYREF,
 757                                                         optional => 1,
 758                                                        },
 759                                          },
 760                                allow_extra => 1,
 761                               );
 762
 763      my @packages;
 764      @packages = make_list($param{package}) if exists $param{package};
 765      my $package_keys = @packages?1:0;
 766      my %packages;
 767      @packages{@packages} = (1) x @packages;
 768      if (exists $param{src}) {
 769           # We only want to increment the number of keys if there is
 770           # something to match
 771           my $key_inc = 0;
 772           # in case there are binaries with the same name as the
 773           # source
 774           my %_temp_p = ();
 775           for my $package ((map {getsrcpkgs($_)} make_list($param{src}))) {
 776                $packages{$package}++ unless exists $_temp_p{$package};
 777                $_temp_p{$package} = 1;
 778                $key_inc=1;
 779           }
 780           for my $package (make_list($param{src})) {
 781                $packages{"src:$package"}++ unless exists $_temp_p{"src:$package"};
 782                $_temp_p{"src:$package"} = 1;
 783                $key_inc=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;
 790                }
 791           }
 792           $package_keys += $key_inc;
 793      }
 794      if (exists $param{maint}) {
 795           my $key_inc = 0;
 796           my %_temp_p = ();
 797           for my $package (package_maintainer(maintainer=>$param{maint})) {
 798                $packages{$package}++ unless exists $_temp_p{$package};
 799                $_temp_p{$package} = 1;
 800                $key_inc = 1;
 801           }
 802           $package_keys += $key_inc;
 803      }
 804      return grep {$packages{$_} >= $package_keys} keys %packages;
 805 }
 806
 807 my %field_match = (
 808     'subject' => \&__contains_field_match,
 809     'tags' => sub {
 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});
 814         }
 815         return 0;
 816     },
 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,
 823 );
 824
 825 sub __bug_matches {
 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";
 833         }
 834         return 1 if ($sub->($key, $value, $status));
 835     }
 836     return 0;
 837 }
 838
 839 sub __exact_field_match {
 840     my ($field, $values, $status) = @_;
 841     my @values = @$values;
 842     my @ret = grep {$_ eq $status->{$field} } @values;
 843     $#ret != -1;
 844 }
 845
 846 sub __contains_field_match {
 847     my ($field, $values, $status) = @_;
 848     foreach my $data (@$values) {
 849         return 1 if (index($status->{$field}, $data) > -1);
 850     }
 851     return 0;
 852 }
 853
 854
 855
 856
 857
 858 1;
 859
 860 __END__