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