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