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