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);
  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      schema => {type     => OBJECT,
 205                 optional => 1,
 206                },
 207     );
 208
 209
 210 state $_get_bugs_options = {%_get_bugs_common_options};
 211 sub get_bugs{
 212      my %param = validate_with(params => \@_,
 213                                spec   => $_get_bugs_options,
 214                               );
 215
 216      # Normalize options
 217      my %options = %param;
 218      my @bugs;
 219      if ($options{archive} eq 'both') {
 220           push @bugs, get_bugs(%options,archive=>0);
 221           push @bugs, get_bugs(%options,archive=>1);
 222           my %bugs;
 223           @bugs{@bugs} = @bugs;
 224           return keys %bugs;
 225      }
 226      # A configuration option will set an array that we'll use here instead.
 227      for my $routine (qw(Debbugs::Bugs::get_bugs_by_db Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) {
 228           my ($package) = $routine =~ m/^(.+)\:\:/;
 229           eval "use $package;";
 230           if ($@) {
 231                # We output errors here because using an invalid function
 232                # in the configuration file isn't something that should
 233                # be done.
 234                warn "use $package failed with $@";
 235                next;
 236           }
 237           @bugs = eval "${routine}(\%options)";
 238           if ($@) {
 239
 240                # We don't output errors here, because failure here
 241                # via die may be a perfectly normal thing.
 242                print STDERR "$@" if $DEBUG;
 243                next;
 244           }
 245           last;
 246      }
 247      # If no one succeeded, die
 248      if ($@) {
 249           die "$@";
 250      }
 251      return @bugs;
 252 }
 253
 254 =head2 count_bugs
 255
 256      count_bugs(function => sub {...})
 257
 258 Uses a subroutine to classify bugs into categories and return the
 259 number of bugs which fall into those categories
 260
 261 =cut
 262
 263 sub count_bugs {
 264      my %param = validate_with(params => \@_,
 265                                spec   => {function => {type => CODEREF,
 266                                                       },
 267                                           archive  => {type => BOOLEAN,
 268                                                        default => 0,
 269                                                       },
 270                                          },
 271                               );
 272      my $flatfile;
 273      if ($param{archive}) {
 274           $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
 275                or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
 276      }
 277      else {
 278           $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
 279                or die "Unable to open $config{spool_dir}/index.db for reading: $!";
 280      }
 281      my %count = ();
 282      while(<$flatfile>) {
 283           if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
 284                my @x = $param{function}->(pkg       => $1,
 285                                           bug       => $2,
 286                                           status    => $4,
 287                                           submitter => $5,
 288                                           severity  => $6,
 289                                           tags      => $7,
 290                                          );
 291                local $_;
 292                $count{$_}++ foreach @x;
 293           }
 294      }
 295      close $flatfile;
 296      return %count;
 297 }
 298
 299 =head2 newest_bug
 300
 301      my $bug = newest_bug();
 302
 303 Returns the bug number of the newest bug, which is nextnumber-1.
 304
 305 =cut
 306
 307 sub newest_bug {
 308      my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r')
 309           or die "Unable to open $config{spool_dir}nextnumber for reading: $!";
 310      local $/;
 311      my $next_number = <$nn_fh>;
 312      close $nn_fh;
 313      chomp $next_number;
 314      return $next_number-1;
 315 }
 316
 317 =head2 bug_filter
 318
 319      bug_filter
 320
 321 Allows filtering bugs on commonly used criteria
 322
 323
 324
 325 =cut
 326
 327 sub bug_filter {
 328      my %param = validate_with(params => \@_,
 329                                spec   => {bug    => {type => ARRAYREF|SCALAR,
 330                                                      optional => 1,
 331                                                     },
 332                                           status => {type => HASHREF|ARRAYREF,
 333                                                      optional => 1,
 334                                                     },
 335                                           seen_merged => {type => HASHREF,
 336                                                           optional => 1,
 337                                                          },
 338                                           repeat_merged => {type => BOOLEAN,
 339                                                             default => 1,
 340                                                            },
 341                                           include => {type => HASHREF,
 342                                                       optional => 1,
 343                                                      },
 344                                           exclude => {type => HASHREF,
 345                                                       optional => 1,
 346                                                      },
 347                                           min_days => {type => SCALAR,
 348                                                        optional => 1,
 349                                                       },
 350                                           max_days => {type => SCALAR,
 351                                                        optional => 1,
 352                                                       },
 353                                          },
 354                               );
 355      if (exists $param{repeat_merged} and
 356          not $param{repeat_merged} and
 357          not defined $param{seen_merged}) {
 358           croak "repeat_merged false requires seen_merged to be passed";
 359      }
 360      if (not exists $param{bug} and not exists $param{status}) {
 361          croak "one of bug or status must be passed";
 362      }
 363
 364      if (not exists $param{status}) {
 365           my $location = getbuglocation($param{bug}, 'summary');
 366           return 0 if not defined $location or not length $location;
 367           $param{status} = readbug( $param{bug}, $location );
 368           return 0 if not defined $param{status};
 369      }
 370
 371      if (exists $param{include}) {
 372           return 1 if (!__bug_matches($param{include}, $param{status}));
 373      }
 374      if (exists $param{exclude}) {
 375           return 1 if (__bug_matches($param{exclude}, $param{status}));
 376      }
 377      if (exists $param{repeat_merged} and not $param{repeat_merged}) {
 378           my @merged = sort {$a<=>$b} $param{bug}, split(/ /, $param{status}{mergedwith});
 379           return 1 if first {defined $_} @{$param{seen_merged}}{@merged};
 380           @{$param{seen_merged}}{@merged} = (1) x @merged;
 381      }
 382      my $daysold = int((time - $param{status}{date}) / 86400);   # seconds to days
 383      if (exists $param{min_days}) {
 384           return 1 unless $param{min_days} <= $daysold;
 385      }
 386      if (exists $param{max_days}) {
 387           return 1 unless $param{max_days} == -1 or
 388                $param{max_days} >= $daysold;
 389      }
 390      return 0;
 391 }
 392
 393
 394 =head2 get_bugs_by_idx
 395
 396 This routine uses the by-$index.idx indicies to try to speed up
 397 searches.
 398
 399
 400 =cut
 401
 402
 403 state $_get_bugs_by_idx_options =
 404    {hash_slice(%_get_bugs_common_options,
 405                (qw(package submitter severity tag archive),
 406                 qw(owner src maint bugs correspondent),
 407                 qw(affects usertags))
 408               )
 409    };
 410 sub get_bugs_by_idx{
 411      my %param = validate_with(params => \@_,
 412                                spec   => $_get_bugs_by_idx_options
 413                               );
 414      my %bugs = ();
 415
 416      # If we're given an empty maint (unmaintained packages), we can't
 417      # handle it, so bail out here
 418      for my $maint (make_list(exists $param{maint}?$param{maint}:[])) {
 419           if (defined $maint and $maint eq '') {
 420                die "Can't handle empty maint (unmaintained packages) in get_bugs_by_idx";
 421           }
 422      }
 423
 424      # We handle src packages, maint and maintenc by mapping to the
 425      # appropriate binary packages, then removing all packages which
 426      # don't match all queries
 427      my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
 428                                                qw(package src maint)
 429                                               );
 430      if (exists $param{package} or
 431          exists $param{src} or
 432          exists $param{maint}) {
 433           delete @param{qw(maint src)};
 434           $param{package} = [@packages];
 435      }
 436      my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param);
 437      die "Need at least 1 key to search by" unless $keys;
 438      my $arc = $param{archive} ? '-arc':'';
 439      my %idx;
 440      for my $key (grep {$_ !~ $_non_search_key_regex} keys %param) {
 441           my $index = $key;
 442           $index = 'submitter-email' if $key eq 'submitter';
 443           $index = "$config{spool_dir}/by-${index}${arc}.idx";
 444           tie(%idx, MLDBM => $index, O_RDONLY)
 445                or die "Unable to open $index: $!";
 446           my %bug_matching = ();
 447           for my $search (make_list($param{$key})) {
 448                for my $bug (keys %{$idx{$search}||{}}) {
 449                     next if $bug_matching{$bug};
 450                     # increment the number of searches that this bug matched
 451                     $bugs{$bug}++;
 452                     $bug_matching{$bug}=1;
 453                }
 454                if ($search ne lc($search)) {
 455                     for my $bug (keys %{$idx{lc($search)}||{}}) {
 456                          next if $bug_matching{$bug};
 457                          # increment the number of searches that this bug matched
 458                          $bugs{$bug}++;
 459                          $bug_matching{$bug}=1;
 460                     }
 461                }
 462           }
 463           if ($key eq 'tag' and exists $param{usertags}) {
 464                for my $bug (make_list(grep {defined $_ } @{$param{usertags}}{make_list($param{tag})})) {
 465                     next if $bug_matching{$bug};
 466                     $bugs{$bug}++;
 467                     $bug_matching{$bug}=1;
 468                }
 469           }
 470           untie %idx or die 'Unable to untie %idx';
 471      }
 472      if ($param{bugs}) {
 473           $keys++;
 474           for my $bug (make_list($param{bugs})) {
 475                $bugs{$bug}++;
 476           }
 477      }
 478      # Throw out results that do not match all of the search specifications
 479      return map {$keys <= $bugs{$_}?($_):()} keys %bugs;
 480 }
 481
 482
 483 =head2 get_bugs_by_db
 484
 485 This routine uses the database to try to speed up
 486 searches.
 487
 488
 489 =cut
 490
 491 state $_get_bugs_by_db_options =
 492    {hash_slice(%_get_bugs_common_options,
 493                (qw(package submitter severity tag archive),
 494                 qw(owner src maint bugs correspondent),
 495                 qw(affects usertags))
 496               ),
 497     schema => {type     => OBJECT,
 498               },
 499    };
 500 sub get_bugs_by_db{
 501      my %param = validate_with(params => \@_,
 502                                spec   => $_get_bugs_by_db_options,
 503                               );
 504      my %bugs = ();
 505
 506      my $s = $param{schema};
 507      my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param);
 508      die "Need at least 1 key to search by" unless $keys;
 509      my $rs = $param{schema}->resultset('Bug');
 510      if (exists $param{package}) {
 511          $rs = $rs->search({-or => {map 'bin_package.'}})
 512      }
 513      if (exists $param{severity}) {
 514          $rs = $rs->search({'severity.severity' =>
 515                             [make_list($param{severity})],
 516                            },
 517                           {join => 'severity'},
 518                           );
 519      }
 520      for my $key (qw(owner submitter done)) {
 521          if (exists $param{$key}) {
 522              $rs = $rs->search({"${key}.addr" =>
 523                                 [make_list($param{$key})],
 524                                },
 525                               {join => $key},
 526                               );
 527          }
 528      }
 529      if (exists $param{correspondent}) {
 530          my $message_rs =
 531              $s->resultset('Message')->
 532              search({'correspondent.addr' =>
 533                      [make_list($param{correspondent})],
 534                     },
 535                    {join => {message_correspondents => 'correspondent'},
 536                     columns => ['id'],
 537                     group_by => ['me.id'],
 538                    },
 539                    );
 540          $rs = $rs->search({'bug_messages.message' =>
 541                            {-in => $message_rs->get_column('id')->as_query()},
 542                            },
 543                           {join => 'bug_messages',
 544                           },
 545                           );
 546      }
 547      if (exists $param{affects}) {
 548          my @aff_list = make_list($param{affects});
 549          $rs = $rs->search({-or => {'bin_pkg.pkg' =>
 550                                     [@aff_list],
 551                                     'src_pkg.pkg' =>
 552                                     [@aff_list],
 553                                     'me.unknown_affects' =>
 554                                     [@aff_list]
 555                                    },
 556                            },
 557                           {join => [{bug_affects_binpackages => 'bin_pkg'},
 558                                    {bug_affects_srcpackages => 'src_pkg'},
 559                                    ],
 560                           },
 561                           );
 562      }
 563      if (exists $param{package}) {
 564          $rs = $rs->search({'bin_pkg.pkg' =>
 565                             [make_list($param{package})],
 566                            },
 567                           {join => {bug_binpackages => 'bin_pkg'}});
 568      }
 569      if (exists $param{maint}) {
 570          my @maint_list =
 571              map {$_ eq '' ? undef : $_}
 572              make_list($param{maint});
 573          my $bin_pkgs_rs =
 574              $s->resultset('BinPkg')->
 575              search({'correspondent.addr' => [@maint_list]},
 576                    {join => {bin_vers =>
 577                             {src_ver =>
 578                             {maintainer => 'correspondent'}}},
 579                     columns => ['id'],
 580                     group_by => ['me.id'],
 581                    },
 582                    );
 583          my $src_pkgs_rs =
 584              $s->resultset('SrcPkg')->
 585              search({'correspondent.addr' => [@maint_list]},
 586                    {join => {src_vers =>
 587                             {maintainer => 'correspondent'}},
 588                     columns => ['id'],
 589                     group_by => ['me.id'],
 590                    },
 591                    );
 592          $rs = $rs->search({-or => {'bug_binpackages.bin_pkg' =>
 593                                    { -in => $bin_pkgs_rs->get_column('id')->as_query},
 594                                     'bug_srcpackages.src_pkg' =>
 595                                    { -in => $bin_pkgs_rs->get_column('id')->as_query},
 596                                    },
 597                            },
 598                           {join => ['bug_binpackages',
 599                                     'bug_srcpackages',
 600                                    ]}
 601                           );
 602      }
 603      if (exists $param{src}) {
 604          # identify all of the srcpackages and binpackages that match first
 605          my $src_pkgs_rs =
 606          $s->resultset('SrcPkg')->
 607              search({-or => [map {('me.pkg' => $_,
 608                                   )}
 609                              make_list($param{src})],
 610                      columns => ['id'],
 611                      group_by => ['me.id'],
 612                     },
 613                    );
 614          my $bin_pkgs_rs =
 615          $s->resultset('BinPkg')->
 616              search({-or => [map {('src_pkg.pkg' => $_,
 617                                   )}
 618                              make_list($param{src})],
 619                      },
 620                    {join => {bin_vers => {src_ver => 'src_pkg'}},
 621                     columns => ['id'],
 622                     group_by => ['me.id'],
 623                    });
 624          $rs = $rs->search({-or => {'bug_binpackages.bin_pkg' =>
 625                                    { -in => $bin_pkgs_rs->get_column('id')->as_query},
 626                                     'bug_srcpackages.src_pkg' =>
 627                                    { -in => $bin_pkgs_rs->get_column('id')->as_query},
 628                                     'me.unknown_package' =>
 629                                     [make_list($param{src})],
 630                                    },
 631                            },
 632                           {join => ['bug_binpackages',
 633                                     'bug_srcpackages',
 634                                    ]}
 635                           );
 636      }
 637      # tags are very odd, because we must handle usertags.
 638      if (exists $param{tag}) {
 639          # bugs from usertags which matter
 640          my %bugs_matching_usertags;
 641          for my $bug (make_list(grep {defined $_ }
 642                                 @{$param{usertags}}{make_list($param{tag})})) {
 643              $bugs_matching_usertags{$bug} = 1;
 644          }
 645          # we want all bugs which either match the tag name given in
 646          # param, or have a usertag set which matches one of the tag
 647          # names given in param.
 648          $rs = $rs->search({-or => {map {('tag.tag' => $_)}
 649                                     make_list($param{tag}),
 650                                     map {('me.id' => $_)}
 651                                     keys %bugs_matching_usertags
 652                                    },
 653                            },
 654                           {join => {bug_tags => 'tag'}});
 655      }
 656      if (exists $param{bugs}) {
 657          $rs = $rs->search({-or => {map {('me.id' => $_)}
 658                                     make_list($param{bugs})}
 659                            });
 660      }
 661      # handle archive
 662      if (defined $param{archive} and $param{archive} ne 'both') {
 663          $rs = $rs->search({'me.archived' => $param{archive}});
 664      }
 665      return $rs->get_column('id')->all();
 666 }
 667
 668
 669 =head2 get_bugs_flatfile
 670
 671 This is the fallback search routine. It should be able to complete all
 672 searches. [Or at least, that's the idea.]
 673
 674 =cut
 675
 676 state $_get_bugs_flatfile_options =
 677    {hash_slice(%_get_bugs_common_options,
 678                map {$_ eq 'dist'?():($_)} keys %_get_bugs_common_options
 679               )
 680    };
 681
 682 sub get_bugs_flatfile{
 683      my %param = validate_with(params => \@_,
 684                                spec   => $_get_bugs_flatfile_options
 685                               );
 686      my $flatfile;
 687      if ($param{archive}) {
 688           $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
 689                or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
 690      }
 691      else {
 692           $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
 693                or die "Unable to open $config{spool_dir}/index.db for reading: $!";
 694      }
 695      my %usertag_bugs;
 696      if (exists $param{tag} and exists $param{usertags}) {
 697           # This complex slice makes a hash with the bugs which have the
 698           # usertags passed in $param{tag} set.
 699           @usertag_bugs{make_list(@{$param{usertags}}{make_list($param{tag})})
 700                         } = (1) x make_list(@{$param{usertags}}{make_list($param{tag})});
 701      }
 702      my $unmaintained_packages = 0;
 703      # unmaintained packages is a special case
 704      my @maints = make_list(exists $param{maint}?$param{maint}:[]);
 705      $param{maint} = [];
 706      for my $maint (@maints) {
 707           if (defined $maint and $maint eq '' and not $unmaintained_packages) {
 708                $unmaintained_packages = 1;
 709                our %maintainers = %{getmaintainers()};
 710                $param{function} = [(exists $param{function}?
 711                                     (ref $param{function}?@{$param{function}}:$param{function}):()),
 712                                    sub {my %d=@_;
 713                                         foreach my $try (make_list($d{"pkg"})) {
 714                                              next unless length $try;
 715                                              ($try) = $try =~ m/^(?:src:)?(.+)/;
 716                                              return 1 if not exists $maintainers{$try};
 717                                         }
 718                                         return 0;
 719                                    }
 720                                   ];
 721           }
 722           elsif (defined $maint and $maint ne '') {
 723                push @{$param{maint}},$maint;
 724           }
 725      }
 726      # We handle src packages, maint and maintenc by mapping to the
 727      # appropriate binary packages, then removing all packages which
 728      # don't match all queries
 729      my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
 730                                                qw(package src maint)
 731                                               );
 732      if (exists $param{package} or
 733          exists $param{src} or
 734          exists $param{maint}) {
 735           delete @param{qw(maint src)};
 736           $param{package} = [@packages] if @packages;
 737      }
 738      my $grep_bugs = 0;
 739      my %bugs;
 740      if (exists $param{bugs}) {
 741           $bugs{$_} = 1 for make_list($param{bugs});
 742           $grep_bugs = 1;
 743      }
 744      # These queries have to be handled by get_bugs_by_idx
 745      if (exists $param{owner}
 746          or exists $param{correspondent}
 747          or exists $param{affects}) {
 748           $bugs{$_} = 1 for get_bugs_by_idx(map {exists $param{$_}?($_,$param{$_}):()}
 749                                             qw(owner correspondent affects),
 750                                            );
 751           $grep_bugs = 1;
 752      }
 753      my @bugs;
 754      BUG: while (<$flatfile>) {
 755           next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*(.*)\s*\]\s+(\w+)\s+(.*)$/;
 756           my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7);
 757           next if $grep_bugs and not exists $bugs{$bug};
 758           if (exists $param{package}) {
 759                my @packages = splitpackages($pkg);
 760                next unless grep { my $pkg_list = $_;
 761                                   grep {$pkg_list eq $_} make_list($param{package})
 762                              } @packages;
 763           }
 764           if (exists $param{src}) {
 765                my @src_packages = map { getsrcpkgs($_)} make_list($param{src});
 766                my @packages = splitpackages($pkg);
 767                next unless grep { my $pkg_list = $_;
 768                                   grep {$pkg_list eq $_} @packages
 769                              } @src_packages;
 770           }
 771           if (exists $param{submitter}) {
 772                my @p_addrs = map {lc($_->address)}
 773                     map {getparsedaddrs($_)}
 774                          make_list($param{submitter});
 775                my @f_addrs = map {$_->address}
 776                     getparsedaddrs($submitter||'');
 777                next unless grep { my $f_addr = $_;
 778                                   grep {$f_addr eq $_} @p_addrs
 779                              } @f_addrs;
 780           }
 781           next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity});
 782           next if exists $param{status} and not grep {$status eq $_} make_list($param{status});
 783           if (exists $param{tag}) {
 784                my $bug_ok = 0;
 785                # either a normal tag, or a usertag must be set
 786                $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug};
 787                my @bug_tags = split ' ', $tags;
 788                $bug_ok = 1 if grep {my $bug_tag = $_;
 789                                     grep {$bug_tag eq $_} make_list($param{tag});
 790                                } @bug_tags;
 791                next unless $bug_ok;
 792           }
 793           # We do this last, because a function may be slow...
 794           if (exists $param{function}) {
 795                my @bug_tags = split ' ', $tags;
 796                my @packages = splitpackages($pkg);
 797                my $package = (@packages > 1)?\@packages:$packages[0];
 798                for my $function (make_list($param{function})) {
 799                     next BUG unless
 800                          $function->(pkg       => $package,
 801                                      bug       => $bug,
 802                                      status    => $status,
 803                                      submitter => $submitter,
 804                                      severity  => $severity,
 805                                      tags      => \@bug_tags,
 806                                     );
 807                }
 808           }
 809           push @bugs, $bug;
 810      }
 811      return @bugs;
 812 }
 813
 814 =head1 PRIVATE FUNCTIONS
 815
 816 =head2 __handle_pkg_src_and_maint
 817
 818      my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
 819                                                qw(package src maint)
 820                                               );
 821
 822 Turn package/src/maint into a list of packages
 823
 824 =cut
 825
 826 sub __handle_pkg_src_and_maint{
 827      my %param = validate_with(params => \@_,
 828                                spec   => {package   => {type => SCALAR|ARRAYREF,
 829                                                         optional => 1,
 830                                                        },
 831                                           src       => {type => SCALAR|ARRAYREF,
 832                                                         optional => 1,
 833                                                        },
 834                                           maint     => {type => SCALAR|ARRAYREF,
 835                                                         optional => 1,
 836                                                        },
 837                                          },
 838                                allow_extra => 1,
 839                               );
 840
 841      my @packages;
 842      @packages = make_list($param{package}) if exists $param{package};
 843      my $package_keys = @packages?1:0;
 844      my %packages;
 845      @packages{@packages} = (1) x @packages;
 846      if (exists $param{src}) {
 847           # We only want to increment the number of keys if there is
 848           # something to match
 849           my $key_inc = 0;
 850           # in case there are binaries with the same name as the
 851           # source
 852           my %_temp_p = ();
 853           for my $package ((map {getsrcpkgs($_)} make_list($param{src}))) {
 854                $packages{$package}++ unless exists $_temp_p{$package};
 855                $_temp_p{$package} = 1;
 856                $key_inc=1;
 857           }
 858           for my $package (make_list($param{src})) {
 859                $packages{"src:$package"}++ unless exists $_temp_p{"src:$package"};
 860                $_temp_p{"src:$package"} = 1;
 861                $key_inc=1;
 862                # As a temporary hack, we will also include $param{src}
 863                # in this list for packages passed which do not have a
 864                # corresponding binary package
 865                if (not exists getpkgsrc()->{$package}) {
 866                    $packages{$package}++ unless exists $_temp_p{$package};
 867                    $_temp_p{$package} = 1;
 868                }
 869           }
 870           $package_keys += $key_inc;
 871      }
 872      if (exists $param{maint}) {
 873           my $key_inc = 0;
 874           my %_temp_p = ();
 875           for my $package (package_maintainer(maintainer=>$param{maint})) {
 876                $packages{$package}++ unless exists $_temp_p{$package};
 877                $_temp_p{$package} = 1;
 878                $key_inc = 1;
 879           }
 880           $package_keys += $key_inc;
 881      }
 882      return grep {$packages{$_} >= $package_keys} keys %packages;
 883 }
 884
 885 state $field_match = {
 886     'subject' => \&__contains_field_match,
 887     'tags' => sub {
 888         my ($field, $values, $status) = @_;
 889         my %values = map {$_=>1} @$values;
 890         foreach my $t (split /\s+/, $status->{$field}) {
 891             return 1 if (defined $values{$t});
 892         }
 893         return 0;
 894     },
 895     'severity' => \&__exact_field_match,
 896     'pending' => \&__exact_field_match,
 897     'package' => \&__exact_field_match,
 898     'originator' => \&__contains_field_match,
 899     'forwarded' => \&__contains_field_match,
 900     'owner' => \&__contains_field_match,
 901 };
 902
 903 sub __bug_matches {
 904     my ($hash, $status) = @_;
 905     foreach my $key( keys( %$hash ) ) {
 906         my $value = $hash->{$key};
 907         next unless exists $field_match->{$key};
 908         my $sub = $field_match->{$key};
 909         if (not defined $sub) {
 910             die "No defined subroutine for key: $key";
 911         }
 912         return 1 if ($sub->($key, $value, $status));
 913     }
 914     return 0;
 915 }
 916
 917 sub __exact_field_match {
 918     my ($field, $values, $status) = @_;
 919     my @values = @$values;
 920     my @ret = grep {$_ eq $status->{$field} } @values;
 921     $#ret != -1;
 922 }
 923
 924 sub __contains_field_match {
 925     my ($field, $values, $status) = @_;
 926     foreach my $data (@$values) {
 927         return 1 if (index($status->{$field}, $data) > -1);
 928     }
 929     return 0;
 930 }
 931
 932
 933
 934
 935
 936 1;
 937
 938 __END__