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));
  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);
  57 use Debbugs::Packages qw(getsrcpkgs);
  58 use Debbugs::Common qw(getparsedaddrs getmaintainers getmaintainers_reverse make_list);
  59 use Fcntl qw(O_RDONLY);
  60 use MLDBM qw(DB_File Storable);
  61
  62 =head2 get_bugs
  63
  64      get_bugs()
  65
  66 =head3 Parameters
  67
  68 The following parameters can either be a single scalar or a reference
  69 to an array. The parameters are ANDed together, and the elements of
  70 arrayrefs are a parameter are ORed. Future versions of this may allow
  71 for limited regular expressions, and/or more complex expressions.
  72
  73 =over
  74
  75 =item package -- name of the binary package
  76
  77 =item src -- name of the source package
  78
  79 =item maint -- address of the maintainer
  80
  81 =item submitter -- address of the submitter
  82
  83 =item severity -- severity of the bug
  84
  85 =item status -- status of the bug
  86
  87 =item tag -- bug tags
  88
  89 =item owner -- owner of the bug
  90
  91 =item dist -- distribution (I don't know about this one yet)
  92
  93 =item bugs -- list of bugs to search within
  94
  95 =item function -- see description below
  96
  97 =back
  98
  99 =head3 Special options
 100
 101 The following options are special options used to modulate how the
 102 searches are performed.
 103
 104 =over
 105
 106 =item archive -- whether to search archived bugs or normal bugs;
 107 defaults to false. As a special case, if archive is 'both', but
 108 archived and unarchived bugs are returned.
 109
 110 =item usertags -- set of usertags and the bugs they are applied to
 111
 112 =back
 113
 114
 115 =head3 Subsidiary routines
 116
 117 All subsidiary routines get passed exactly the same set of options as
 118 get_bugs. If for some reason they are unable to handle the options
 119 passed (for example, they don't have the right type of index for the
 120 type of selection) they should die as early as possible. [Using
 121 Params::Validate and/or die when files don't exist makes this fairly
 122 trivial.]
 123
 124 This function will then immediately move on to the next subroutine,
 125 giving it the same arguments.
 126
 127 =head3 function
 128
 129 This option allows you to provide an arbitrary function which will be
 130 given the information in the index.db file. This will be super, super
 131 slow, so only do this if there's no other way to write the search.
 132
 133 You'll be given a list (which you can turn into a hash) like the
 134 following:
 135
 136  (pkg => ['a','b'], # may be a scalar (most common)
 137   bug => 1234,
 138   status => 'pending',
 139   submitter => 'boo@baz.com',
 140   severity => 'serious',
 141   tags => ['a','b','c'], # may be an empty arrayref
 142  )
 143
 144 The function should return 1 if the bug should be included; 0 if the
 145 bug should not.
 146
 147 =cut
 148
 149 sub get_bugs{
 150      my %param = validate_with(params => \@_,
 151                                spec   => {package   => {type => SCALAR|ARRAYREF,
 152                                                         optional => 1,
 153                                                        },
 154                                           src       => {type => SCALAR|ARRAYREF,
 155                                                         optional => 1,
 156                                                        },
 157                                           maint     => {type => SCALAR|ARRAYREF,
 158                                                         optional => 1,
 159                                                        },
 160                                           submitter => {type => SCALAR|ARRAYREF,
 161                                                         optional => 1,
 162                                                        },
 163                                           severity  => {type => SCALAR|ARRAYREF,
 164                                                         optional => 1,
 165                                                        },
 166                                           status    => {type => SCALAR|ARRAYREF,
 167                                                         optional => 1,
 168                                                        },
 169                                           tag       => {type => SCALAR|ARRAYREF,
 170                                                         optional => 1,
 171                                                        },
 172                                           owner     => {type => SCALAR|ARRAYREF,
 173                                                         optional => 1,
 174                                                        },
 175                                           dist      => {type => SCALAR|ARRAYREF,
 176                                                         optional => 1,
 177                                                        },
 178                                           function  => {type => CODEREF,
 179                                                         optional => 1,
 180                                                        },
 181                                           bugs      => {type => SCALAR|ARRAYREF,
 182                                                         optional => 1,
 183                                                        },
 184                                           archive   => {type => BOOLEAN|SCALAR,
 185                                                         default => 0,
 186                                                        },
 187                                           usertags  => {type => HASHREF,
 188                                                         optional => 1,
 189                                                        },
 190                                          },
 191                               );
 192
 193      # Normalize options
 194      my %options = %param;
 195      my @bugs;
 196      if ($options{archive} eq 'both') {
 197           push @bugs, get_bugs(%options,archive=>0);
 198           push @bugs, get_bugs(%options,archive=>1);
 199           my %bugs;
 200           @bugs{@bugs} = @bugs;
 201           return keys %bugs;
 202      }
 203      # A configuration option will set an array that we'll use here instead.
 204      for my $routine (qw(Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) {
 205           my ($package) = $routine =~ m/^(.+)\:\:/;
 206           eval "use $package;";
 207           if ($@) {
 208                # We output errors here because using an invalid function
 209                # in the configuration file isn't something that should
 210                # be done.
 211                warn "use $package failed with $@";
 212                next;
 213           }
 214           @bugs = eval "${routine}(\%options)";
 215           if ($@) {
 216
 217                # We don't output errors here, because failure here
 218                # via die may be a perfectly normal thing.
 219                print STDERR "$@" if $DEBUG;
 220                next;
 221           }
 222           last;
 223      }
 224      # If no one succeeded, die
 225      if ($@) {
 226           die "$@";
 227      }
 228      return @bugs;
 229 }
 230
 231 =head2 count_bugs
 232
 233      count_bugs(function => sub {...})
 234
 235 Uses a subroutine to classify bugs into categories and return the
 236 number of bugs which fall into those categories
 237
 238 =cut
 239
 240 sub count_bugs {
 241      my %param = validate_with(params => \@_,
 242                                spec   => {function => {type => CODEREF,
 243                                                       },
 244                                           archive  => {type => BOOLEAN,
 245                                                        default => 0,
 246                                                       },
 247                                          },
 248                               );
 249      my $flatfile;
 250      if ($param{archive}) {
 251           $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
 252                or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
 253      }
 254      else {
 255           $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
 256                or die "Unable to open $config{spool_dir}/index.db for reading: $!";
 257      }
 258      my %count = ();
 259      while(<$flatfile>) {
 260           if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) {
 261                my @x = $param{function}->(pkg       => $1,
 262                                           bug       => $2,
 263                                           status    => $4,
 264                                           submitter => $5,
 265                                           severity  => $6,
 266                                           tags      => $7,
 267                                          );
 268                local $_;
 269                $count{$_}++ foreach @x;
 270           }
 271      }
 272      close $flatfile;
 273      return %count;
 274 }
 275
 276 =head2 newest_bug
 277
 278      my $bug = newest_bug();
 279
 280 Returns the bug number of the newest bug, which is nextnumber-1.
 281
 282 =cut
 283
 284 sub newest_bug {
 285      my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r')
 286           or die "Unable to open $config{spool_dir}nextnumber for reading: $!";
 287      local $/;
 288      my $next_number = <$nn_fh>;
 289      close $nn_fh;
 290      chomp $next_number;
 291      return $next_number+0;
 292 }
 293
 294
 295 =head2 get_bugs_by_idx
 296
 297 This routine uses the by-$index.idx indicies to try to speed up
 298 searches.
 299
 300
 301 =cut
 302
 303 sub get_bugs_by_idx{
 304      my %param = validate_with(params => \@_,
 305                                spec   => {package   => {type => SCALAR|ARRAYREF,
 306                                                         optional => 1,
 307                                                        },
 308                                           submitter => {type => SCALAR|ARRAYREF,
 309                                                         optional => 1,
 310                                                        },
 311                                           severity  => {type => SCALAR|ARRAYREF,
 312                                                         optional => 1,
 313                                                        },
 314                                           tag       => {type => SCALAR|ARRAYREF,
 315                                                         optional => 1,
 316                                                        },
 317                                           archive   => {type => BOOLEAN,
 318                                                         default => 0,
 319                                                        },
 320                                           owner     => {type => SCALAR|ARRAYREF,
 321                                                         optional => 1,
 322                                                        },
 323                                           src       => {type => SCALAR|ARRAYREF,
 324                                                         optional => 1,
 325                                                        },
 326                                           maint     => {type => SCALAR|ARRAYREF,
 327                                                         optional => 1,
 328                                                        },
 329                                          },
 330                               );
 331      my %bugs = ();
 332
 333      # We handle src packages, maint and maintenc by mapping to the
 334      # appropriate binary packages, then removing all packages which
 335      # don't match all queries
 336      my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
 337                                                qw(package src maint)
 338                                               );
 339      if (exists $param{package} or
 340          exists $param{src} or
 341          exists $param{maint}) {
 342           delete @param{qw(maint src)};
 343           $param{package} = [@packages];
 344      }
 345      my $keys = keys(%param) - 1;
 346      die "Need at least 1 key to search by" unless $keys;
 347      my $arc = $param{archive} ? '-arc':'';
 348      my %idx;
 349      for my $key (grep {$_ ne 'archive'} keys %param) {
 350           my $index = $key;
 351           $index = 'submitter-email' if $key eq 'submitter';
 352           $index = "$config{spool_dir}/by-${index}${arc}.idx";
 353           tie(%idx, MLDBM => $index, O_RDONLY)
 354                or die "Unable to open $index: $!";
 355           for my $search (make_list($param{$key})) {
 356                next unless defined $idx{$search};
 357                for my $bug (keys %{$idx{$search}}) {
 358                     # increment the number of searches that this bug matched
 359                     $bugs{$bug}++;
 360                }
 361           }
 362           untie %idx or die 'Unable to untie %idx';
 363      }
 364      # Throw out results that do not match all of the search specifications
 365      return map {$keys <= $bugs{$_}?($_):()} keys %bugs;
 366 }
 367
 368
 369 =head2 get_bugs_flatfile
 370
 371 This is the fallback search routine. It should be able to complete all
 372 searches. [Or at least, that's the idea.]
 373
 374 =cut
 375
 376 sub get_bugs_flatfile{
 377      my %param = validate_with(params => \@_,
 378                                spec   => {package   => {type => SCALAR|ARRAYREF,
 379                                                         optional => 1,
 380                                                        },
 381                                           src       => {type => SCALAR|ARRAYREF,
 382                                                         optional => 1,
 383                                                        },
 384                                           maint     => {type => SCALAR|ARRAYREF,
 385                                                         optional => 1,
 386                                                        },
 387                                           submitter => {type => SCALAR|ARRAYREF,
 388                                                         optional => 1,
 389                                                        },
 390                                           severity  => {type => SCALAR|ARRAYREF,
 391                                                         optional => 1,
 392                                                        },
 393                                           status    => {type => SCALAR|ARRAYREF,
 394                                                         optional => 1,
 395                                                        },
 396                                           tag       => {type => SCALAR|ARRAYREF,
 397                                                         optional => 1,
 398                                                        },
 399 # not yet supported
 400 #                                         owner     => {type => SCALAR|ARRAYREF,
 401 #                                                       optional => 1,
 402 #                                                      },
 403 #                                         dist      => {type => SCALAR|ARRAYREF,
 404 #                                                       optional => 1,
 405 #                                                      },
 406                                           archive   => {type => BOOLEAN,
 407                                                         default => 1,
 408                                                        },
 409                                           usertags  => {type => HASHREF,
 410                                                         optional => 1,
 411                                                        },
 412                                           function  => {type => CODEREF,
 413                                                         optional => 1,
 414                                                        },
 415                                          },
 416                               );
 417      my $flatfile;
 418      if ($param{archive}) {
 419           $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r')
 420                or die "Unable to open $config{spool_dir}/index.archive for reading: $!";
 421      }
 422      else {
 423           $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r')
 424                or die "Unable to open $config{spool_dir}/index.db for reading: $!";
 425      }
 426      my %usertag_bugs;
 427      if (exists $param{tag} and exists $param{usertags}) {
 428
 429           # This complex slice makes a hash with the bugs which have the
 430           # usertags passed in $param{tag} set.
 431           @usertag_bugs{map {@{$_}}
 432                              @{$param{usertags}}{make_list($param{tag})}
 433                         } = (1) x @{$param{usertags}}{make_list($param{tag})}
 434      }
 435      # We handle src packages, maint and maintenc by mapping to the
 436      # appropriate binary packages, then removing all packages which
 437      # don't match all queries
 438      my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()}
 439                                                qw(package src maint)
 440                                               );
 441      if (exists $param{package} or
 442          exists $param{src} or
 443          exists $param{maint}) {
 444           delete @param{qw(maint src)};
 445           $param{package} = [@packages];
 446      }
 447      my @bugs;
 448      while (<$flatfile>) {
 449           next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/;
 450           my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7);
 451           next if exists $param{bugs} and not grep {$bug == $_} make_list($param{bugs});
 452           if (exists $param{package}) {
 453                my @packages = splitpackages($pkg);
 454                next unless grep { my $pkg_list = $_;
 455                                   grep {$pkg_list eq $_} make_list($param{package})
 456                              } @packages;
 457           }
 458           if (exists $param{src}) {
 459                my @src_packages = map { getsrcpkgs($_)} make_list($param{src});
 460                my @packages = splitpackages($pkg);
 461                next unless grep { my $pkg_list = $_;
 462                                   grep {$pkg_list eq $_} @packages
 463                              } @src_packages;
 464           }
 465           if (exists $param{submitter}) {
 466                my @p_addrs = map {lc($_->address)}
 467                     map {getparsedaddrs($_)}
 468                          make_list($param{submitter});
 469                my @f_addrs = map {$_->address}
 470                     getparsedaddrs($submitter||'');
 471                next unless grep { my $f_addr = $_;
 472                                   grep {$f_addr eq $_} @p_addrs
 473                              } @f_addrs;
 474           }
 475           next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity});
 476           next if exists $param{status} and not grep {$status eq $_} make_list($param{status});
 477           if (exists $param{tag}) {
 478                my $bug_ok = 0;
 479                # either a normal tag, or a usertag must be set
 480                $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug};
 481                my @bug_tags = split ' ', $tags;
 482                $bug_ok = 1 if grep {my $bug_tag = $_;
 483                                     grep {$bug_tag eq $_} make_list($param{tag});
 484                                } @bug_tags;
 485                next unless $bug_ok;
 486           }
 487           # We do this last, because a function may be slow...
 488           if (exists $param{function}) {
 489                my @bug_tags = split ' ', $tags;
 490                my @packages = splitpackages($pkg);
 491                my $package = (@packages > 1)?\@packages:$packages[0];
 492                next unless
 493                     $param{function}->(pkg       => $package,
 494                                        bug       => $bug,
 495                                        status    => $status,
 496                                        submitter => $submitter,
 497                                        severity  => $severity,
 498                                        tags      => \@bug_tags,
 499                                       );
 500           }
 501           push @bugs, $bug;
 502      }
 503      return @bugs;
 504 }
 505
 506 sub __handle_pkg_src_and_maint{
 507      my %param = validate_with(params => \@_,
 508                                spec   => {package   => {type => SCALAR|ARRAYREF,
 509                                                         optional => 1,
 510                                                        },
 511                                           src       => {type => SCALAR|ARRAYREF,
 512                                                         optional => 1,
 513                                                        },
 514                                           maint     => {type => SCALAR|ARRAYREF,
 515                                                         optional => 1,
 516                                                        },
 517                                          },
 518                                allow_extra => 1,
 519                               );
 520
 521      my @packages;
 522      @packages = make_list($param{package}) if exists $param{package};
 523      my $package_keys = @packages?1:0;
 524      my %packages;
 525      @packages{@packages} = (1) x @packages;
 526      if (exists $param{src}) {
 527           # We only want to increment the number of keys if there is
 528           # something to match
 529           my $key_inc = 0;
 530           for my $package ((map { getsrcpkgs($_)} make_list($param{src})),make_list($param{src})) {
 531                $packages{$package}++;
 532                $key_inc=1;
 533           }
 534           $package_keys += $key_inc;
 535      }
 536      if (exists $param{maint}) {
 537           my $key_inc = 0;
 538           my $maint_rev = getmaintainers_reverse();
 539           for my $package (map { exists $maint_rev->{$_}?@{$maint_rev->{$_}}:()}
 540                            make_list($param{maint})) {
 541                $packages{$package}++;
 542                $key_inc = 1;
 543           }
 544           $package_keys += $key_inc;
 545      }
 546      return grep {$packages{$_} >= $package_keys} keys %packages;
 547 }
 548
 549
 550 1;
 551
 552 __END__