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