Debbugs/Status.pm

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