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