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