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 feature 'state';
  41 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  42 use Exporter qw(import);
  43
  44 BEGIN{
  45      $VERSION = 1.00;
  46      $DEBUG = 0 unless defined $DEBUG;
  47
  48      @EXPORT = ();
  49      %EXPORT_TAGS = ();
  50      @EXPORT_OK = (qw(get_bugs count_bugs newest_bug bug_filter));
  51      $EXPORT_TAGS{all} = [@EXPORT_OK];
  52 }
  53
  54 use Debbugs::Config qw(:config);
  55 use Params::Validate qw(validate_with :types);
  56 use IO::File;
  57 use Debbugs::Status qw(splitpackages get_bug_status);
  58 use Debbugs::Packages qw(getsrcpkgs getpkgsrc);
  59 use Debbugs::Common qw(getparsedaddrs package_maintainer getmaintainers make_list hash_slice);
  60 use Fcntl qw(O_RDONLY);
  61 use MLDBM qw(DB_File Storable);
  62 use List::AllUtils qw(first max);
  63 use Carp;
  64
  65 =head2 get_bugs
  66
  67      get_bugs()
  68
  69 =head3 Parameters
  70
  71 The following parameters can either be a single scalar or a reference
  72 to an array. The parameters are ANDed together, and the elements of
  73 arrayrefs are a parameter are ORed. Future versions of this may allow
  74 for limited regular expressions, and/or more complex expressions.
  75
  76 =over
  77
  78 =item package -- name of the binary package
  79
  80 =item src -- name of the source package
  81
  82 =item maint -- address of the maintainer
  83
  84 =item submitter -- address of the submitter
  85
  86 =item severity -- severity of the bug
  87
  88 =item status -- status of the bug
  89
  90 =item tag -- bug tags
  91
  92 =item owner -- owner of the bug
  93
  94 =item correspondent -- address of someone who sent mail to the log
  95
  96 =item affects -- bugs which affect this package
  97
  98 =item dist -- distribution (I don't know about this one yet)
  99
 100 =item bugs -- list of bugs to search within
 101
 102 =item function -- see description below
 103
 104 =back
 105
 106 =head3 Special options
 107
 108 The following options are special options used to modulate how the
 109 searches are performed.
 110
 111 =over
 112
 113 =item archive -- whether to search archived bugs or normal bugs;
 114 defaults to false. As a special case, if archive is 'both', but
 115 archived and unarchived bugs are returned.
 116
 117 =item usertags -- set of usertags and the bugs they are applied to
 118
 119 =back
 120
 121
 122 =head3 Subsidiary routines
 123
 124 All subsidiary routines get passed exactly the same set of options as
 125 get_bugs. If for some reason they are unable to handle the options
 126 passed (for example, they don't have the right type of index for the
 127 type of selection) they should die as early as possible. [Using
 128 Params::Validate and/or die when files don't exist makes this fairly
 129 trivial.]
 130
 131 This function will then immediately move on to the next subroutine,
 132 giving it the same arguments.
 133
 134 =head3 function
 135
 136 This option allows you to provide an arbitrary function which will be
 137 given the information in the index.db file. This will be super, super
 138 slow, so only do this if there's no other way to write the search.
 139
 140 You'll be given a list (which you can turn into a hash) like the
 141 following:
 142
 143  (pkg => ['a','b'], # may be a scalar (most common)
 144   bug => 1234,
 145   status => 'pending',
 146   submitter => 'boo@baz.com',
 147   severity => 'serious',
 148   tags => ['a','b','c'], # may be an empty arrayref
 149  )
 150
 151 The function should return 1 if the bug should be included; 0 if the
 152 bug should not.
 153
 154 =cut
 155
 156 state $_non_search_key_regex = qr/^(bugs|archive|usertags|schema)$/;
 157
 158 my %_get_bugs_common_options =
 159     (package   => {type => SCALAR|ARRAYREF,
 160                    optional => 1,
 161                   },
 162      src       => {type => SCALAR|ARRAYREF,
 163                    optional => 1,
 164                   },
 165      maint     => {type => SCALAR|ARRAYREF,
 166                    optional => 1,
 167                   },
 168      submitter => {type => SCALAR|ARRAYREF,
 169                    optional => 1,
 170                   },
 171      severity  => {type => SCALAR|ARRAYREF,
 172                    optional => 1,
 173                   },
 174      status    => {type => SCALAR|ARRAYREF,
 175                    optional => 1,
 176                   },
 177      tag       => {type => SCALAR|ARRAYREF,
 178                    optional => 1,
 179                   },
 180      owner     => {type => SCALAR|ARRAYREF,
 181                    optional => 1,
 182                   },
 183      dist      => {type => SCALAR|ARRAYREF,
 184                    optional => 1,
 185                   },
 186      correspondent => {type => SCALAR|ARRAYREF,
 187                        optional => 1,
 188                       },
 189      affects   => {type => SCALAR|ARRAYREF,
 190                    optional => 1,
 191                   },
 192      function  => {type => CODEREF,
 193                    optional => 1,
 194                   },
 195      bugs      => {type => SCALAR|ARRAYREF,
 196                    optional => 1,
 197                   },
 198      archive   => {type => BOOLEAN|SCALAR,
 199                    default => 0,
 200                   },
 201      usertags  => {type => HASHREF,
 202                    optional => 1,
 203                   },
 204      newest    => {type => SCALAR|ARRAYREF,
 205                    optional => 1,
 206                   },
 207      schema => {type     => OBJECT,
 208                 optional => 1,
 209                },
 210     );
 211
 212
 213 state $_get_bugs_options = {%_get_bugs_common_options};
 214 sub get_bugs{
 215      my %param = validate_with(params => \@_,
 216                                spec   => $_get_bugs_options,
 217                               );
 218
 219      # Normalize options
 220      my %options = %param;
 221      my @bugs;
 222      if ($options{archive} eq 'both') {
 223           push @bugs, get_bugs(%options,archive=>0);
 224           push @bugs, get_bugs(%options,archive=>1);
 225           my %bugs;
 226           @bugs{@bugs} = @bugs;
 227           return keys %bugs;
 228      }
 229      # A configuration option will set an array that we'll use here instead.
 230      for my $routine (qw(Debbugs::Bugs::get_bugs_by_db Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) {
 231           my ($package) = $routine =~ m/^(.+)\:\:/;
 232           eval "use $package;";
 233           if ($@) {
 234                # We output errors here because using an invalid function
 235                # in the configuration file isn't something that should
 236                # be done.
 237                warn "use $package failed with $@";
 238                next;
 239           }
 240           @bugs = eval "${routine}(\%options)";
 241           if ($@) {
 242
 243                # We don't output errors here, because failure here
 244                # via die may be a perfectly normal thing.
 245                print STDERR "$@" if $DEBUG;
 246                next;
 247           }
 248           last;
 249      }
 250      # If no one succeeded, die
 251      if ($@) {
 252           die "$@";
 253      }
 254      return @bugs;
 255 }
 256
 257 =head2 count_bugs
 258
 259      count_bugs(function => sub {...})
 260
 261 Uses a subroutine to classify bugs into categories and return the
 262 number of bugs which fall into those categories
 263
 264 =cut
 265
 266 sub count_bugs {
 267      my %param = validate_with(params => \@_,
 268                                spec   => {function => {type => CODEREF,
 269                                                       },
 270                                           archive  => {type => BOOLEAN,
 271                                                        default => 0,
 272                                                       },
 273                                          },
 274                               );
 275      my $flatfile;
 276      if ($param{archive}) {
 277           $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
 278                or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
 279      }
 280      else {
 281           $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
 282                or die "Unable to open $config{spool_dir}/index.db for reading: $!";
 283      }
 284      my %count = ();
 285      while(<$flatfile>) {
 286           if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
 287                my @x = $param{function}->(pkg       => $1,
 288                                           bug       => $2,
 289                                           status    => $4,
 290                                           submitter => $5,
 291                                           severity  => $6,
 292                                           tags      => $7,
 293                                          );
 294                local $_;
 295                $count{$_}++ foreach @x;
 296           }
 297      }
 298      close $flatfile;
 299      return %count;
 300 }
 301
 302 =head2 newest_bug
 303
 304      my $bug = newest_bug();
 305
 306 Returns the bug number of the newest bug, which is nextnumber-1.
 307
 308 =cut
 309
 310 sub newest_bug {
 311      my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r')
 312           or die "Unable to open $config{spool_dir}nextnumber for reading: $!";
 313      local $/;
 314      my $next_number = <$nn_fh>;
 315      close $nn_fh;
 316      chomp $next_number;
 317      return $next_number-1;
 318 }
 319
 320 =head2 bug_filter
 321
 322      bug_filter
 323
 324 Allows filtering bugs on commonly used criteria
 325
 326
 327
 328 =cut
 329
 330 sub bug_filter {
 331      my %param = validate_with(params => \@_,
 332                                spec   => {bug    => {type => ARRAYREF|SCALAR,
 333                                                      optional => 1,
 334                                                     },
 335                                           status => {type => HASHREF|ARRAYREF,
 336                                                      optional => 1,
 337                                                     },
 338                                           seen_merged => {type => HASHREF,
 339                                                           optional => 1,
 340                                                          },
 341                                           repeat_merged => {type => BOOLEAN,
 342                                                             default => 1,
 343                                                            },
 344                                           include => {type => HASHREF,
 345                                                       optional => 1,
 346                                                      },
 347                                           exclude => {type => HASHREF,
 348                                                       optional => 1,
 349                                                      },
 350                                           min_days => {type => SCALAR,
 351                                                        optional => 1,
 352                                                       },
 353                                           max_days => {type => SCALAR,
 354                                                        optional => 1,
 355                                                       },
 356                                          },
 357                               );
 358      if (exists $param{repeat_merged} and
 359          not $param{repeat_merged} and
 360          not defined $param{seen_merged}) {
 361           croak "repeat_merged false requires seen_merged to be passed";
 362      }
 363      if (not exists $param{bug} and not exists $param{status}) {
 364          croak "one of bug or status must be passed";
 365      }
 366
 367      if (not exists $param{status}) {
 368           my $location = getbuglocation($param{bug}, 'summary');
 369           return 0 if not defined $location or not length $location;
 370           $param{status} = readbug( $param{bug}, $location );
 371           return 0 if not defined $param{status};
 372      }
 373
 374      if (exists $param{include}) {
 375           return 1 if (!__bug_matches($param{include}, $param{status}));
 376      }
 377      if (exists $param{exclude}) {
 378           return 1 if (__bug_matches($param{exclude}, $param{status}));
 379      }
 380      if (exists $param{repeat_merged} and not $param{repeat_merged}) {
 381           my @merged = sort {$a<=>$b} $param{bug}, split(/ /, $param{status}{mergedwith});
 382           return 1 if first {defined $_} @{$param{seen_merged}}{@merged};
 383           @{$param{seen_merged}}{@merged} = (1) x @merged;
 384      }
 385      my $daysold = int((time - $param{status}{date}) / 86400);   # seconds to days
 386      if (exists $param{min_days}) {
 387           return 1 unless $param{min_days} <= $daysold;
 388      }
 389      if (exists $param{max_days}) {
 390           return 1 unless $param{max_days} == -1 or
 391                $param{max_days} >= $daysold;
 392      }
 393      return 0;
 394 }
 395
 396
 397 =head2 get_bugs_by_idx
 398
 399 This routine uses the by-$index.idx indicies to try to speed up
 400 searches.
 401
 402
 403 =cut
 404
 405
 406 state $_get_bugs_by_idx_options =
 407    {hash_slice(%_get_bugs_common_options,
 408                (qw(package submitter severity tag archive),
 409                 qw(owner src maint bugs correspondent),
 410                 qw(affects usertags newest))
 411               )
 412    };
 413 sub get_bugs_by_idx{
 414      my %param = validate_with(params => \@_,
 415                                spec   => $_get_bugs_by_idx_options
 416                               );
 417      my %bugs = ();
 418
 419      # If we're given an empty maint (unmaintained packages), we can't
 420      # handle it, so bail out here
 421      for my $maint (make_list(exists $param{maint}?$param{maint}:[])) {
 422           if (defined $maint and $maint eq '') {
 423                die "Can't handle empty maint (unmaintained packages) in get_bugs_by_idx";
 424           }
 425      }
 426      if ($param{newest}) {
 427          my $newest_bug = newest_bug();
 428          my @bugs = ($newest_bug - max(make_list($param{newest})) + 1) .. $newest_bug;
 429          $param{bugs} = [exists $param{bugs}?make_list($param{bugs}):(),
 430                          @bugs,
 431                         ];
 432      }
 433      # We handle src packages, maint and maintenc by mapping to the
 434      # appropriate binary packages, then removing all packages which
 435      # don't match all queries
 436      my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
 437                                                qw(package src maint)
 438                                               );
 439      if (exists $param{package} or
 440          exists $param{src} or
 441          exists $param{maint}) {
 442           delete @param{qw(maint src)};
 443           $param{package} = [@packages];
 444      }
 445      my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param);
 446      die "Need at least 1 key to search by" unless $keys;
 447      my $arc = $param{archive} ? '-arc':'';
 448      my %idx;
 449      for my $key (grep {$_ !~ $_non_search_key_regex} keys %param) {
 450           my $index = $key;
 451           $index = 'submitter-email' if $key eq 'submitter';
 452           $index = "$config{spool_dir}/by-${index}${arc}.idx";
 453           tie(%idx, MLDBM => $index, O_RDONLY)
 454                or die "Unable to open $index: $!";
 455           my %bug_matching = ();
 456           for my $search (make_list($param{$key})) {
 457                for my $bug (keys %{$idx{$search}||{}}) {
 458                     next if $bug_matching{$bug};
 459                     # increment the number of searches that this bug matched
 460                     $bugs{$bug}++;
 461                     $bug_matching{$bug}=1;
 462                }
 463                if ($search ne lc($search)) {
 464                     for my $bug (keys %{$idx{lc($search)}||{}}) {
 465                          next if $bug_matching{$bug};
 466                          # increment the number of searches that this bug matched
 467                          $bugs{$bug}++;
 468                          $bug_matching{$bug}=1;
 469                     }
 470                }
 471           }
 472           if ($key eq 'tag' and exists $param{usertags}) {
 473                for my $bug (make_list(grep {defined $_ } @{$param{usertags}}{make_list($param{tag})})) {
 474                     next if $bug_matching{$bug};
 475                     $bugs{$bug}++;
 476                     $bug_matching{$bug}=1;
 477                }
 478           }
 479           untie %idx or die 'Unable to untie %idx';
 480      }
 481      if ($param{bugs}) {
 482           $keys++;
 483           for my $bug (make_list($param{bugs})) {
 484                $bugs{$bug}++;
 485           }
 486      }
 487      # Throw out results that do not match all of the search specifications
 488      return map {$keys <= $bugs{$_}?($_):()} keys %bugs;
 489 }
 490
 491
 492 =head2 get_bugs_by_db
 493
 494 This routine uses the database to try to speed up
 495 searches.
 496
 497
 498 =cut
 499
 500 state $_get_bugs_by_db_options =
 501    {hash_slice(%_get_bugs_common_options,
 502                (qw(package submitter severity tag archive),
 503                 qw(owner src maint bugs correspondent),
 504                 qw(affects usertags newest))
 505               ),
 506     schema => {type     => OBJECT,
 507               },
 508    };
 509 sub get_bugs_by_db{
 510      my %param = validate_with(params => \@_,
 511                                spec   => $_get_bugs_by_db_options,
 512                               );
 513      my %bugs = ();
 514
 515      my $s = $param{schema};
 516      my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param);
 517      die "Need at least 1 key to search by" unless $keys;
 518      my $rs = $s->resultset('Bug');
 519      if (exists $param{severity}) {
 520          $rs = $rs->search({'severity.severity' =>
 521                             [make_list($param{severity})],
 522                            },
 523                           {join => 'severity'},
 524                           );
 525      }
 526      for my $key (qw(owner submitter done)) {
 527          if (exists $param{$key}) {
 528              $rs = $rs->search({"${key}.addr" =>
 529                                 [make_list($param{$key})],
 530                                },
 531                               {join => $key},
 532                               );
 533          }
 534      }
 535      if (exists $param{newest}) {
 536          $rs =
 537              $rs->search({},
 538                         {order_by => {-desc => 'me.creation'},
 539                          rows => max(make_list($param{newest})),
 540                         },
 541                         );
 542      }
 543      if (exists $param{correspondent}) {
 544          my $message_rs =
 545              $s->resultset('Message')->
 546              search({'correspondent.addr' =>
 547                      [make_list($param{correspondent})],
 548                     },
 549                    {join => {message_correspondents => 'correspondent'},
 550                     columns => ['id'],
 551                     group_by => ['me.id'],
 552                    },
 553                    );
 554          $rs = $rs->search({'bug_messages.message' =>
 555                            {-in => $message_rs->get_column('id')->as_query()},
 556                            },
 557                           {join => 'bug_messages',
 558                           },
 559                           );
 560      }
 561      if (exists $param{affects}) {
 562          my @aff_list = make_list($param{affects});
 563          $rs = $rs->search({-or => {'bin_pkg.pkg' =>
 564                                     [@aff_list],
 565                                     'src_pkg.pkg' =>
 566                                     [@aff_list],
 567                                     'me.unknown_affects' =>
 568                                     [@aff_list]
 569                                    },
 570                            },
 571                           {join => [{bug_affects_binpackages => 'bin_pkg'},
 572                                    {bug_affects_srcpackages => 'src_pkg'},
 573                                    ],
 574                           },
 575                           );
 576      }
 577      if (exists $param{package}) {
 578          $rs = $rs->search({-or => {'bin_pkg.pkg' =>
 579                                     [make_list($param{package})],
 580                                     'me.unknown.package' =>
 581                                     [make_list($param{package})]},
 582                            },
 583                           {join => {bug_binpackages => 'bin_pkg'}});
 584      }
 585      if (exists $param{maint}) {
 586          my @maint_list =
 587              map {$_ eq '' ? undef : $_}
 588              make_list($param{maint});
 589          my $bin_pkgs_rs =
 590              $s->resultset('BinPkg')->
 591              search({'correspondent.addr' => [@maint_list]},
 592                    {join => {bin_vers =>
 593                             {src_ver =>
 594                             {maintainer => 'correspondent'}}},
 595                     columns => ['id'],
 596                     group_by => ['me.id'],
 597                    },
 598                    );
 599          my $src_pkgs_rs =
 600              $s->resultset('SrcPkg')->
 601              search({'correspondent.addr' => [@maint_list]},
 602                    {join => {src_vers =>
 603                             {maintainer => 'correspondent'}},
 604                     columns => ['id'],
 605                     group_by => ['me.id'],
 606                    },
 607                    );
 608          $rs = $rs->search({-or => {'bug_binpackages.bin_pkg' =>
 609                                    { -in => $bin_pkgs_rs->get_column('id')->as_query},
 610                                     'bug_srcpackages.src_pkg' =>
 611                                    { -in => $bin_pkgs_rs->get_column('id')->as_query},
 612                                    },
 613                            },
 614                           {join => ['bug_binpackages',
 615                                     'bug_srcpackages',
 616                                    ]}
 617                           );
 618      }
 619      if (exists $param{src}) {
 620          # identify all of the srcpackages and binpackages that match first
 621          my $src_pkgs_rs =
 622          $s->resultset('SrcPkg')->
 623              search({-or => [map {('me.pkg' => $_,
 624                                   )}
 625                              make_list($param{src})],
 626                      columns => ['id'],
 627                      group_by => ['me.id'],
 628                     },
 629                    );
 630          my $bin_pkgs_rs =
 631          $s->resultset('BinPkg')->
 632              search({-or => [map {('src_pkg.pkg' => $_,
 633                                   )}
 634                              make_list($param{src})],
 635                      },
 636                    {join => {bin_vers => {src_ver => 'src_pkg'}},
 637                     columns => ['id'],
 638                     group_by => ['me.id'],
 639                    });
 640          $rs = $rs->search({-or => {'bug_binpackages.bin_pkg' =>
 641                                    { -in => $bin_pkgs_rs->get_column('id')->as_query},
 642                                     'bug_srcpackages.src_pkg' =>
 643                                    { -in => $bin_pkgs_rs->get_column('id')->as_query},
 644                                     'me.unknown_package' =>
 645                                     [make_list($param{src})],
 646                                    },
 647                            },
 648                           {join => ['bug_binpackages',
 649                                     'bug_srcpackages',
 650                                    ]}
 651                           );
 652      }
 653      # tags are very odd, because we must handle usertags.
 654      if (exists $param{tag}) {
 655          # bugs from usertags which matter
 656          my %bugs_matching_usertags;
 657          for my $bug (make_list(grep {defined $_ }
 658                                 @{$param{usertags}}{make_list($param{tag})})) {
 659              $bugs_matching_usertags{$bug} = 1;
 660          }
 661          # we want all bugs which either match the tag name given in
 662          # param, or have a usertag set which matches one of the tag
 663          # names given in param.
 664          $rs = $rs->search({-or => {map {('tag.tag' => $_)}
 665                                     make_list($param{tag}),
 666                                     map {('me.id' => $_)}
 667                                     keys %bugs_matching_usertags
 668                                    },
 669                            },
 670                           {join => {bug_tags => 'tag'}});
 671      }
 672      if (exists $param{bugs}) {
 673          $rs = $rs->search({-or => {map {('me.id' => $_)}
 674                                     make_list($param{bugs})}
 675                            });
 676      }
 677      # handle archive
 678      if (defined $param{archive} and $param{archive} ne 'both') {
 679          $rs = $rs->search({'me.archived' => $param{archive}});
 680      }
 681      return $rs->get_column('id')->all();
 682 }
 683
 684
 685 =head2 get_bugs_flatfile
 686
 687 This is the fallback search routine. It should be able to complete all
 688 searches. [Or at least, that's the idea.]
 689
 690 =cut
 691
 692 state $_get_bugs_flatfile_options =
 693    {hash_slice(%_get_bugs_common_options,
 694                map {$_ eq 'dist'?():($_)} keys %_get_bugs_common_options
 695               )
 696    };
 697
 698 sub get_bugs_flatfile{
 699      my %param = validate_with(params => \@_,
 700                                spec   => $_get_bugs_flatfile_options
 701                               );
 702      my $flatfile;
 703      if ($param{newest}) {
 704          my $newest_bug = newest_bug();
 705          my @bugs = ($newest_bug - max(make_list($param{newest})) + 1) .. $newest_bug;
 706          $param{bugs} = [exists $param{bugs}?make_list($param{bugs}):(),
 707                          @bugs,
 708                         ];
 709      }
 710      if ($param{archive}) {
 711           $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
 712                or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
 713      }
 714      else {
 715           $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
 716                or die "Unable to open $config{spool_dir}/index.db for reading: $!";
 717      }
 718      my %usertag_bugs;
 719      if (exists $param{tag} and exists $param{usertags}) {
 720           # This complex slice makes a hash with the bugs which have the
 721           # usertags passed in $param{tag} set.
 722           @usertag_bugs{make_list(@{$param{usertags}}{make_list($param{tag})})
 723                         } = (1) x make_list(@{$param{usertags}}{make_list($param{tag})});
 724      }
 725      my $unmaintained_packages = 0;
 726      # unmaintained packages is a special case
 727      my @maints = make_list(exists $param{maint}?$param{maint}:[]);
 728      $param{maint} = [];
 729      for my $maint (@maints) {
 730           if (defined $maint and $maint eq '' and not $unmaintained_packages) {
 731                $unmaintained_packages = 1;
 732                our %maintainers = %{getmaintainers()};
 733                $param{function} = [(exists $param{function}?
 734                                     (ref $param{function}?@{$param{function}}:$param{function}):()),
 735                                    sub {my %d=@_;
 736                                         foreach my $try (make_list($d{"pkg"})) {
 737                                              next unless length $try;
 738                                              ($try) = $try =~ m/^(?:src:)?(.+)/;
 739                                              return 1 if not exists $maintainers{$try};
 740                                         }
 741                                         return 0;
 742                                    }
 743                                   ];
 744           }
 745           elsif (defined $maint and $maint ne '') {
 746                push @{$param{maint}},$maint;
 747           }
 748      }
 749      # We handle src packages, maint and maintenc by mapping to the
 750      # appropriate binary packages, then removing all packages which
 751      # don't match all queries
 752      my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
 753                                                qw(package src maint)
 754                                               );
 755      if (exists $param{package} or
 756          exists $param{src} or
 757          exists $param{maint}) {
 758           delete @param{qw(maint src)};
 759           $param{package} = [@packages] if @packages;
 760      }
 761      my $grep_bugs = 0;
 762      my %bugs;
 763      if (exists $param{bugs}) {
 764           $bugs{$_} = 1 for make_list($param{bugs});
 765           $grep_bugs = 1;
 766      }
 767      # These queries have to be handled by get_bugs_by_idx
 768      if (exists $param{owner}
 769          or exists $param{correspondent}
 770          or exists $param{affects}) {
 771           $bugs{$_} = 1 for get_bugs_by_idx(map {exists $param{$_}?($_,$param{$_}):()}
 772                                             qw(owner correspondent affects),
 773                                            );
 774           $grep_bugs = 1;
 775      }
 776      my @bugs;
 777      BUG: while (<$flatfile>) {
 778           next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*(.*)\s*\]\s+(\w+)\s+(.*)$/;
 779           my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7);
 780           next if $grep_bugs and not exists $bugs{$bug};
 781           if (exists $param{package}) {
 782                my @packages = splitpackages($pkg);
 783                next unless grep { my $pkg_list = $_;
 784                                   grep {$pkg_list eq $_} make_list($param{package})
 785                              } @packages;
 786           }
 787           if (exists $param{src}) {
 788                my @src_packages = map { getsrcpkgs($_)} make_list($param{src});
 789                my @packages = splitpackages($pkg);
 790                next unless grep { my $pkg_list = $_;
 791                                   grep {$pkg_list eq $_} @packages
 792                              } @src_packages;
 793           }
 794           if (exists $param{submitter}) {
 795                my @p_addrs = map {lc($_->address)}
 796                     map {getparsedaddrs($_)}
 797                          make_list($param{submitter});
 798                my @f_addrs = map {$_->address}
 799                     getparsedaddrs($submitter||'');
 800                next unless grep { my $f_addr = $_;
 801                                   grep {$f_addr eq $_} @p_addrs
 802                              } @f_addrs;
 803           }
 804           next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity});
 805           next if exists $param{status} and not grep {$status eq $_} make_list($param{status});
 806           if (exists $param{tag}) {
 807                my $bug_ok = 0;
 808                # either a normal tag, or a usertag must be set
 809                $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug};
 810                my @bug_tags = split ' ', $tags;
 811                $bug_ok = 1 if grep {my $bug_tag = $_;
 812                                     grep {$bug_tag eq $_} make_list($param{tag});
 813                                } @bug_tags;
 814                next unless $bug_ok;
 815           }
 816           # We do this last, because a function may be slow...
 817           if (exists $param{function}) {
 818                my @bug_tags = split ' ', $tags;
 819                my @packages = splitpackages($pkg);
 820                my $package = (@packages > 1)?\@packages:$packages[0];
 821                for my $function (make_list($param{function})) {
 822                     next BUG unless
 823                          $function->(pkg       => $package,
 824                                      bug       => $bug,
 825                                      status    => $status,
 826                                      submitter => $submitter,
 827                                      severity  => $severity,
 828                                      tags      => \@bug_tags,
 829                                     );
 830                }
 831           }
 832           push @bugs, $bug;
 833      }
 834      return @bugs;
 835 }
 836
 837 =head1 PRIVATE FUNCTIONS
 838
 839 =head2 __handle_pkg_src_and_maint
 840
 841      my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
 842                                                qw(package src maint)
 843                                               );
 844
 845 Turn package/src/maint into a list of packages
 846
 847 =cut
 848
 849 sub __handle_pkg_src_and_maint{
 850      my %param = validate_with(params => \@_,
 851                                spec   => {package   => {type => SCALAR|ARRAYREF,
 852                                                         optional => 1,
 853                                                        },
 854                                           src       => {type => SCALAR|ARRAYREF,
 855                                                         optional => 1,
 856                                                        },
 857                                           maint     => {type => SCALAR|ARRAYREF,
 858                                                         optional => 1,
 859                                                        },
 860                                          },
 861                                allow_extra => 1,
 862                               );
 863
 864      my @packages;
 865      @packages = make_list($param{package}) if exists $param{package};
 866      my $package_keys = @packages?1:0;
 867      my %packages;
 868      @packages{@packages} = (1) x @packages;
 869      if (exists $param{src}) {
 870           # We only want to increment the number of keys if there is
 871           # something to match
 872           my $key_inc = 0;
 873           # in case there are binaries with the same name as the
 874           # source
 875           my %_temp_p = ();
 876           for my $package ((map {getsrcpkgs($_)} make_list($param{src}))) {
 877                $packages{$package}++ unless exists $_temp_p{$package};
 878                $_temp_p{$package} = 1;
 879                $key_inc=1;
 880           }
 881           for my $package (make_list($param{src})) {
 882                $packages{"src:$package"}++ unless exists $_temp_p{"src:$package"};
 883                $_temp_p{"src:$package"} = 1;
 884                $key_inc=1;
 885                # As a temporary hack, we will also include $param{src}
 886                # in this list for packages passed which do not have a
 887                # corresponding binary package
 888                if (not exists getpkgsrc()->{$package}) {
 889                    $packages{$package}++ unless exists $_temp_p{$package};
 890                    $_temp_p{$package} = 1;
 891                }
 892           }
 893           $package_keys += $key_inc;
 894      }
 895      if (exists $param{maint}) {
 896           my $key_inc = 0;
 897           my %_temp_p = ();
 898           for my $package (package_maintainer(maintainer=>$param{maint})) {
 899                $packages{$package}++ unless exists $_temp_p{$package};
 900                $_temp_p{$package} = 1;
 901                $key_inc = 1;
 902           }
 903           $package_keys += $key_inc;
 904      }
 905      return grep {$packages{$_} >= $package_keys} keys %packages;
 906 }
 907
 908 state $field_match = {
 909     'subject' => \&__contains_field_match,
 910     'tags' => sub {
 911         my ($field, $values, $status) = @_;
 912         my %values = map {$_=>1} @$values;
 913         foreach my $t (split /\s+/, $status->{$field}) {
 914             return 1 if (defined $values{$t});
 915         }
 916         return 0;
 917     },
 918     'severity' => \&__exact_field_match,
 919     'pending' => \&__exact_field_match,
 920     'package' => \&__exact_field_match,
 921     'originator' => \&__contains_field_match,
 922     'forwarded' => \&__contains_field_match,
 923     'owner' => \&__contains_field_match,
 924 };
 925
 926 sub __bug_matches {
 927     my ($hash, $status) = @_;
 928     foreach my $key( keys( %$hash ) ) {
 929         my $value = $hash->{$key};
 930         next unless exists $field_match->{$key};
 931         my $sub = $field_match->{$key};
 932         if (not defined $sub) {
 933             die "No defined subroutine for key: $key";
 934         }
 935         return 1 if ($sub->($key, $value, $status));
 936     }
 937     return 0;
 938 }
 939
 940 sub __exact_field_match {
 941     my ($field, $values, $status) = @_;
 942     my @values = @$values;
 943     my @ret = grep {$_ eq $status->{$field} } @values;
 944     $#ret != -1;
 945 }
 946
 947 sub __contains_field_match {
 948     my ($field, $values, $status) = @_;
 949     foreach my $data (@$values) {
 950         return 1 if (index($status->{$field}, $data) > -1);
 951     }
 952     return 0;
 953 }
 954
 955
 956
 957
 958
 959 1;
 960
 961 __END__