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