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