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(map{(exists $param{$_})?($_,$param{$_}):()}
 961                                  qw(bug sourceversions arch dist version found fixed package)
 962                                 );
 963      if (defined $presence) {
 964           if ($presence eq 'fixed') {
 965                $status{pending} = 'done';
 966           }
 967           elsif ($presence eq 'absent') {
 968                $status{pending} = 'absent';
 969           }
 970      }
 971      return \%status;
 972 }
 973
 974 =head2 bug_presence
 975
 976      my $precence = bug_presence(bug => nnn,
 977                                  ...
 978                                 );
 979
 980 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
 981 is found, absent, fixed, or no information is available in the
 982 distribution (dist) and/or architecture (arch) specified.
 983
 984
 985 =head3 Options
 986
 987 =over
 988
 989 =item bug -- scalar bug number
 990
 991 =item status -- optional hashref of bug status as returned by readbug
 992 (can be passed to avoid rereading the bug information)
 993
 994 =item bug_index -- optional tied index of bug status infomration;
 995 currently not correctly implemented.
 996
 997 =item version -- optional version to check package status at
 998
 999 =item dist -- optional distribution to check package status at
1000
1001 =item arch -- optional architecture to check package status at
1002
1003 =item sourceversion -- optional arrayref of source/version; overrides
1004 dist, arch, and version. [The entries in this array must be in the
1005 "source/version" format.] Eventually this can be used to for caching.
1006
1007 =back
1008
1009 =cut
1010
1011 sub bug_presence {
1012      my %param = validate_with(params => \@_,
1013                                spec   => {bug       => {type => SCALAR,
1014                                                         regex => qr/^\d+$/,
1015                                                        },
1016                                           status    => {type => HASHREF,
1017                                                         optional => 1,
1018                                                        },
1019                                           version   => {type => SCALAR|ARRAYREF,
1020                                                         optional => 1,
1021                                                        },
1022                                           dist       => {type => SCALAR|ARRAYREF,
1023                                                          optional => 1,
1024                                                         },
1025                                           arch       => {type => SCALAR|ARRAYREF,
1026                                                          optional => 1,
1027                                                         },
1028                                           sourceversions => {type => ARRAYREF,
1029                                                              optional => 1,
1030                                                             },
1031                                          },
1032                               );
1033      my %status;
1034      if (defined $param{status}) {
1035          %status = %{$param{status}};
1036      }
1037      else {
1038           my $location = getbuglocation($param{bug}, 'summary');
1039           return {} if not length $location;
1040           %status = %{ readbug( $param{bug}, $location ) };
1041      }
1042
1043      my @sourceversions;
1044      my $pseudo_desc = getpseudodesc();
1045      if (not exists $param{sourceversions}) {
1046           my %sourceversions;
1047           # pseudopackages do not have source versions by definition.
1048           if (exists $pseudo_desc->{$status{package}}) {
1049                # do nothing.
1050           }
1051           elsif (defined $param{version}) {
1052                foreach my $arch (make_list($param{arch})) {
1053                     for my $package (split /\s*,\s*/, $status{package}) {
1054                          my @temp = makesourceversions($package,
1055                                                        $arch,
1056                                                        make_list($param{version})
1057                                                       );
1058                          @sourceversions{@temp} = (1) x @temp;
1059                     }
1060                }
1061           } elsif (defined $param{dist}) {
1062                foreach my $arch (make_list($param{arch})) {
1063                     my @versions;
1064                     for my $package (split /\s*,\s*/, $status{package}) {
1065                          foreach my $dist (make_list($param{dist})) {
1066                               push @versions, getversions($package, $dist, $arch);
1067                          }
1068                          my @temp = makesourceversions($package,
1069                                                        $arch,
1070                                                        @versions
1071                                                       );
1072                          @sourceversions{@temp} = (1) x @temp;
1073                     }
1074                }
1075           }
1076
1077           # TODO: This should probably be handled further out for efficiency and
1078           # for more ease of distinguishing between pkg= and src= queries.
1079           # DLA: src= queries should just pass arch=source, and they'll be happy.
1080           @sourceversions = keys %sourceversions;
1081      }
1082      else {
1083           @sourceversions = @{$param{sourceversions}};
1084      }
1085      my $maxbuggy = 'undef';
1086      if (@sourceversions) {
1087           $maxbuggy = max_buggy(bug => $param{bug},
1088                                    sourceversions => \@sourceversions,
1089                                    found => $status{found_versions},
1090                                    fixed => $status{fixed_versions},
1091                                    package => $status{package},
1092                                    version_cache => $version_cache,
1093                                   );
1094      }
1095      elsif (defined $param{dist} and
1096             not exists $pseudo_desc->{$status{package}}) {
1097           return 'absent';
1098      }
1099      if (length($status{done}) and
1100          (not @sourceversions or not @{$status{fixed_versions}})) {
1101           return 'fixed';
1102      }
1103      return $maxbuggy;
1104 }
1105
1106
1107 =head2 max_buggy
1108
1109      max_buggy()
1110
1111 =head3 Options
1112
1113 =over
1114
1115 =item bug -- scalar bug number
1116
1117 =item sourceversion -- optional arrayref of source/version; overrides
1118 dist, arch, and version. [The entries in this array must be in the
1119 "source/version" format.] Eventually this can be used to for caching.
1120
1121 =back
1122
1123 Note: Currently the version information is cached; this needs to be
1124 changed before using this function in long lived programs.
1125
1126
1127 =cut
1128 sub max_buggy{
1129      my %param = validate_with(params => \@_,
1130                                spec   => {bug       => {type => SCALAR,
1131                                                         regex => qr/^\d+$/,
1132                                                        },
1133                                           sourceversions => {type => ARRAYREF,
1134                                                              default => [],
1135                                                             },
1136                                           found          => {type => ARRAYREF,
1137                                                              default => [],
1138                                                             },
1139                                           fixed          => {type => ARRAYREF,
1140                                                              default => [],
1141                                                             },
1142                                           package        => {type => SCALAR,
1143                                                             },
1144                                           version_cache  => {type => HASHREF,
1145                                                              default => {},
1146                                                             },
1147                                          },
1148                               );
1149      # Resolve bugginess states (we might be looking at multiple
1150      # architectures, say). Found wins, then fixed, then absent.
1151      my $maxbuggy = 'absent';
1152      for my $package (split /\s*,\s*/, $param{package}) {
1153           for my $version (@{$param{sourceversions}}) {
1154                my $buggy = buggy(bug => $param{bug},
1155                                  version => $version,
1156                                  found => $param{found},
1157                                  fixed => $param{fixed},
1158                                  version_cache => $param{version_cache},
1159                                  package => $package,
1160                                 );
1161                if ($buggy eq 'found') {
1162                     return 'found';
1163                } elsif ($buggy eq 'fixed') {
1164                     $maxbuggy = 'fixed';
1165                }
1166           }
1167      }
1168      return $maxbuggy;
1169 }
1170
1171
1172 =head2 buggy
1173
1174      buggy(bug => nnn,
1175            found => \@found,
1176            fixed => \@fixed,
1177            package => 'foo',
1178            version => '1.0',
1179           );
1180
1181 Returns the output of Debbugs::Versions::buggy for a particular
1182 package, version and found/fixed set. Automatically turns found, fixed
1183 and version into source/version strings.
1184
1185 Caching can be had by using the version_cache, but no attempt to check
1186 to see if the on disk information is more recent than the cache is
1187 made. [This will need to be fixed for long-lived processes.]
1188
1189 =cut
1190
1191 sub buggy {
1192      my %param = validate_with(params => \@_,
1193                                spec   => {bug => {type => SCALAR,
1194                                                   regex => qr/^\d+$/,
1195                                                  },
1196                                           found => {type => ARRAYREF,
1197                                                     default => [],
1198                                                    },
1199                                           fixed => {type => ARRAYREF,
1200                                                     default => [],
1201                                                    },
1202                                           version_cache => {type => HASHREF,
1203                                                             optional => 1,
1204                                                            },
1205                                           package => {type => SCALAR,
1206                                                      },
1207                                           version => {type => SCALAR,
1208                                                      },
1209                                          },
1210                               );
1211      my @found = @{$param{found}};
1212      my @fixed = @{$param{fixed}};
1213      if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1214           # We have non-source version versions
1215           @found = makesourceversions($param{package},undef,
1216                                       @found
1217                                      );
1218           @fixed = makesourceversions($param{package},undef,
1219                                       @fixed
1220                                      );
1221      }
1222      if ($param{version} !~ m{/}) {
1223           my ($version) = makesourceversions($param{package},undef,
1224                                              $param{version}
1225                                             );
1226           $param{version} = $version if defined $version;
1227      }
1228      # Figure out which source packages we need
1229      my %sources;
1230      @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1231      @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1232      @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1233           $param{version} =~ m{/};
1234      my $version;
1235      if (not defined $param{version_cache} or
1236          not exists $param{version_cache}{join(',',sort keys %sources)}) {
1237           $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1238           foreach my $source (keys %sources) {
1239                my $srchash = substr $source, 0, 1;
1240                my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1241                if (not defined $version_fh) {
1242                     # We only want to warn if it's a package which actually has a maintainer
1243                     my $maints = getmaintainers();
1244                     next if not exists $maints->{$source};
1245                     warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1246                     next;
1247                }
1248                $version->load($version_fh);
1249           }
1250           if (defined $param{version_cache}) {
1251                $param{version_cache}{join(',',sort keys %sources)} = $version;
1252           }
1253      }
1254      else {
1255           $version = $param{version_cache}{join(',',sort keys %sources)};
1256      }
1257      return $version->buggy($param{version},\@found,\@fixed);
1258 }
1259
1260 sub isstrongseverity {
1261     my $severity = shift;
1262     $severity = $config{default_severity} if
1263          not defined $severity or $severity eq '';
1264     return grep { $_ eq $severity } @{$config{strong_severities}};
1265 }
1266
1267
1268 =head1 PRIVATE FUNCTIONS
1269
1270 =cut
1271
1272 sub update_realtime {
1273         my ($file, %bugs) = @_;
1274
1275         # update realtime index.db
1276
1277         return () unless keys %bugs;
1278         my $idx_old = IO::File->new($file,'r')
1279              or die "Couldn't open ${file}: $!";
1280         my $idx_new = IO::File->new($file.'.new','w')
1281              or die "Couldn't open ${file}.new: $!";
1282
1283         my $min_bug = min(keys %bugs);
1284         my $line;
1285         my @line;
1286         my %changed_bugs;
1287         while($line = <$idx_old>) {
1288              @line = split /\s/, $line;
1289              # Two cases; replacing existing line or adding new line
1290              if (exists $bugs{$line[1]}) {
1291                   my $new = $bugs{$line[1]};
1292                   delete $bugs{$line[1]};
1293                   $min_bug = min(keys %bugs);
1294                   if ($new eq "NOCHANGE") {
1295                        print {$idx_new} $line;
1296                        $changed_bugs{$line[1]} = $line;
1297                   } elsif ($new eq "REMOVE") {
1298                        $changed_bugs{$line[1]} = $line;
1299                   } else {
1300                        print {$idx_new} $new;
1301                        $changed_bugs{$line[1]} = $line;
1302                   }
1303              }
1304              else {
1305                   while ($line[1] > $min_bug) {
1306                        print {$idx_new} $bugs{$min_bug};
1307                        delete $bugs{$min_bug};
1308                        last unless keys %bugs;
1309                        $min_bug = min(keys %bugs);
1310                   }
1311                   print {$idx_new} $line;
1312              }
1313              last unless keys %bugs;
1314         }
1315         print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1316
1317         print {$idx_new} <$idx_old>;
1318
1319         close($idx_new);
1320         close($idx_old);
1321
1322         rename("$file.new", $file);
1323
1324         return %changed_bugs;
1325 }
1326
1327 sub bughook_archive {
1328         my @refs = @_;
1329         &filelock("$config{spool_dir}/debbugs.trace.lock");
1330         &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1331         my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1332                                    map{($_,'REMOVE')} @refs);
1333         update_realtime("$config{spool_dir}/index.archive.realtime",
1334                         %bugs);
1335         &unfilelock;
1336 }
1337
1338 sub bughook {
1339         my ( $type, %bugs_temp ) = @_;
1340         &filelock("$config{spool_dir}/debbugs.trace.lock");
1341
1342         my %bugs;
1343         for my $bug (keys %bugs_temp) {
1344              my $data = $bugs_temp{$bug};
1345              &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1346
1347              my $whendone = "open";
1348              my $severity = $config{default_severity};
1349              (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1350              $pkglist =~ s/^,+//;
1351              $pkglist =~ s/,+$//;
1352              $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1353              $whendone = "done" if defined $data->{done} and length $data->{done};
1354              $severity = $data->{severity} if length $data->{severity};
1355
1356              my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1357                   $pkglist, $bug, $data->{date}, $whendone,
1358                        $data->{originator}, $severity, $data->{keywords};
1359              $bugs{$bug} = $k;
1360         }
1361         update_realtime("$config{spool_dir}/index.db.realtime", %bugs);
1362
1363         &unfilelock;
1364 }
1365
1366
1367 1;
1368
1369 __END__