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