Debbugs/Status.pm

   1
   2 package Debbugs::Status;
   3
   4 =head1 NAME
   5
   6 Debbugs::Status -- Routines for dealing with summary and status files
   7
   8 =head1 SYNOPSIS
   9
  10 use Debbugs::Status;
  11
  12
  13 =head1 DESCRIPTION
  14
  15 This module is a replacement for the parts of errorlib.pl which write
  16 and read status and summary files.
  17
  18 It also contains generic routines for returning information about the
  19 status of a particular bug
  20
  21 =head1 FUNCTIONS
  22
  23 =cut
  24
  25 use warnings;
  26 use strict;
  27 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  28 use base qw(Exporter);
  29
  30 use Params::Validate qw(validate_with :types);
  31 use Debbugs::Common qw(:util :lock :quit);
  32 use Debbugs::Config qw(:config);
  33 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
  34 use Debbugs::Packages qw(makesourceversions getversions binarytosource);
  35 use Debbugs::Versions;
  36 use Debbugs::Versions::Dpkg;
  37 use POSIX qw(ceil);
  38
  39
  40 BEGIN{
  41      $VERSION = 1.00;
  42      $DEBUG = 0 unless defined $DEBUG;
  43
  44      @EXPORT = ();
  45      %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable),
  46                                 qw(isstrongseverity),
  47                                ],
  48                      read   => [qw(readbug read_bug lockreadbug)],
  49                      write  => [qw(writebug makestatus unlockwritebug)],
  50                      versions => [qw(addfoundversions addfixedversions),
  51                                   qw(removefoundversions)
  52                                  ],
  53                     );
  54      @EXPORT_OK = ();
  55      Exporter::export_ok_tags(qw(status read write versions));
  56      $EXPORT_TAGS{all} = [@EXPORT_OK];
  57 }
  58
  59
  60 =head2 readbug
  61
  62      readbug($bug_num,$location)
  63      readbug($bug_num)
  64
  65 Reads a summary file from the archive given a bug number and a bug
  66 location. Valid locations are those understood by L</getbugcomponent>
  67
  68 =cut
  69
  70
  71 my %fields = (originator     => 'submitter',
  72               date           => 'date',
  73               subject        => 'subject',
  74               msgid          => 'message-id',
  75               'package'      => 'package',
  76               keywords       => 'tags',
  77               done           => 'done',
  78               forwarded      => 'forwarded-to',
  79               mergedwith     => 'merged-with',
  80               severity       => 'severity',
  81               owner          => 'owner',
  82               found_versions => 'found-in',
  83               found_date     => 'found-date',
  84               fixed_versions => 'fixed-in',
  85               fixed_date     => 'fixed-date',
  86               blocks         => 'blocks',
  87               blockedby      => 'blocked-by',
  88              );
  89
  90 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
  91 my @rfc1522_fields = qw(originator subject done forwarded owner);
  92
  93 sub readbug {
  94      return read_bug(bug => $_[0],
  95                      (@_ > 1)?(location => $_[1]):()
  96                     );
  97 }
  98
  99 =head2 read_bug
 100
 101      read_bug(bug => $bug_num,
 102               location => 'archive',
 103              );
 104      read_bug(summary => 'path/to/bugnum.summary');
 105      read_bug($bug_num);
 106
 107 A more complete function than readbug; it enables you to pass a full
 108 path to the summary file instead of the bug number and/or location.
 109
 110 =head3 Options
 111
 112 =over
 113
 114 =item bug -- the bug number
 115
 116 =item location -- optional location which is passed to getbugcomponent
 117
 118 =item summary -- complete path to the .summary file which will be read
 119
 120 =back
 121
 122 One of C<bug> or C<summary> must be passed. This function will return
 123 undef on failure, and will die if improper arguments are passed.
 124
 125 =cut
 126
 127 sub read_bug{
 128     if (@_ == 1) {
 129          unshift @_, 'bug';
 130     }
 131     my %param = validate_with(params => \@_,
 132                               spec   => {bug => {type => SCALAR,
 133                                                  optional => 1,
 134                                                  regex    => qr/^\d+/,
 135                                                 },
 136                                          location => {type => SCALAR|UNDEF,
 137                                                       optional => 1,
 138                                                      },
 139                                          summary  => {type => SCALAR,
 140                                                       optional => 1,
 141                                                      },
 142                                         },
 143                              );
 144     die "One of bug or summary must be passed to read_bug"
 145          if not exists $param{bug} and not exists $param{summary};
 146     my $status;
 147     if (not defined $param{summary}) {
 148          my ($lref, $location) = @param{qw(bug location)};
 149          if (not defined $location) {
 150               $location = getbuglocation($lref,'summary');
 151               return undef if not defined $location;
 152          }
 153          $status = getbugcomponent($lref, 'summary', $location);
 154          return undef unless defined $status;
 155     }
 156     else {
 157          $status = $param{summary};
 158     }
 159     my $status_fh = new IO::File $status, 'r' or
 160          warn "Unable to open $status for reading: $!" and return undef;
 161
 162     my %data;
 163     my @lines;
 164     my $version = 2;
 165     local $_;
 166
 167     while (<$status_fh>) {
 168         chomp;
 169         push @lines, $_;
 170         $version = $1 if /^Format-Version: ([0-9]+)/i;
 171     }
 172
 173     # Version 3 is the latest format version currently supported.
 174     return undef if $version > 3;
 175
 176     my %namemap = reverse %fields;
 177     for my $line (@lines) {
 178         if ($line =~ /(\S+?): (.*)/) {
 179             my ($name, $value) = (lc $1, $2);
 180             $data{$namemap{$name}} = $value if exists $namemap{$name};
 181         }
 182     }
 183     for my $field (keys %fields) {
 184         $data{$field} = '' unless exists $data{$field};
 185     }
 186
 187     $data{severity} = $config{default_severity} if $data{severity} eq '';
 188     for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
 189          $data{$field} = [split ' ', $data{$field}];
 190     }
 191     for my $field (qw(found fixed)) {
 192          # create the found/fixed hashes which indicate when a
 193          # particular version was marked found or marked fixed.
 194          @{$data{$field}}{@{$data{"${field}_versions"}}} =
 195               (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
 196                @{$data{"${field}_date"}});
 197     }
 198
 199     if ($version < 3) {
 200         for my $field (@rfc1522_fields) {
 201             $data{$field} = decode_rfc1522($data{$field});
 202         }
 203     }
 204
 205     return \%data;
 206 }
 207
 208 =head2 lockreadbug
 209
 210      lockreadbug($bug_num,$location)
 211
 212 Performs a filelock, then reads the bug; the bug is unlocked if the
 213 return is undefined, otherwise, you need to call unfilelock or
 214 unlockwritebug.
 215
 216 See readbug above for information on what this returns
 217
 218 =cut
 219
 220 sub lockreadbug {
 221     my ($lref, $location) = @_;
 222     &filelock("lock/$lref");
 223     my $data = read_bug(bug => $lref, location => $location);
 224     &unfilelock unless defined $data;
 225     return $data;
 226 }
 227
 228 my @v1fieldorder = qw(originator date subject msgid package
 229                       keywords done forwarded mergedwith severity);
 230
 231 =head2 makestatus
 232
 233      my $content = makestatus($status,$version)
 234      my $content = makestatus($status);
 235
 236 Creates the content for a status file based on the $status hashref
 237 passed.
 238
 239 Really only useful for writebug
 240
 241 Currently defaults to version 2 (non-encoded rfc1522 names) but will
 242 eventually default to version 3. If you care, you should specify a
 243 version.
 244
 245 =cut
 246
 247 sub makestatus {
 248     my ($data,$version) = @_;
 249     $version = 2 unless defined $version;
 250
 251     my $contents = '';
 252
 253     my %newdata = %$data;
 254     for my $field (qw(found fixed)) {
 255          if (exists $newdata{$field}) {
 256               $newdata{"${field}_date"} =
 257                    [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}];
 258          }
 259     }
 260
 261     for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
 262          $newdata{$field} = join ' ', @{$newdata{$field}||[]};
 263     }
 264
 265     if ($version < 3) {
 266         for my $field (@rfc1522_fields) {
 267             $newdata{$field} = encode_rfc1522($newdata{$field});
 268         }
 269     }
 270
 271     if ($version == 1) {
 272         for my $field (@v1fieldorder) {
 273             if (exists $newdata{$field} and defined $newdata{$field}) {
 274                 $contents .= "$newdata{$field}\n";
 275             } else {
 276                 $contents .= "\n";
 277             }
 278         }
 279     } elsif ($version == 2 or $version == 3) {
 280         # Version 2 or 3. Add a file format version number for the sake of
 281         # further extensibility in the future.
 282         $contents .= "Format-Version: $version\n";
 283         for my $field (keys %fields) {
 284             if (exists $newdata{$field} and defined $newdata{$field}
 285                 and $newdata{$field} ne '') {
 286                 # Output field names in proper case, e.g. 'Merged-With'.
 287                 my $properfield = $fields{$field};
 288                 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
 289                 $contents .= "$properfield: $newdata{$field}\n";
 290             }
 291         }
 292     }
 293
 294     return $contents;
 295 }
 296
 297 =head2 writebug
 298
 299      writebug($bug_num,$status,$location,$minversion,$disablebughook)
 300
 301 Writes the bug status and summary files out.
 302
 303 Skips writting out a status file if minversion is 2
 304
 305 Does not call bughook if disablebughook is true.
 306
 307 =cut
 308
 309 sub writebug {
 310     my ($ref, $data, $location, $minversion, $disablebughook) = @_;
 311     my $change;
 312
 313     my %outputs = (1 => 'status', 2 => 'summary');
 314     for my $version (keys %outputs) {
 315         next if defined $minversion and $version < $minversion;
 316         my $status = getbugcomponent($ref, $outputs{$version}, $location);
 317         &quit("can't find location for $ref") unless defined $status;
 318         open(S,"> $status.new") || &quit("opening $status.new: $!");
 319         print(S makestatus($data, $version)) ||
 320             &quit("writing $status.new: $!");
 321         close(S) || &quit("closing $status.new: $!");
 322         if (-e $status) {
 323             $change = 'change';
 324         } else {
 325             $change = 'new';
 326         }
 327         rename("$status.new",$status) || &quit("installing new $status: $!");
 328     }
 329
 330     # $disablebughook is a bit of a hack to let format migration scripts use
 331     # this function rather than having to duplicate it themselves.
 332     &bughook($change,$ref,$data) unless $disablebughook;
 333 }
 334
 335 =head2 unlockwritebug
 336
 337      unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
 338
 339 Writes a bug, then calls unfilelock; see writebug for what these
 340 options mean.
 341
 342 =cut
 343
 344 sub unlockwritebug {
 345     writebug(@_);
 346     &unfilelock;
 347 }
 348
 349 =head1 VERSIONS
 350
 351 The following functions are exported with the :versions tag
 352
 353 =head2 addfoundversions
 354
 355      addfoundversions($status,$package,$version,$isbinary);
 356
 357
 358
 359 =cut
 360
 361
 362 sub addfoundversions {
 363     my $data = shift;
 364     my $package = shift;
 365     my $version = shift;
 366     my $isbinary = shift;
 367     return unless defined $version;
 368     undef $package if $package =~ m[(?:\s|/)];
 369     my $source = $package;
 370
 371     if (defined $package and $isbinary) {
 372         my @srcinfo = binarytosource($package, $version, undef);
 373         if (@srcinfo) {
 374             # We know the source package(s). Use a fully-qualified version.
 375             addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 376             return;
 377         }
 378         # Otherwise, an unqualified version will have to do.
 379         undef $source;
 380     }
 381
 382     # Strip off various kinds of brain-damage.
 383     $version =~ s/;.*//;
 384     $version =~ s/ *\(.*\)//;
 385     $version =~ s/ +[A-Za-z].*//;
 386
 387     foreach my $ver (split /[,\s]+/, $version) {
 388         my $sver = defined($source) ? "$source/$ver" : '';
 389         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
 390             push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
 391         }
 392         @{$data->{fixed_versions}} =
 393             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 394     }
 395 }
 396
 397 =head2 removefoundversions
 398
 399      removefoundversions($data,$package,$versiontoremove)
 400
 401 Removes found versions from $data
 402
 403 If a version is fully qualified (contains /) only versions matching
 404 exactly are removed. Otherwise, all versions matching the version
 405 number are removed.
 406
 407 Currently $package and $isbinary are entirely ignored, but accepted
 408 for backwards compatibilty.
 409
 410 =cut
 411
 412 sub removefoundversions {
 413     my $data = shift;
 414     my $package = shift;
 415     my $version = shift;
 416     my $isbinary = shift;
 417     return unless defined $version;
 418
 419     foreach my $ver (split /[,\s]+/, $version) {
 420          if ($ver =~ m{/}) {
 421               # fully qualified version
 422               @{$data->{found_versions}} =
 423                    grep {$_ ne $ver}
 424                         @{$data->{found_versions}};
 425          }
 426          else {
 427               # non qualified version; delete all matchers
 428               @{$data->{found_versions}} =
 429                    grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
 430                         @{$data->{found_versions}};
 431          }
 432     }
 433 }
 434
 435
 436 sub addfixedversions {
 437     my $data = shift;
 438     my $package = shift;
 439     my $version = shift;
 440     my $isbinary = shift;
 441     return unless defined $version;
 442     undef $package if $package =~ m[(?:\s|/)];
 443     my $source = $package;
 444
 445     if (defined $package and $isbinary) {
 446         my @srcinfo = binarytosource($package, $version, undef);
 447         if (@srcinfo) {
 448             # We know the source package(s). Use a fully-qualified version.
 449             addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 450             return;
 451         }
 452         # Otherwise, an unqualified version will have to do.
 453         undef $source;
 454     }
 455
 456     # Strip off various kinds of brain-damage.
 457     $version =~ s/;.*//;
 458     $version =~ s/ *\(.*\)//;
 459     $version =~ s/ +[A-Za-z].*//;
 460
 461     foreach my $ver (split /[,\s]+/, $version) {
 462         my $sver = defined($source) ? "$source/$ver" : '';
 463         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
 464             push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
 465         }
 466         @{$data->{found_versions}} =
 467             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 468     }
 469 }
 470
 471 sub removefixedversions {
 472     my $data = shift;
 473     my $package = shift;
 474     my $version = shift;
 475     my $isbinary = shift;
 476     return unless defined $version;
 477     undef $package if $package =~ m[(?:\s|/)];
 478     my $source = $package;
 479
 480     if (defined $package and $isbinary) {
 481         my @srcinfo = binarytosource($package, $version, undef);
 482         if (@srcinfo) {
 483             # We know the source package(s). Use a fully-qualified version.
 484             removefixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 485             return;
 486         }
 487         # Otherwise, an unqualified version will have to do.
 488         undef $source;
 489     }
 490
 491     foreach my $ver (split /[,\s]+/, $version) {
 492         my $sver = defined($source) ? "$source/$ver" : '';
 493         @{$data->{fixed_versions}} =
 494             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 495     }
 496 }
 497
 498
 499
 500 =head2 splitpackages
 501
 502      splitpackages($pkgs)
 503
 504 Split a package string from the status file into a list of package names.
 505
 506 =cut
 507
 508 sub splitpackages {
 509     my $pkgs = shift;
 510     return unless defined $pkgs;
 511     return map lc, split /[ \t?,()]+/, $pkgs;
 512 }
 513
 514
 515 =head2 bug_archiveable
 516
 517      bug_archiveable(bug => $bug_num);
 518
 519 Options
 520
 521 =over
 522
 523 =item bug -- bug number (required)
 524
 525 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
 526
 527 =item version -- Debbugs::Version information (optional)
 528
 529 =item days_until -- return days until the bug can be archived
 530
 531 =back
 532
 533 Returns 1 if the bug can be archived
 534 Returns 0 if the bug cannot be archived
 535
 536 If days_until is true, returns the number of days until the bug can be
 537 archived, -1 if it cannot be archived. 0 means that the bug can be
 538 archived the next time the archiver runs.
 539
 540 Returns undef on failure.
 541
 542 =cut
 543
 544 # This will eventually need to be fixed before we start using mod_perl
 545 my $version_cache = {};
 546 sub bug_archiveable{
 547      my %param = validate_with(params => \@_,
 548                                spec   => {bug => {type => SCALAR,
 549                                                   regex => qr/^\d+$/,
 550                                                  },
 551                                           status => {type => HASHREF,
 552                                                      optional => 1,
 553                                                     },
 554                                           days_until => {type => BOOLEAN,
 555                                                          default => 0,
 556                                                         },
 557                                          },
 558                               );
 559      # This is what we return if the bug cannot be archived.
 560      my $cannot_archive = $param{days_until}?-1:0;
 561      # read the status information
 562      my $status = $param{status};
 563      if (not exists $param{status} or not defined $status) {
 564           $status = read_bug(bug=>$param{bug});
 565           return undef if not defined $status;
 566      }
 567      # Bugs can be archived if they are
 568      # 1. Closed
 569      return $cannot_archive if not defined $status->{done} or not length $status->{done};
 570      # If we just are checking if the bug can be archived, we'll not even bother
 571      # checking the versioning information if the bug has been -done for less than 28 days.
 572      if (not $param{days_until} and $config{remove_age} >
 573          -M getbugcomponent($param{ref},'log')
 574         ) {
 575           return $cannot_archive;
 576      }
 577      # At this point, we have to get the versioning information for this bug.
 578      # We examine the set of distribution tags. If a bug has no distribution
 579      # tags set, we assume a default set, otherwise we use the tags the bug
 580      # has set.
 581
 582      # There must be fixed_versions for us to look at the versioning
 583      # information
 584      if (@{$status->{fixed_versions}}) {
 585           my %dist_tags;
 586           @dist_tags{@{$config{removal_distribution_tags}}} =
 587                (1) x @{$config{removal_distribution_tags}};
 588           my %dists;
 589           @dists{@{$config{removal_default_distribution_tags}}} =
 590                (1) x @{$config{removal_default_distribution_tags}};
 591           for my $tag (split ' ', $status->{tags}) {
 592                next unless $dist_tags{$tag};
 593                $dists{$tag} = 1;
 594           }
 595           my %source_versions;
 596           for my $dist (keys %dists){
 597                my @versions;
 598                @versions = getversions($status->{package},
 599                                        $dist,
 600                                        undef);
 601                # TODO: This should probably be handled further out for efficiency and
 602                # for more ease of distinguishing between pkg= and src= queries.
 603                my @sourceversions = makesourceversions($status->{package},
 604                                                        $dist,
 605                                                        @versions);
 606                @source_versions{@sourceversions} = (1) x @sourceversions;
 607           }
 608           if ('found' eq max_buggy(bug => $param{bug},
 609                                    sourceversions => [keys %source_versions],
 610                                    found          => $status->{found_versions},
 611                                    fixed          => $status->{fixed_versions},
 612                                    version_cache  => $version_cache,
 613                                    package        => $status->{package},
 614                                   )) {
 615                return $cannot_archive;
 616           }
 617      }
 618      # 6. at least 28 days have passed since the last action has occured or the bug was closed
 619      # XXX We still need some more work here before we actually can archive;
 620      # we really need to track when a bug was closed in a version.
 621      my $age = ceil($config{remove_age} - -M getbugcomponent($param{bug},'log'));
 622      if ($age > 0 ) {
 623           return $param{days_until}?$age:0;
 624      }
 625      else {
 626           return $param{days_until}?0:1;
 627      }
 628 }
 629
 630
 631 =head2 get_bug_status
 632
 633      my $status = get_bug_status(bug => $nnn);
 634
 635      my $status = get_bug_status($bug_num)
 636
 637 =head3 Options
 638
 639 =over
 640
 641 =item bug -- scalar bug number
 642
 643 =item status -- optional hashref of bug status as returned by readbug
 644 (can be passed to avoid rereading the bug information)
 645
 646 =item bug_index -- optional tied index of bug status infomration;
 647 currently not correctly implemented.
 648
 649 =item version -- optional version to check package status at
 650
 651 =item dist -- optional distribution to check package status at
 652
 653 =item arch -- optional architecture to check package status at
 654
 655 =item usertags -- optional hashref of usertags
 656
 657 =item sourceversion -- optional arrayref of source/version; overrides
 658 dist, arch, and version. [The entries in this array must be in the
 659 "source/version" format.] Eventually this can be used to for caching.
 660
 661 =back
 662
 663 Note: Currently the version information is cached; this needs to be
 664 changed before using this function in long lived programs.
 665
 666 =cut
 667
 668 sub get_bug_status {
 669      if (@_ == 1) {
 670           unshift @_, 'bug';
 671      }
 672      my %param = validate_with(params => \@_,
 673                                spec   => {bug       => {type => SCALAR,
 674                                                         regex => qr/^\d+$/,
 675                                                        },
 676                                           status    => {type => HASHREF,
 677                                                         optional => 1,
 678                                                        },
 679                                           bug_index => {type => OBJECT,
 680                                                         optional => 1,
 681                                                        },
 682                                           version   => {type => SCALAR,
 683                                                         optional => 1,
 684                                                        },
 685                                           dist       => {type => SCALAR,
 686                                                          optional => 1,
 687                                                         },
 688                                           arch       => {type => SCALAR,
 689                                                          optional => 1,
 690                                                         },
 691                                           usertags   => {type => HASHREF,
 692                                                          optional => 1,
 693                                                         },
 694                                           sourceversions => {type => ARRAYREF,
 695                                                              optional => 1,
 696                                                             },
 697                                          },
 698                               );
 699      my %status;
 700
 701      if (defined $param{bug_index} and
 702          exists $param{bug_index}{$param{bug}}) {
 703           %status = %{ $param{bug_index}{$param{bug}} };
 704           $status{pending} = $status{ status };
 705           $status{id} = $param{bug};
 706           return \%status;
 707      }
 708      if (defined $param{status}) {
 709           %status = %{$param{status}};
 710      }
 711      else {
 712           my $location = getbuglocation($param{bug}, 'summary');
 713           return {} if not length $location;
 714           %status = %{ readbug( $param{bug}, $location ) };
 715      }
 716      $status{id} = $param{bug};
 717
 718      if (defined $param{usertags}{$param{bug}}) {
 719           $status{keywords} = "" unless defined $status{keywords};
 720           $status{keywords} .= " " unless $status{keywords} eq "";
 721           $status{keywords} .= join(" ", @{$param{usertags}{$param{bug}}});
 722      }
 723      $status{tags} = $status{keywords};
 724      my %tags = map { $_ => 1 } split ' ', $status{tags};
 725
 726      $status{"package"} =~ s/\s*$//;
 727      $status{"package"} = 'unknown' if ($status{"package"} eq '');
 728      $status{"severity"} = 'normal' if ($status{"severity"} eq '');
 729
 730      $status{"pending"} = 'pending';
 731      $status{"pending"} = 'forwarded'       if (length($status{"forwarded"}));
 732      $status{"pending"} = 'pending-fixed'    if ($tags{pending});
 733      $status{"pending"} = 'fixed'           if ($tags{fixed});
 734
 735      my @sourceversions;
 736      if (not exists $param{sourceversions}) {
 737           my @versions;
 738           if (defined $param{version}) {
 739                @versions = ($param{version});
 740           } elsif (defined $param{dist}) {
 741                @versions = getversions($status{package}, $param{dist}, $param{arch});
 742           }
 743
 744           # TODO: This should probably be handled further out for efficiency and
 745           # for more ease of distinguishing between pkg= and src= queries.
 746           @sourceversions = makesourceversions($status{package},
 747                                                $param{arch},
 748                                                @versions);
 749      }
 750      else {
 751           @sourceversions = @{$param{sourceversions}};
 752      }
 753      if (@sourceversions) {
 754           my $maxbuggy = max_buggy(bug => $param{bug},
 755                                    sourceversions => \@sourceversions,
 756                                    found => $status{found_versions},
 757                                    fixed => $status{fixed_versions},
 758                                    package => $status{package},
 759                                    version_cache => $version_cache,
 760                                   );
 761           if ($maxbuggy eq 'absent') {
 762                $status{pending} = 'absent';
 763           }
 764           elsif ($maxbuggy eq 'fixed' ) {
 765                $status{pending} = 'done';
 766           }
 767      }
 768      if (length($status{done}) and
 769          (not @sourceversions or not @{$status{fixed_versions}})) {
 770           $status{"pending"} = 'done';
 771      }
 772
 773      return \%status;
 774 }
 775
 776
 777 =head2 max_buggy
 778
 779      max_buggy()
 780
 781 =head3 Options
 782
 783 =over
 784
 785 =item bug -- scalar bug number
 786
 787 =item sourceversion -- optional arrayref of source/version; overrides
 788 dist, arch, and version. [The entries in this array must be in the
 789 "source/version" format.] Eventually this can be used to for caching.
 790
 791 =back
 792
 793 Note: Currently the version information is cached; this needs to be
 794 changed before using this function in long lived programs.
 795
 796
 797 =cut
 798 sub max_buggy{
 799      my %param = validate_with(params => \@_,
 800                                spec   => {bug       => {type => SCALAR,
 801                                                         regex => qr/^\d+$/,
 802                                                        },
 803                                           sourceversions => {type => ARRAYREF,
 804                                                              default => [],
 805                                                             },
 806                                           found          => {type => ARRAYREF,
 807                                                              default => [],
 808                                                             },
 809                                           fixed          => {type => ARRAYREF,
 810                                                              default => [],
 811                                                             },
 812                                           package        => {type => SCALAR,
 813                                                             },
 814                                           version_cache  => {type => HASHREF,
 815                                                              default => {},
 816                                                             },
 817                                          },
 818                               );
 819      # Resolve bugginess states (we might be looking at multiple
 820      # architectures, say). Found wins, then fixed, then absent.
 821      my $maxbuggy = 'absent';
 822      for my $version (@{$param{sourceversions}}) {
 823           my $buggy = buggy(bug => $param{bug},
 824                             version => $version,
 825                             found => $param{found},
 826                             fixed => $param{fixed},
 827                             version_cache => $param{version_cache},
 828                             package => $param{package},
 829                            );
 830           if ($buggy eq 'found') {
 831                return 'found';
 832           } elsif ($buggy eq 'fixed') {
 833                $maxbuggy = 'fixed';
 834           }
 835      }
 836      return $maxbuggy;
 837 }
 838
 839
 840 =head2 buggy
 841
 842      buggy(bug => nnn,
 843            found => \@found,
 844            fixed => \@fixed,
 845            package => 'foo',
 846            version => '1.0',
 847           );
 848
 849 Returns the output of Debbugs::Versions::buggy for a particular
 850 package, version and found/fixed set. Automatically turns found, fixed
 851 and version into source/version strings.
 852
 853 Caching can be had by using the version_cache, but no attempt to check
 854 to see if the on disk information is more recent than the cache is
 855 made. [This will need to be fixed for long-lived processes.]
 856
 857 =cut
 858
 859 sub buggy {
 860      my %param = validate_with(params => \@_,
 861                                spec   => {bug => {type => SCALAR,
 862                                                   regex => qr/^\d+$/,
 863                                                  },
 864                                           found => {type => ARRAYREF,
 865                                                     default => [],
 866                                                    },
 867                                           fixed => {type => ARRAYREF,
 868                                                     default => [],
 869                                                    },
 870                                           version_cache => {type => HASHREF,
 871                                                             optional => 1,
 872                                                            },
 873                                           package => {type => SCALAR,
 874                                                      },
 875                                           version => {type => SCALAR,
 876                                                      },
 877                                          },
 878                               );
 879      my @found = @{$param{found}};
 880      my @fixed = @{$param{fixed}};
 881      if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
 882           # We have non-source version versions
 883           @found = makesourceversions($param{package},undef,
 884                                       @found
 885                                      );
 886           @fixed = makesourceversions($param{package},undef,
 887                                       @fixed
 888                                      );
 889      }
 890      if ($param{version} !~ m{/}) {
 891           $param{version} = makesourceversions($param{package},undef,
 892                                                $param{version}
 893                                               );
 894      }
 895      # Figure out which source packages we need
 896      my %sources;
 897      @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
 898      @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
 899      @sources{map {m{(.+)/}; $1} $param{version}} = 1;
 900      my $version;
 901      if (not defined $param{version_cache} or
 902          not exists $param{version_cache}{join(',',sort keys %sources)}) {
 903           $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
 904           foreach my $source (keys %sources) {
 905                my $srchash = substr $source, 0, 1;
 906                my $version_fh = new IO::File "$config{version_packages_dir}/$srchash/$source", 'r' or
 907                     warn "Unable to open $config{version_packages_dir}/$srchash/$source: $!" and next;
 908                $version->load($version_fh);
 909           }
 910           if (defined $param{version_cache}) {
 911                $param{version_cache}{join(',',sort keys %sources)} = $version;
 912           }
 913      }
 914      else {
 915           $version = $param{version_cache}{join(',',sort keys %sources)};
 916      }
 917      return $version->buggy($param{version},\@found,\@fixed);
 918 }
 919
 920 sub isstrongseverity {
 921     my $severity = shift;
 922     $severity = $config{default_severity} if $severity eq '';
 923     return grep { $_ eq $severity } @{$config{strong_severities}};
 924 }
 925
 926
 927 =head1 PRIVATE FUNCTIONS
 928
 929 =cut
 930
 931 sub update_realtime {
 932         my ($file, $bug, $new) = @_;
 933
 934         # update realtime index.db
 935
 936         open(IDXDB, "<$file") or die "Couldn't open $file";
 937         open(IDXNEW, ">$file.new");
 938
 939         my $line;
 940         my @line;
 941         while($line = <IDXDB>) {
 942                 @line = split /\s/, $line;
 943                 last if ($line[1] >= $bug);
 944                 print IDXNEW $line;
 945                 $line = "";
 946         }
 947
 948         if ($new eq "NOCHANGE") {
 949                 print IDXNEW $line if ($line ne ""  and $line[1] == $bug);
 950         } elsif ($new eq "REMOVE") {
 951                 0;
 952         } else {
 953                 print IDXNEW $new;
 954         }
 955         if (defined $line and $line ne "" and  @line and $line[1] > $bug) {
 956                 print IDXNEW $line;
 957                 $line = "";
 958         }
 959
 960         print IDXNEW while(<IDXDB>);
 961
 962         close(IDXNEW);
 963         close(IDXDB);
 964
 965         rename("$file.new", $file);
 966
 967         return $line;
 968 }
 969
 970 sub bughook_archive {
 971         my $ref = shift;
 972         &filelock("debbugs.trace.lock");
 973         &appendfile("debbugs.trace","archive $ref\n");
 974         my $line = update_realtime(
 975                 "$config{spool_dir}/index.db.realtime",
 976                 $ref,
 977                 "REMOVE");
 978         update_realtime("$config{spool_dir}/index.archive.realtime",
 979                 $ref, $line);
 980         &unfilelock;
 981 }
 982
 983 sub bughook {
 984         my ( $type, $ref, $data ) = @_;
 985         &filelock("debbugs.trace.lock");
 986
 987         &appendfile("debbugs.trace","$type $ref\n",makestatus($data, 1));
 988
 989         my $whendone = "open";
 990         my $severity = $config{default_severity};
 991         (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
 992         $pkglist =~ s/^,+//;
 993         $pkglist =~ s/,+$//;
 994         $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
 995         $whendone = "done" if defined $data->{done} and length $data->{done};
 996         $severity = $data->{severity} if length $data->{severity};
 997
 998         my $k = sprintf "%s %d %d %s [%s] %s %s\n",
 999                         $pkglist, $ref, $data->{date}, $whendone,
1000                         $data->{originator}, $severity, $data->{keywords};
1001
1002         update_realtime("$config{spool_dir}/index.db.realtime", $ref, $k);
1003
1004         &unfilelock;
1005 }
1006
1007
1008 1;
1009
1010 __END__