Debbugs/Status.pm

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