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      }
 734      # If $param{ignore_time}, then we should ignore time.
 735      if ($param{ignore_time}) {
 736           return $param{days_until}?0:1;
 737      }
 738      # 6. at least 28 days have passed since the last action has occured or the bug was closed
 739      my $age = ceil($max_log_age);
 740      if ($age > 0 or $min_archive_days > 0) {
 741           print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
 742           return $param{days_until}?max($age,$min_archive_days):0;
 743      }
 744      else {
 745           return $param{days_until}?0:1;
 746      }
 747 }
 748
 749
 750 =head2 get_bug_status
 751
 752      my $status = get_bug_status(bug => $nnn);
 753
 754      my $status = get_bug_status($bug_num)
 755
 756 =head3 Options
 757
 758 =over
 759
 760 =item bug -- scalar bug number
 761
 762 =item status -- optional hashref of bug status as returned by readbug
 763 (can be passed to avoid rereading the bug information)
 764
 765 =item bug_index -- optional tied index of bug status infomration;
 766 currently not correctly implemented.
 767
 768 =item version -- optional version(s) to check package status at
 769
 770 =item dist -- optional distribution(s) to check package status at
 771
 772 =item arch -- optional architecture(s) to check package status at
 773
 774 =item bugusertags -- optional hashref of bugusertags
 775
 776 =item sourceversion -- optional arrayref of source/version; overrides
 777 dist, arch, and version. [The entries in this array must be in the
 778 "source/version" format.] Eventually this can be used to for caching.
 779
 780 =item indicatesource -- if true, indicate which source packages this
 781 bug could belong to. Defaults to false. [Note that eventually we will
 782 properly allow bugs that only affect a source package, and this will
 783 become always on.]
 784
 785 =back
 786
 787 Note: Currently the version information is cached; this needs to be
 788 changed before using this function in long lived programs.
 789
 790 =cut
 791
 792 sub get_bug_status {
 793      if (@_ == 1) {
 794           unshift @_, 'bug';
 795      }
 796      my %param = validate_with(params => \@_,
 797                                spec   => {bug       => {type => SCALAR,
 798                                                         regex => qr/^\d+$/,
 799                                                        },
 800                                           status    => {type => HASHREF,
 801                                                         optional => 1,
 802                                                        },
 803                                           bug_index => {type => OBJECT,
 804                                                         optional => 1,
 805                                                        },
 806                                           version   => {type => SCALAR|ARRAYREF,
 807                                                         optional => 1,
 808                                                        },
 809                                           dist       => {type => SCALAR|ARRAYREF,
 810                                                          optional => 1,
 811                                                         },
 812                                           arch       => {type => SCALAR|ARRAYREF,
 813                                                          optional => 1,
 814                                                         },
 815                                           bugusertags   => {type => HASHREF,
 816                                                             optional => 1,
 817                                                            },
 818                                           sourceversions => {type => ARRAYREF,
 819                                                              optional => 1,
 820                                                             },
 821                                           indicatesource => {type => BOOLEAN,
 822                                                              default => 0,
 823                                                             },
 824                                          },
 825                               );
 826      my %status;
 827
 828      if (defined $param{bug_index} and
 829          exists $param{bug_index}{$param{bug}}) {
 830           %status = %{ $param{bug_index}{$param{bug}} };
 831           $status{pending} = $status{ status };
 832           $status{id} = $param{bug};
 833           return \%status;
 834      }
 835      if (defined $param{status}) {
 836           %status = %{$param{status}};
 837      }
 838      else {
 839           my $location = getbuglocation($param{bug}, 'summary');
 840           return {} if not defined $location or not length $location;
 841           %status = %{ readbug( $param{bug}, $location ) };
 842      }
 843      $status{id} = $param{bug};
 844
 845      if (defined $param{bugusertags}{$param{bug}}) {
 846           $status{keywords} = "" unless defined $status{keywords};
 847           $status{keywords} .= " " unless $status{keywords} eq "";
 848           $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
 849      }
 850      $status{tags} = $status{keywords};
 851      my %tags = map { $_ => 1 } split ' ', $status{tags};
 852
 853      $status{"package"} =~ s/\s*$//;
 854      if ($param{indicatesource} and $status{package} ne '') {
 855           $status{source} = join(', ',binarytosource($status{package}));
 856      }
 857      else {
 858           $status{source} = 'unknown';
 859      }
 860      $status{"package"} = 'unknown' if ($status{"package"} eq '');
 861      $status{"severity"} = 'normal' if ($status{"severity"} eq '');
 862
 863      $status{"pending"} = 'pending';
 864      $status{"pending"} = 'forwarded'       if (length($status{"forwarded"}));
 865      $status{"pending"} = 'pending-fixed'    if ($tags{pending});
 866      $status{"pending"} = 'fixed'           if ($tags{fixed});
 867
 868
 869      my $presence = bug_presence(map{(exists $param{$_})?($_,$param{$_}):()}
 870                                  qw(bug sourceversions arch dist version found fixed package)
 871                                 );
 872      if (defined $presence) {
 873           if ($presence eq 'fixed') {
 874                $status{pending} = 'done';
 875           }
 876           elsif ($presence eq 'absent') {
 877                $status{pending} = 'absent';
 878           }
 879      }
 880      return \%status;
 881 }
 882
 883 =head2 bug_presence
 884
 885      my $precence = bug_presence(bug => nnn,
 886                                  ...
 887                                 );
 888
 889 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
 890 is found, absent, fixed, or no information is available in the
 891 distribution (dist) and/or architecture (arch) specified.
 892
 893
 894 =head3 Options
 895
 896 =over
 897
 898 =item bug -- scalar bug number
 899
 900 =item status -- optional hashref of bug status as returned by readbug
 901 (can be passed to avoid rereading the bug information)
 902
 903 =item bug_index -- optional tied index of bug status infomration;
 904 currently not correctly implemented.
 905
 906 =item version -- optional version to check package status at
 907
 908 =item dist -- optional distribution to check package status at
 909
 910 =item arch -- optional architecture to check package status at
 911
 912 =item sourceversion -- optional arrayref of source/version; overrides
 913 dist, arch, and version. [The entries in this array must be in the
 914 "source/version" format.] Eventually this can be used to for caching.
 915
 916 =back
 917
 918 =cut
 919
 920 sub bug_presence {
 921      my %param = validate_with(params => \@_,
 922                                spec   => {bug       => {type => SCALAR,
 923                                                         regex => qr/^\d+$/,
 924                                                        },
 925                                           status    => {type => HASHREF,
 926                                                         optional => 1,
 927                                                        },
 928                                           version   => {type => SCALAR|ARRAYREF,
 929                                                         optional => 1,
 930                                                        },
 931                                           dist       => {type => SCALAR|ARRAYREF,
 932                                                          optional => 1,
 933                                                         },
 934                                           arch       => {type => SCALAR|ARRAYREF,
 935                                                          optional => 1,
 936                                                         },
 937                                           sourceversions => {type => ARRAYREF,
 938                                                              optional => 1,
 939                                                             },
 940                                          },
 941                               );
 942      my %status;
 943      if (defined $param{status}) {
 944          %status = %{$param{status}};
 945      }
 946      else {
 947           my $location = getbuglocation($param{bug}, 'summary');
 948           return {} if not length $location;
 949           %status = %{ readbug( $param{bug}, $location ) };
 950      }
 951
 952      my @sourceversions;
 953      my $pseudo_desc = getpseudodesc();
 954      if (not exists $param{sourceversions}) {
 955           my %sourceversions;
 956           # pseudopackages do not have source versions by definition.
 957           if (exists $pseudo_desc->{$status{package}}) {
 958                # do nothing.
 959           }
 960           elsif (defined $param{version}) {
 961                foreach my $arch (make_list($param{arch})) {
 962                     for my $package (split /\s*,\s*/, $status{package}) {
 963                          my @temp = makesourceversions($package,
 964                                                        $arch,
 965                                                        make_list($param{version})
 966                                                       );
 967                          @sourceversions{@temp} = (1) x @temp;
 968                     }
 969                }
 970           } elsif (defined $param{dist}) {
 971                foreach my $arch (make_list($param{arch})) {
 972                     my @versions;
 973                     for my $package (split /\s*,\s*/, $status{package}) {
 974                          foreach my $dist (make_list($param{dist})) {
 975                               push @versions, getversions($package, $dist, $arch);
 976                          }
 977                          my @temp = makesourceversions($package,
 978                                                        $arch,
 979                                                        @versions
 980                                                       );
 981                          @sourceversions{@temp} = (1) x @temp;
 982                     }
 983                }
 984           }
 985
 986           # TODO: This should probably be handled further out for efficiency and
 987           # for more ease of distinguishing between pkg= and src= queries.
 988           # DLA: src= queries should just pass arch=source, and they'll be happy.
 989           @sourceversions = keys %sourceversions;
 990      }
 991      else {
 992           @sourceversions = @{$param{sourceversions}};
 993      }
 994      my $maxbuggy = 'undef';
 995      if (@sourceversions) {
 996           $maxbuggy = max_buggy(bug => $param{bug},
 997                                    sourceversions => \@sourceversions,
 998                                    found => $status{found_versions},
 999                                    fixed => $status{fixed_versions},
1000                                    package => $status{package},
1001                                    version_cache => $version_cache,
1002                                   );
1003      }
1004      elsif (defined $param{dist} and
1005             not exists $pseudo_desc->{$status{package}}) {
1006           return 'absent';
1007      }
1008      if (length($status{done}) and
1009          (not @sourceversions or not @{$status{fixed_versions}})) {
1010           return 'fixed';
1011      }
1012      return $maxbuggy;
1013 }
1014
1015
1016 =head2 max_buggy
1017
1018      max_buggy()
1019
1020 =head3 Options
1021
1022 =over
1023
1024 =item bug -- scalar bug number
1025
1026 =item sourceversion -- optional arrayref of source/version; overrides
1027 dist, arch, and version. [The entries in this array must be in the
1028 "source/version" format.] Eventually this can be used to for caching.
1029
1030 =back
1031
1032 Note: Currently the version information is cached; this needs to be
1033 changed before using this function in long lived programs.
1034
1035
1036 =cut
1037 sub max_buggy{
1038      my %param = validate_with(params => \@_,
1039                                spec   => {bug       => {type => SCALAR,
1040                                                         regex => qr/^\d+$/,
1041                                                        },
1042                                           sourceversions => {type => ARRAYREF,
1043                                                              default => [],
1044                                                             },
1045                                           found          => {type => ARRAYREF,
1046                                                              default => [],
1047                                                             },
1048                                           fixed          => {type => ARRAYREF,
1049                                                              default => [],
1050                                                             },
1051                                           package        => {type => SCALAR,
1052                                                             },
1053                                           version_cache  => {type => HASHREF,
1054                                                              default => {},
1055                                                             },
1056                                          },
1057                               );
1058      # Resolve bugginess states (we might be looking at multiple
1059      # architectures, say). Found wins, then fixed, then absent.
1060      my $maxbuggy = 'absent';
1061      for my $package (split /\s*,\s*/, $param{package}) {
1062           for my $version (@{$param{sourceversions}}) {
1063                my $buggy = buggy(bug => $param{bug},
1064                                  version => $version,
1065                                  found => $param{found},
1066                                  fixed => $param{fixed},
1067                                  version_cache => $param{version_cache},
1068                                  package => $package,
1069                                 );
1070                if ($buggy eq 'found') {
1071                     return 'found';
1072                } elsif ($buggy eq 'fixed') {
1073                     $maxbuggy = 'fixed';
1074                }
1075           }
1076      }
1077      return $maxbuggy;
1078 }
1079
1080
1081 =head2 buggy
1082
1083      buggy(bug => nnn,
1084            found => \@found,
1085            fixed => \@fixed,
1086            package => 'foo',
1087            version => '1.0',
1088           );
1089
1090 Returns the output of Debbugs::Versions::buggy for a particular
1091 package, version and found/fixed set. Automatically turns found, fixed
1092 and version into source/version strings.
1093
1094 Caching can be had by using the version_cache, but no attempt to check
1095 to see if the on disk information is more recent than the cache is
1096 made. [This will need to be fixed for long-lived processes.]
1097
1098 =cut
1099
1100 sub buggy {
1101      my %param = validate_with(params => \@_,
1102                                spec   => {bug => {type => SCALAR,
1103                                                   regex => qr/^\d+$/,
1104                                                  },
1105                                           found => {type => ARRAYREF,
1106                                                     default => [],
1107                                                    },
1108                                           fixed => {type => ARRAYREF,
1109                                                     default => [],
1110                                                    },
1111                                           version_cache => {type => HASHREF,
1112                                                             optional => 1,
1113                                                            },
1114                                           package => {type => SCALAR,
1115                                                      },
1116                                           version => {type => SCALAR,
1117                                                      },
1118                                          },
1119                               );
1120      my @found = @{$param{found}};
1121      my @fixed = @{$param{fixed}};
1122      if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1123           # We have non-source version versions
1124           @found = makesourceversions($param{package},undef,
1125                                       @found
1126                                      );
1127           @fixed = makesourceversions($param{package},undef,
1128                                       @fixed
1129                                      );
1130      }
1131      if ($param{version} !~ m{/}) {
1132           my ($version) = makesourceversions($param{package},undef,
1133                                              $param{version}
1134                                             );
1135           $param{version} = $version if defined $version;
1136      }
1137      # Figure out which source packages we need
1138      my %sources;
1139      @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1140      @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1141      @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1142           $param{version} =~ m{/};
1143      my $version;
1144      if (not defined $param{version_cache} or
1145          not exists $param{version_cache}{join(',',sort keys %sources)}) {
1146           $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1147           foreach my $source (keys %sources) {
1148                my $srchash = substr $source, 0, 1;
1149                my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1150                if (not defined $version_fh) {
1151                     # We only want to warn if it's a package which actually has a maintainer
1152                     my $maints = getmaintainers();
1153                     next if not exists $maints->{$source};
1154                     warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1155                     next;
1156                }
1157                $version->load($version_fh);
1158           }
1159           if (defined $param{version_cache}) {
1160                $param{version_cache}{join(',',sort keys %sources)} = $version;
1161           }
1162      }
1163      else {
1164           $version = $param{version_cache}{join(',',sort keys %sources)};
1165      }
1166      return $version->buggy($param{version},\@found,\@fixed);
1167 }
1168
1169 sub isstrongseverity {
1170     my $severity = shift;
1171     $severity = $config{default_severity} if
1172          not defined $severity or $severity eq '';
1173     return grep { $_ eq $severity } @{$config{strong_severities}};
1174 }
1175
1176
1177 =head1 PRIVATE FUNCTIONS
1178
1179 =cut
1180
1181 sub update_realtime {
1182         my ($file, %bugs) = @_;
1183
1184         # update realtime index.db
1185
1186         return () unless keys %bugs;
1187         my $idx_old = IO::File->new($file,'r')
1188              or die "Couldn't open ${file}: $!";
1189         my $idx_new = IO::File->new($file.'.new','w')
1190              or die "Couldn't open ${file}.new: $!";
1191
1192         my $min_bug = min(keys %bugs);
1193         my $line;
1194         my @line;
1195         my %changed_bugs;
1196         while($line = <$idx_old>) {
1197              @line = split /\s/, $line;
1198              # Two cases; replacing existing line or adding new line
1199              if (exists $bugs{$line[1]}) {
1200                   my $new = $bugs{$line[1]};
1201                   delete $bugs{$line[1]};
1202                   $min_bug = min(keys %bugs);
1203                   if ($new eq "NOCHANGE") {
1204                        print {$idx_new} $line;
1205                        $changed_bugs{$line[1]} = $line;
1206                   } elsif ($new eq "REMOVE") {
1207                        $changed_bugs{$line[1]} = $line;
1208                   } else {
1209                        print {$idx_new} $new;
1210                        $changed_bugs{$line[1]} = $line;
1211                   }
1212              }
1213              else {
1214                   while ($line[1] > $min_bug) {
1215                        print {$idx_new} $bugs{$min_bug};
1216                        delete $bugs{$min_bug};
1217                        last unless keys %bugs;
1218                        $min_bug = min(keys %bugs);
1219                   }
1220                   print {$idx_new} $line;
1221              }
1222              last unless keys %bugs;
1223         }
1224         print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1225
1226         print {$idx_new} <$idx_old>;
1227
1228         close($idx_new);
1229         close($idx_old);
1230
1231         rename("$file.new", $file);
1232
1233         return %changed_bugs;
1234 }
1235
1236 sub bughook_archive {
1237         my @refs = @_;
1238         &filelock("debbugs.trace.lock");
1239         &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1240         my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1241                                    map{($_,'REMOVE')} @refs);
1242         update_realtime("$config{spool_dir}/index.archive.realtime",
1243                         %bugs);
1244         &unfilelock;
1245 }
1246
1247 sub bughook {
1248         my ( $type, %bugs_temp ) = @_;
1249         &filelock("debbugs.trace.lock");
1250
1251         my %bugs;
1252         for my $bug (keys %bugs_temp) {
1253              my $data = $bugs_temp{$bug};
1254              &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1255
1256              my $whendone = "open";
1257              my $severity = $config{default_severity};
1258              (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1259              $pkglist =~ s/^,+//;
1260              $pkglist =~ s/,+$//;
1261              $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1262              $whendone = "done" if defined $data->{done} and length $data->{done};
1263              $severity = $data->{severity} if length $data->{severity};
1264
1265              my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1266                   $pkglist, $bug, $data->{date}, $whendone,
1267                        $data->{originator}, $severity, $data->{keywords};
1268              $bugs{$bug} = $k;
1269         }
1270         update_realtime("$config{spool_dir}/index.db.realtime", %bugs);
1271
1272         &unfilelock;
1273 }
1274
1275
1276 1;
1277
1278 __END__