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