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