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