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