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