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