Debbugs/Status.pm

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