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