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