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