Debbugs/Status.pm

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