Debbugs/Status.pm

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