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