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