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