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      mergedwith     => $ditch_empty_space,
 298     );
 299
 300 sub split_status_fields {
 301     my @data = @{dclone(\@_)};
 302     for my $data (@data) {
 303         next if not defined $data;
 304         croak "Passed an element which is not a hashref to split_status_field".ref($data) if
 305             not (ref($data) and ref($data) eq 'HASH');
 306         for my $field (keys %{$data}) {
 307             next unless defined $data->{$field};
 308             if (exists $split_fields{$field}) {
 309                 next if ref($data->{$field});
 310                 my @elements;
 311                 if (ref($split_fields{$field}) eq 'CODE') {
 312                     @elements = &{$split_fields{$field}}($data->{$field});
 313                 }
 314                 elsif (not ref($split_fields{$field}) or
 315                        UNIVERSAL::isa($split_fields{$field},'Regex')
 316                       ) {
 317                     @elements = split $split_fields{$field}, $data->{$field};
 318                 }
 319                 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          mergedwith     => ' ',
 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: ".
 361             ref($data)
 362                 if ref($data) ne 'HASH';
 363         for my $field (keys %{$data}) {
 364             next unless defined $data->{$field};
 365             next unless 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
 520     if ($version < 3) {
 521         for my $field (@rfc1522_fields) {
 522             $newdata{$field} = encode_rfc1522($newdata{$field});
 523         }
 524     }
 525
 526     if ($version == 1) {
 527         for my $field (@v1fieldorder) {
 528             if (exists $newdata{$field} and defined $newdata{$field}) {
 529                 $contents .= "$newdata{$field}\n";
 530             } else {
 531                 $contents .= "\n";
 532             }
 533         }
 534     } elsif ($version == 2 or $version == 3) {
 535         # Version 2 or 3. Add a file format version number for the sake of
 536         # further extensibility in the future.
 537         $contents .= "Format-Version: $version\n";
 538         for my $field (keys %fields) {
 539             if (exists $newdata{$field} and defined $newdata{$field}
 540                 and $newdata{$field} ne '') {
 541                 # Output field names in proper case, e.g. 'Merged-With'.
 542                 my $properfield = $fields{$field};
 543                 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
 544                 $contents .= "$properfield: $newdata{$field}\n";
 545             }
 546         }
 547     }
 548
 549     return $contents;
 550 }
 551
 552 =head2 writebug
 553
 554      writebug($bug_num,$status,$location,$minversion,$disablebughook)
 555
 556 Writes the bug status and summary files out.
 557
 558 Skips writting out a status file if minversion is 2
 559
 560 Does not call bughook if disablebughook is true.
 561
 562 =cut
 563
 564 sub writebug {
 565     my ($ref, $data, $location, $minversion, $disablebughook) = @_;
 566     my $change;
 567
 568     my %outputs = (1 => 'status', 2 => 'summary');
 569     for my $version (keys %outputs) {
 570         next if defined $minversion and $version < $minversion;
 571         my $status = getbugcomponent($ref, $outputs{$version}, $location);
 572         die "can't find location for $ref" unless defined $status;
 573         open(S,"> $status.new") || die "opening $status.new: $!";
 574         print(S makestatus($data, $version)) ||
 575             die "writing $status.new: $!";
 576         close(S) || die "closing $status.new: $!";
 577         if (-e $status) {
 578             $change = 'change';
 579         } else {
 580             $change = 'new';
 581         }
 582         rename("$status.new",$status) || die "installing new $status: $!";
 583     }
 584
 585     # $disablebughook is a bit of a hack to let format migration scripts use
 586     # this function rather than having to duplicate it themselves.
 587     &bughook($change,$ref,$data) unless $disablebughook;
 588 }
 589
 590 =head2 unlockwritebug
 591
 592      unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
 593
 594 Writes a bug, then calls unfilelock; see writebug for what these
 595 options mean.
 596
 597 =cut
 598
 599 sub unlockwritebug {
 600     writebug(@_);
 601     &unfilelock;
 602 }
 603
 604 =head1 VERSIONS
 605
 606 The following functions are exported with the :versions tag
 607
 608 =head2 addfoundversions
 609
 610      addfoundversions($status,$package,$version,$isbinary);
 611
 612
 613
 614 =cut
 615
 616
 617 sub addfoundversions {
 618     my $data = shift;
 619     my $package = shift;
 620     my $version = shift;
 621     my $isbinary = shift;
 622     return unless defined $version;
 623     undef $package if $package =~ m[(?:\s|/)];
 624     my $source = $package;
 625
 626     if (defined $package and $isbinary) {
 627         my @srcinfo = binarytosource($package, $version, undef);
 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 = binarytosource($package, $version, undef);
 702         if (@srcinfo) {
 703             # We know the source package(s). Use a fully-qualified version.
 704             addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 705             return;
 706         }
 707         # Otherwise, an unqualified version will have to do.
 708         undef $source;
 709     }
 710
 711     # Strip off various kinds of brain-damage.
 712     $version =~ s/;.*//;
 713     $version =~ s/ *\(.*\)//;
 714     $version =~ s/ +[A-Za-z].*//;
 715
 716     foreach my $ver (split /[,\s]+/, $version) {
 717         my $sver = defined($source) ? "$source/$ver" : '';
 718         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
 719             push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
 720         }
 721         @{$data->{found_versions}} =
 722             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 723     }
 724 }
 725
 726 sub removefixedversions {
 727     my $data = shift;
 728     my $package = shift;
 729     my $version = shift;
 730     my $isbinary = shift;
 731     return unless defined $version;
 732
 733     foreach my $ver (split /[,\s]+/, $version) {
 734          if ($ver =~ m{/}) {
 735               # fully qualified version
 736               @{$data->{fixed_versions}} =
 737                    grep {$_ ne $ver}
 738                         @{$data->{fixed_versions}};
 739          }
 740          else {
 741               # non qualified version; delete all matchers
 742               @{$data->{fixed_versions}} =
 743                    grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
 744                         @{$data->{fixed_versions}};
 745          }
 746     }
 747 }
 748
 749
 750
 751 =head2 splitpackages
 752
 753      splitpackages($pkgs)
 754
 755 Split a package string from the status file into a list of package names.
 756
 757 =cut
 758
 759 sub splitpackages {
 760     my $pkgs = shift;
 761     return unless defined $pkgs;
 762     return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
 763 }
 764
 765
 766 =head2 bug_archiveable
 767
 768      bug_archiveable(bug => $bug_num);
 769
 770 Options
 771
 772 =over
 773
 774 =item bug -- bug number (required)
 775
 776 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
 777
 778 =item version -- Debbugs::Version information (optional)
 779
 780 =item days_until -- return days until the bug can be archived
 781
 782 =back
 783
 784 Returns 1 if the bug can be archived
 785 Returns 0 if the bug cannot be archived
 786
 787 If days_until is true, returns the number of days until the bug can be
 788 archived, -1 if it cannot be archived. 0 means that the bug can be
 789 archived the next time the archiver runs.
 790
 791 Returns undef on failure.
 792
 793 =cut
 794
 795 # This will eventually need to be fixed before we start using mod_perl
 796 our $version_cache = {};
 797 sub bug_archiveable{
 798      my %param = validate_with(params => \@_,
 799                                spec   => {bug => {type => SCALAR,
 800                                                   regex => qr/^\d+$/,
 801                                                  },
 802                                           status => {type => HASHREF,
 803                                                      optional => 1,
 804                                                     },
 805                                           days_until => {type => BOOLEAN,
 806                                                          default => 0,
 807                                                         },
 808                                           ignore_time => {type => BOOLEAN,
 809                                                           default => 0,
 810                                                          },
 811                                          },
 812                               );
 813      # This is what we return if the bug cannot be archived.
 814      my $cannot_archive = $param{days_until}?-1:0;
 815      # read the status information
 816      my $status = $param{status};
 817      if (not exists $param{status} or not defined $status) {
 818           $status = read_bug(bug=>$param{bug});
 819           if (not defined $status) {
 820                print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
 821                return undef;
 822           }
 823      }
 824      # Bugs can be archived if they are
 825      # 1. Closed
 826      if (not defined $status->{done} or not length $status->{done}) {
 827           print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
 828           return $cannot_archive
 829      }
 830      # Check to make sure that the bug has none of the unremovable tags set
 831      if (@{$config{removal_unremovable_tags}}) {
 832           for my $tag (split ' ', ($status->{tags}||'')) {
 833                if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
 834                     print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
 835                     return $cannot_archive;
 836                }
 837           }
 838      }
 839
 840      # If we just are checking if the bug can be archived, we'll not even bother
 841      # checking the versioning information if the bug has been -done for less than 28 days.
 842      my $log_file = getbugcomponent($param{bug},'log');
 843      if (not defined $log_file) {
 844           print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
 845           return $cannot_archive;
 846      }
 847      my $max_log_age = max(map {$config{remove_age} - -M $_}
 848                            $log_file, map {my $log = getbugcomponent($_,'log');
 849                                            defined $log ? ($log) : ();
 850                                       }
 851                            split / /, $status->{mergedwith}
 852                        );
 853      if (not $param{days_until} and not $param{ignore_time}
 854          and $max_log_age > 0
 855         ) {
 856           print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
 857           return $cannot_archive;
 858      }
 859      # At this point, we have to get the versioning information for this bug.
 860      # We examine the set of distribution tags. If a bug has no distribution
 861      # tags set, we assume a default set, otherwise we use the tags the bug
 862      # has set.
 863
 864      # In cases where we are assuming a default set, if the severity
 865      # is strong, we use the strong severity default; otherwise, we
 866      # use the normal default.
 867
 868      # There must be fixed_versions for us to look at the versioning
 869      # information
 870      my $min_fixed_time = time;
 871      my $min_archive_days = 0;
 872      if (@{$status->{fixed_versions}}) {
 873           my %dist_tags;
 874           @dist_tags{@{$config{removal_distribution_tags}}} =
 875                (1) x @{$config{removal_distribution_tags}};
 876           my %dists;
 877           for my $tag (split ' ', ($status->{tags}||'')) {
 878                next unless exists $config{distribution_aliases}{$tag};
 879                next unless $dist_tags{$config{distribution_aliases}{$tag}};
 880                $dists{$config{distribution_aliases}{$tag}} = 1;
 881           }
 882           if (not keys %dists) {
 883                if (isstrongseverity($status->{severity})) {
 884                     @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
 885                          (1) x @{$config{removal_strong_severity_default_distribution_tags}};
 886                }
 887                else {
 888                     @dists{@{$config{removal_default_distribution_tags}}} =
 889                          (1) x @{$config{removal_default_distribution_tags}};
 890                }
 891           }
 892           my %source_versions;
 893           my @sourceversions = get_versions(package => $status->{package},
 894                                             dist => [keys %dists],
 895                                             source => 1,
 896                                            );
 897           @source_versions{@sourceversions} = (1) x @sourceversions;
 898           # If the bug has not been fixed in the versions actually
 899           # distributed, then it cannot be archived.
 900           if ('found' eq max_buggy(bug => $param{bug},
 901                                    sourceversions => [keys %source_versions],
 902                                    found          => $status->{found_versions},
 903                                    fixed          => $status->{fixed_versions},
 904                                    version_cache  => $version_cache,
 905                                    package        => $status->{package},
 906                                   )) {
 907                print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
 908                return $cannot_archive;
 909           }
 910           # Since the bug has at least been fixed in the architectures
 911           # that matters, we check to see how long it has been fixed.
 912
 913           # If $param{ignore_time}, then we should ignore time.
 914           if ($param{ignore_time}) {
 915                return $param{days_until}?0:1;
 916           }
 917
 918           # To do this, we order the times from most recent to oldest;
 919           # when we come to the first found version, we stop.
 920           # If we run out of versions, we only report the time of the
 921           # last one.
 922           my %time_versions = get_versions(package => $status->{package},
 923                                            dist    => [keys %dists],
 924                                            source  => 1,
 925                                            time    => 1,
 926                                           );
 927           for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
 928                my $buggy = buggy(bug => $param{bug},
 929                                  version        => $version,
 930                                  found          => $status->{found_versions},
 931                                  fixed          => $status->{fixed_versions},
 932                                  version_cache  => $version_cache,
 933                                  package        => $status->{package},
 934                                 );
 935                last if $buggy eq 'found';
 936                $min_fixed_time = min($time_versions{$version},$min_fixed_time);
 937           }
 938           $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
 939                # if there are no versions in the archive at all, then
 940                # we can archive if enough days have passed
 941                if @sourceversions;
 942      }
 943      # If $param{ignore_time}, then we should ignore time.
 944      if ($param{ignore_time}) {
 945           return $param{days_until}?0:1;
 946      }
 947      # 6. at least 28 days have passed since the last action has occured or the bug was closed
 948      my $age = ceil($max_log_age);
 949      if ($age > 0 or $min_archive_days > 0) {
 950           print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
 951           return $param{days_until}?max($age,$min_archive_days):0;
 952      }
 953      else {
 954           return $param{days_until}?0:1;
 955      }
 956 }
 957
 958
 959 =head2 get_bug_status
 960
 961      my $status = get_bug_status(bug => $nnn);
 962
 963      my $status = get_bug_status($bug_num)
 964
 965 =head3 Options
 966
 967 =over
 968
 969 =item bug -- scalar bug number
 970
 971 =item status -- optional hashref of bug status as returned by readbug
 972 (can be passed to avoid rereading the bug information)
 973
 974 =item bug_index -- optional tied index of bug status infomration;
 975 currently not correctly implemented.
 976
 977 =item version -- optional version(s) to check package status at
 978
 979 =item dist -- optional distribution(s) to check package status at
 980
 981 =item arch -- optional architecture(s) to check package status at
 982
 983 =item bugusertags -- optional hashref of bugusertags
 984
 985 =item sourceversion -- optional arrayref of source/version; overrides
 986 dist, arch, and version. [The entries in this array must be in the
 987 "source/version" format.] Eventually this can be used to for caching.
 988
 989 =item indicatesource -- if true, indicate which source packages this
 990 bug could belong to (or does belong to in the case of bugs assigned to
 991 a source package). Defaults to true.
 992
 993 =back
 994
 995 Note: Currently the version information is cached; this needs to be
 996 changed before using this function in long lived programs.
 997
 998 =cut
 999
1000 sub get_bug_status {
1001      if (@_ == 1) {
1002           unshift @_, 'bug';
1003      }
1004      my %param = validate_with(params => \@_,
1005                                spec   => {bug       => {type => SCALAR,
1006                                                         regex => qr/^\d+$/,
1007                                                        },
1008                                           status    => {type => HASHREF,
1009                                                         optional => 1,
1010                                                        },
1011                                           bug_index => {type => OBJECT,
1012                                                         optional => 1,
1013                                                        },
1014                                           version   => {type => SCALAR|ARRAYREF,
1015                                                         optional => 1,
1016                                                        },
1017                                           dist       => {type => SCALAR|ARRAYREF,
1018                                                          optional => 1,
1019                                                         },
1020                                           arch       => {type => SCALAR|ARRAYREF,
1021                                                          optional => 1,
1022                                                         },
1023                                           bugusertags   => {type => HASHREF,
1024                                                             optional => 1,
1025                                                            },
1026                                           sourceversions => {type => ARRAYREF,
1027                                                              optional => 1,
1028                                                             },
1029                                           indicatesource => {type => BOOLEAN,
1030                                                              default => 1,
1031                                                             },
1032                                          },
1033                               );
1034      my %status;
1035
1036      if (defined $param{bug_index} and
1037          exists $param{bug_index}{$param{bug}}) {
1038           %status = %{ $param{bug_index}{$param{bug}} };
1039           $status{pending} = $status{ status };
1040           $status{id} = $param{bug};
1041           return \%status;
1042      }
1043      if (defined $param{status}) {
1044           %status = %{$param{status}};
1045      }
1046      else {
1047           my $location = getbuglocation($param{bug}, 'summary');
1048           return {} if not defined $location or not length $location;
1049           %status = %{ readbug( $param{bug}, $location ) };
1050      }
1051      $status{id} = $param{bug};
1052
1053      if (defined $param{bugusertags}{$param{bug}}) {
1054           $status{keywords} = "" unless defined $status{keywords};
1055           $status{keywords} .= " " unless $status{keywords} eq "";
1056           $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1057      }
1058      $status{tags} = $status{keywords};
1059      my %tags = map { $_ => 1 } split ' ', $status{tags};
1060
1061      $status{package} = '' if not defined $status{package};
1062      $status{"package"} =~ s/\s*$//;
1063      # if we aren't supposed to indicate the source, we'll return
1064      # unknown here.
1065      $status{source} = 'unknown';
1066      if ($param{indicatesource}) {
1067          my @packages = split /\s*,\s*/, $status{package};
1068          my @source;
1069          for my $package (@packages) {
1070              next if $package eq '';
1071              if ($package =~ /^src\:$/) {
1072                  push @source,$1;
1073              }
1074              else {
1075                  push @source, binarytosource($package);
1076              }
1077          }
1078          if (@source) {
1079              $status{source} = join(', ',@source);
1080          }
1081      }
1082
1083      $status{"package"} = 'unknown' if ($status{"package"} eq '');
1084      $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1085
1086      $status{"pending"} = 'pending';
1087      $status{"pending"} = 'forwarded'       if (length($status{"forwarded"}));
1088      $status{"pending"} = 'pending-fixed'    if ($tags{pending});
1089      $status{"pending"} = 'fixed'           if ($tags{fixed});
1090
1091
1092      my $presence = bug_presence(status => \%status,
1093                                  map{(exists $param{$_})?($_,$param{$_}):()}
1094                                  qw(bug sourceversions arch dist version found fixed package)
1095                                 );
1096      if (defined $presence) {
1097           if ($presence eq 'fixed') {
1098                $status{pending} = 'done';
1099           }
1100           elsif ($presence eq 'absent') {
1101                $status{pending} = 'absent';
1102           }
1103      }
1104      return \%status;
1105 }
1106
1107 =head2 bug_presence
1108
1109      my $precence = bug_presence(bug => nnn,
1110                                  ...
1111                                 );
1112
1113 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1114 is found, absent, fixed, or no information is available in the
1115 distribution (dist) and/or architecture (arch) specified.
1116
1117
1118 =head3 Options
1119
1120 =over
1121
1122 =item bug -- scalar bug number
1123
1124 =item status -- optional hashref of bug status as returned by readbug
1125 (can be passed to avoid rereading the bug information)
1126
1127 =item bug_index -- optional tied index of bug status infomration;
1128 currently not correctly implemented.
1129
1130 =item version -- optional version to check package status at
1131
1132 =item dist -- optional distribution to check package status at
1133
1134 =item arch -- optional architecture to check package status at
1135
1136 =item sourceversion -- optional arrayref of source/version; overrides
1137 dist, arch, and version. [The entries in this array must be in the
1138 "source/version" format.] Eventually this can be used to for caching.
1139
1140 =back
1141
1142 =cut
1143
1144 sub bug_presence {
1145      my %param = validate_with(params => \@_,
1146                                spec   => {bug       => {type => SCALAR,
1147                                                         regex => qr/^\d+$/,
1148                                                        },
1149                                           status    => {type => HASHREF,
1150                                                         optional => 1,
1151                                                        },
1152                                           version   => {type => SCALAR|ARRAYREF,
1153                                                         optional => 1,
1154                                                        },
1155                                           dist       => {type => SCALAR|ARRAYREF,
1156                                                          optional => 1,
1157                                                         },
1158                                           arch       => {type => SCALAR|ARRAYREF,
1159                                                          optional => 1,
1160                                                         },
1161                                           sourceversions => {type => ARRAYREF,
1162                                                              optional => 1,
1163                                                             },
1164                                          },
1165                               );
1166      my %status;
1167      if (defined $param{status}) {
1168          %status = %{$param{status}};
1169      }
1170      else {
1171           my $location = getbuglocation($param{bug}, 'summary');
1172           return {} if not length $location;
1173           %status = %{ readbug( $param{bug}, $location ) };
1174      }
1175
1176      my @sourceversions;
1177      my $pseudo_desc = getpseudodesc();
1178      if (not exists $param{sourceversions}) {
1179           my %sourceversions;
1180           # pseudopackages do not have source versions by definition.
1181           if (exists $pseudo_desc->{$status{package}}) {
1182                # do nothing.
1183           }
1184           elsif (defined $param{version}) {
1185                foreach my $arch (make_list($param{arch})) {
1186                     for my $package (split /\s*,\s*/, $status{package}) {
1187                          my @temp = makesourceversions($package,
1188                                                        $arch,
1189                                                        make_list($param{version})
1190                                                       );
1191                          @sourceversions{@temp} = (1) x @temp;
1192                     }
1193                }
1194           } elsif (defined $param{dist}) {
1195                my %affects_distribution_tags;
1196                @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1197                     (1) x @{$config{affects_distribution_tags}};
1198                my $some_distributions_disallowed = 0;
1199                my %allowed_distributions;
1200                for my $tag (split ' ', ($status{tags}||'')) {
1201                    if (exists $config{distribution_aliases}{$tag} and
1202                         exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1203                        $some_distributions_disallowed = 1;
1204                        $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1205                    }
1206                    elsif (exists $affects_distribution_tags{$tag}) {
1207                        $some_distributions_disallowed = 1;
1208                        $allowed_distributions{$tag} = 1;
1209                    }
1210                }
1211                foreach my $arch (make_list(exists $param{arch}?$param{arch}:undef)) {
1212                     for my $package (split /\s*,\s*/, $status{package}) {
1213                          my @versions = ();
1214                          my $source = 0;
1215                          if ($package =~ /^src:(.+)$/) {
1216                              $source = 1;
1217                              $package = $1;
1218                          }
1219                          foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1220                               # if some distributions are disallowed,
1221                               # and this isn't an allowed
1222                               # distribution, then we ignore this
1223                               # distribution for the purposees of
1224                               # finding versions
1225                               if ($some_distributions_disallowed and
1226                                   not exists $allowed_distributions{$dist}) {
1227                                    next;
1228                               }
1229                               push @versions, get_versions(package => $package,
1230                                                            dist    => $dist,
1231                                                            ($source?(arch => 'source'):
1232                                                             (defined $arch?(arch => $arch):())),
1233                                                           );
1234                          }
1235                          next unless @versions;
1236                          my @temp = make_source_versions(package => $package,
1237                                                          arch => $arch,
1238                                                          versions => \@versions,
1239                                                         );
1240                          @sourceversions{@temp} = (1) x @temp;
1241                     }
1242                }
1243           }
1244
1245           # TODO: This should probably be handled further out for efficiency and
1246           # for more ease of distinguishing between pkg= and src= queries.
1247           # DLA: src= queries should just pass arch=source, and they'll be happy.
1248           @sourceversions = keys %sourceversions;
1249      }
1250      else {
1251           @sourceversions = @{$param{sourceversions}};
1252      }
1253      my $maxbuggy = 'undef';
1254      if (@sourceversions) {
1255           $maxbuggy = max_buggy(bug => $param{bug},
1256                                 sourceversions => \@sourceversions,
1257                                 found => $status{found_versions},
1258                                 fixed => $status{fixed_versions},
1259                                 package => $status{package},
1260                                 version_cache => $version_cache,
1261                                );
1262      }
1263      elsif (defined $param{dist} and
1264             not exists $pseudo_desc->{$status{package}}) {
1265           return 'absent';
1266      }
1267      if (length($status{done}) and
1268          (not @sourceversions or not @{$status{fixed_versions}})) {
1269           return 'fixed';
1270      }
1271      return $maxbuggy;
1272 }
1273
1274
1275 =head2 max_buggy
1276
1277      max_buggy()
1278
1279 =head3 Options
1280
1281 =over
1282
1283 =item bug -- scalar bug number
1284
1285 =item sourceversion -- optional arrayref of source/version; overrides
1286 dist, arch, and version. [The entries in this array must be in the
1287 "source/version" format.] Eventually this can be used to for caching.
1288
1289 =back
1290
1291 Note: Currently the version information is cached; this needs to be
1292 changed before using this function in long lived programs.
1293
1294
1295 =cut
1296 sub max_buggy{
1297      my %param = validate_with(params => \@_,
1298                                spec   => {bug       => {type => SCALAR,
1299                                                         regex => qr/^\d+$/,
1300                                                        },
1301                                           sourceversions => {type => ARRAYREF,
1302                                                              default => [],
1303                                                             },
1304                                           found          => {type => ARRAYREF,
1305                                                              default => [],
1306                                                             },
1307                                           fixed          => {type => ARRAYREF,
1308                                                              default => [],
1309                                                             },
1310                                           package        => {type => SCALAR,
1311                                                             },
1312                                           version_cache  => {type => HASHREF,
1313                                                              default => {},
1314                                                             },
1315                                          },
1316                               );
1317      # Resolve bugginess states (we might be looking at multiple
1318      # architectures, say). Found wins, then fixed, then absent.
1319      my $maxbuggy = 'absent';
1320      for my $package (split /\s*,\s*/, $param{package}) {
1321           for my $version (@{$param{sourceversions}}) {
1322                my $buggy = buggy(bug => $param{bug},
1323                                  version => $version,
1324                                  found => $param{found},
1325                                  fixed => $param{fixed},
1326                                  version_cache => $param{version_cache},
1327                                  package => $package,
1328                                 );
1329                if ($buggy eq 'found') {
1330                     return 'found';
1331                } elsif ($buggy eq 'fixed') {
1332                     $maxbuggy = 'fixed';
1333                }
1334           }
1335      }
1336      return $maxbuggy;
1337 }
1338
1339
1340 =head2 buggy
1341
1342      buggy(bug => nnn,
1343            found => \@found,
1344            fixed => \@fixed,
1345            package => 'foo',
1346            version => '1.0',
1347           );
1348
1349 Returns the output of Debbugs::Versions::buggy for a particular
1350 package, version and found/fixed set. Automatically turns found, fixed
1351 and version into source/version strings.
1352
1353 Caching can be had by using the version_cache, but no attempt to check
1354 to see if the on disk information is more recent than the cache is
1355 made. [This will need to be fixed for long-lived processes.]
1356
1357 =cut
1358
1359 sub buggy {
1360      my %param = validate_with(params => \@_,
1361                                spec   => {bug => {type => SCALAR,
1362                                                   regex => qr/^\d+$/,
1363                                                  },
1364                                           found => {type => ARRAYREF,
1365                                                     default => [],
1366                                                    },
1367                                           fixed => {type => ARRAYREF,
1368                                                     default => [],
1369                                                    },
1370                                           version_cache => {type => HASHREF,
1371                                                             optional => 1,
1372                                                            },
1373                                           package => {type => SCALAR,
1374                                                      },
1375                                           version => {type => SCALAR,
1376                                                      },
1377                                          },
1378                               );
1379      my @found = @{$param{found}};
1380      my @fixed = @{$param{fixed}};
1381      if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1382           # We have non-source version versions
1383           @found = makesourceversions($param{package},undef,
1384                                       @found
1385                                      );
1386           @fixed = makesourceversions($param{package},undef,
1387                                       @fixed
1388                                      );
1389      }
1390      if ($param{version} !~ m{/}) {
1391           my ($version) = makesourceversions($param{package},undef,
1392                                              $param{version}
1393                                             );
1394           $param{version} = $version if defined $version;
1395      }
1396      # Figure out which source packages we need
1397      my %sources;
1398      @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1399      @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1400      @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1401           $param{version} =~ m{/};
1402      my $version;
1403      if (not defined $param{version_cache} or
1404          not exists $param{version_cache}{join(',',sort keys %sources)}) {
1405           $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1406           foreach my $source (keys %sources) {
1407                my $srchash = substr $source, 0, 1;
1408                my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1409                if (not defined $version_fh) {
1410                     # We only want to warn if it's a package which actually has a maintainer
1411                     my $maints = getmaintainers();
1412                     next if not exists $maints->{$source};
1413                     warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1414                     next;
1415                }
1416                $version->load($version_fh);
1417           }
1418           if (defined $param{version_cache}) {
1419                $param{version_cache}{join(',',sort keys %sources)} = $version;
1420           }
1421      }
1422      else {
1423           $version = $param{version_cache}{join(',',sort keys %sources)};
1424      }
1425      return $version->buggy($param{version},\@found,\@fixed);
1426 }
1427
1428 sub isstrongseverity {
1429     my $severity = shift;
1430     $severity = $config{default_severity} if
1431          not defined $severity or $severity eq '';
1432     return grep { $_ eq $severity } @{$config{strong_severities}};
1433 }
1434
1435
1436 =head1 PRIVATE FUNCTIONS
1437
1438 =cut
1439
1440 sub update_realtime {
1441         my ($file, %bugs) = @_;
1442
1443         # update realtime index.db
1444
1445         return () unless keys %bugs;
1446         my $idx_old = IO::File->new($file,'r')
1447              or die "Couldn't open ${file}: $!";
1448         my $idx_new = IO::File->new($file.'.new','w')
1449              or die "Couldn't open ${file}.new: $!";
1450
1451         my $min_bug = min(keys %bugs);
1452         my $line;
1453         my @line;
1454         my %changed_bugs;
1455         while($line = <$idx_old>) {
1456              @line = split /\s/, $line;
1457              # Two cases; replacing existing line or adding new line
1458              if (exists $bugs{$line[1]}) {
1459                   my $new = $bugs{$line[1]};
1460                   delete $bugs{$line[1]};
1461                   $min_bug = min(keys %bugs);
1462                   if ($new eq "NOCHANGE") {
1463                        print {$idx_new} $line;
1464                        $changed_bugs{$line[1]} = $line;
1465                   } elsif ($new eq "REMOVE") {
1466                        $changed_bugs{$line[1]} = $line;
1467                   } else {
1468                        print {$idx_new} $new;
1469                        $changed_bugs{$line[1]} = $line;
1470                   }
1471              }
1472              else {
1473                   while ($line[1] > $min_bug) {
1474                        print {$idx_new} $bugs{$min_bug};
1475                        delete $bugs{$min_bug};
1476                        last unless keys %bugs;
1477                        $min_bug = min(keys %bugs);
1478                   }
1479                   print {$idx_new} $line;
1480              }
1481              last unless keys %bugs;
1482         }
1483         print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1484
1485         print {$idx_new} <$idx_old>;
1486
1487         close($idx_new);
1488         close($idx_old);
1489
1490         rename("$file.new", $file);
1491
1492         return %changed_bugs;
1493 }
1494
1495 sub bughook_archive {
1496         my @refs = @_;
1497         &filelock("$config{spool_dir}/debbugs.trace.lock");
1498         &appendfile("debbugs.trace","archive ".join(',',@refs)."\n");
1499         my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1500                                    map{($_,'REMOVE')} @refs);
1501         update_realtime("$config{spool_dir}/index.archive.realtime",
1502                         %bugs);
1503         &unfilelock;
1504 }
1505
1506 sub bughook {
1507         my ( $type, %bugs_temp ) = @_;
1508         &filelock("$config{spool_dir}/debbugs.trace.lock");
1509
1510         my %bugs;
1511         for my $bug (keys %bugs_temp) {
1512              my $data = $bugs_temp{$bug};
1513              &appendfile("debbugs.trace","$type $bug\n",makestatus($data, 1));
1514
1515              my $whendone = "open";
1516              my $severity = $config{default_severity};
1517              (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1518              $pkglist =~ s/^,+//;
1519              $pkglist =~ s/,+$//;
1520              $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1521              $whendone = "done" if defined $data->{done} and length $data->{done};
1522              $severity = $data->{severity} if length $data->{severity};
1523
1524              my $k = sprintf "%s %d %d %s [%s] %s %s\n",
1525                   $pkglist, $bug, $data->{date}, $whendone,
1526                        $data->{originator}, $severity, $data->{keywords};
1527              $bugs{$bug} = $k;
1528         }
1529         update_realtime("$config{spool_dir}/index.db.realtime", %bugs);
1530
1531         &unfilelock;
1532 }
1533
1534
1535 1;
1536
1537 __END__