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