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