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