Debbugs/Status.pm

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