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