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