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