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                      indexdb  => [qw(generate_index_db_line)],
  74                      fields   => [qw(%fields)],
  75                     );
  76      @EXPORT_OK = ();
  77      Exporter::export_ok_tags(keys %EXPORT_TAGS);
  78      $EXPORT_TAGS{all} = [@EXPORT_OK];
  79 }
  80
  81
  82 =head2 readbug
  83
  84      readbug($bug_num,$location)
  85      readbug($bug_num)
  86
  87 Reads a summary file from the archive given a bug number and a bug
  88 location. Valid locations are those understood by L</getbugcomponent>
  89
  90 =cut
  91
  92 # these probably shouldn't be imported by most people, but
  93 # Debbugs::Control needs them, so they're now exportable
  94 our %fields = (originator     => 'submitter',
  95               date           => 'date',
  96               subject        => 'subject',
  97               msgid          => 'message-id',
  98               'package'      => 'package',
  99               keywords       => 'tags',
 100               done           => 'done',
 101               forwarded      => 'forwarded-to',
 102               mergedwith     => 'merged-with',
 103               severity       => 'severity',
 104               owner          => 'owner',
 105               found_versions => 'found-in',
 106               found_date     => 'found-date',
 107               fixed_versions => 'fixed-in',
 108               fixed_date     => 'fixed-date',
 109               blocks         => 'blocks',
 110               blockedby      => 'blocked-by',
 111               unarchived     => 'unarchived',
 112               summary        => 'summary',
 113               outlook        => 'outlook',
 114               affects        => 'affects',
 115              );
 116
 117
 118 # Fields which need to be RFC1522-decoded in format versions earlier than 3.
 119 my @rfc1522_fields = qw(originator subject done forwarded owner);
 120
 121 sub readbug {
 122      return read_bug(bug => $_[0],
 123                      (@_ > 1)?(location => $_[1]):()
 124                     );
 125 }
 126
 127 =head2 read_bug
 128
 129      read_bug(bug => $bug_num,
 130               location => 'archive',
 131              );
 132      read_bug(summary => 'path/to/bugnum.summary');
 133      read_bug($bug_num);
 134
 135 A more complete function than readbug; it enables you to pass a full
 136 path to the summary file instead of the bug number and/or location.
 137
 138 =head3 Options
 139
 140 =over
 141
 142 =item bug -- the bug number
 143
 144 =item location -- optional location which is passed to getbugcomponent
 145
 146 =item summary -- complete path to the .summary file which will be read
 147
 148 =item lock -- whether to obtain a lock for the bug to prevent
 149 something modifying it while the bug has been read. You B<must> call
 150 C<unfilelock();> if something not undef is returned from read_bug.
 151
 152 =item locks -- hashref of already obtained locks; incremented as new
 153 locks are needed, and decremented as locks are released on particular
 154 files.
 155
 156 =back
 157
 158 One of C<bug> or C<summary> must be passed. This function will return
 159 undef on failure, and will die if improper arguments are passed.
 160
 161 =cut
 162
 163 sub read_bug{
 164     if (@_ == 1) {
 165          unshift @_, 'bug';
 166     }
 167     my %param = validate_with(params => \@_,
 168                               spec   => {bug => {type => SCALAR,
 169                                                  optional => 1,
 170                                                  # something really
 171                                                  # stupid passes
 172                                                  # negative bugnumbers
 173                                                  regex    => qr/^-?\d+/,
 174                                                 },
 175                                          location => {type => SCALAR|UNDEF,
 176                                                       optional => 1,
 177                                                      },
 178                                          summary  => {type => SCALAR,
 179                                                       optional => 1,
 180                                                      },
 181                                          lock     => {type => BOOLEAN,
 182                                                       optional => 1,
 183                                                      },
 184                                          locks    => {type => HASHREF,
 185                                                       optional => 1,
 186                                                      },
 187                                         },
 188                              );
 189     die "One of bug or summary must be passed to read_bug"
 190          if not exists $param{bug} and not exists $param{summary};
 191     my $status;
 192     my $log;
 193     my $location;
 194     if (not defined $param{summary}) {
 195          my $lref;
 196          ($lref,$location) = @param{qw(bug location)};
 197          if (not defined $location) {
 198               $location = getbuglocation($lref,'summary');
 199               return undef if not defined $location;
 200          }
 201          $status = getbugcomponent($lref, 'summary', $location);
 202          $log    = getbugcomponent($lref, 'log'    , $location);
 203          return undef unless defined $status;
 204          return undef if not -e $status;
 205     }
 206     else {
 207          $status = $param{summary};
 208          $log = $status;
 209          $log =~ s/\.summary$/.log/;
 210          ($location) = $status =~ m/(db-h|db|archive)/;
 211     }
 212     if ($param{lock}) {
 213         filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:());
 214     }
 215     my $status_fh = IO::File->new($status, 'r');
 216     if (not defined $status_fh) {
 217         warn "Unable to open $status for reading: $!";
 218         if ($param{lock}) {
 219                 unfilelock(exists $param{locks}?$param{locks}:());
 220         }
 221         return undef;
 222     }
 223     binmode($status_fh,':encoding(UTF-8)');
 224
 225     my %data;
 226     my @lines;
 227     my $version = 2;
 228     local $_;
 229
 230     while (<$status_fh>) {
 231         chomp;
 232         push @lines, $_;
 233         $version = $1 if /^Format-Version: ([0-9]+)/i;
 234     }
 235
 236     # Version 3 is the latest format version currently supported.
 237     if ($version > 3) {
 238          warn "Unsupported status version '$version'";
 239          if ($param{lock}) {
 240              unfilelock(exists $param{locks}?$param{locks}:());
 241          }
 242          return undef;
 243     }
 244
 245     my %namemap = reverse %fields;
 246     for my $line (@lines) {
 247         if ($line =~ /(\S+?): (.*)/) {
 248             my ($name, $value) = (lc $1, $2);
 249             # this is a bit of a hack; we should never, ever have \r
 250             # or \n in the fields of status. Kill them off here.
 251             # [Eventually, this should be superfluous.]
 252             $value =~ s/[\r\n]//g;
 253             $data{$namemap{$name}} = $value if exists $namemap{$name};
 254         }
 255     }
 256     for my $field (keys %fields) {
 257         $data{$field} = '' unless exists $data{$field};
 258     }
 259     if ($version < 3) {
 260         for my $field (@rfc1522_fields) {
 261             $data{$field} = decode_rfc1522($data{$field});
 262         }
 263     }
 264     $data{severity} = $config{default_severity} if $data{severity} eq '';
 265     for my $field (qw(found_versions fixed_versions found_date fixed_date)) {
 266          $data{$field} = [split ' ', $data{$field}];
 267     }
 268     for my $field (qw(found fixed)) {
 269          # create the found/fixed hashes which indicate when a
 270          # particular version was marked found or marked fixed.
 271          @{$data{$field}}{@{$data{"${field}_versions"}}} =
 272               (('') x (@{$data{"${field}_date"}} - @{$data{"${field}_versions"}}),
 273                @{$data{"${field}_date"}});
 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 = 3 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     %newdata = encode_utf8_structure(%newdata);
 613
 614     if ($version < 3) {
 615         for my $field (@rfc1522_fields) {
 616             $newdata{$field} = encode_rfc1522($newdata{$field});
 617         }
 618     }
 619
 620     # this is a bit of a hack; we should never, ever have \r or \n in
 621     # the fields of status. Kill them off here. [Eventually, this
 622     # should be superfluous.]
 623     for my $field (keys %newdata) {
 624         $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field};
 625     }
 626
 627     if ($version == 1) {
 628         for my $field (@v1fieldorder) {
 629             if (exists $newdata{$field} and defined $newdata{$field}) {
 630                 $contents .= "$newdata{$field}\n";
 631             } else {
 632                 $contents .= "\n";
 633             }
 634         }
 635     } elsif ($version == 2 or $version == 3) {
 636         # Version 2 or 3. Add a file format version number for the sake of
 637         # further extensibility in the future.
 638         $contents .= "Format-Version: $version\n";
 639         for my $field (keys %fields) {
 640             if (exists $newdata{$field} and defined $newdata{$field}
 641                 and $newdata{$field} ne '') {
 642                 # Output field names in proper case, e.g. 'Merged-With'.
 643                 my $properfield = $fields{$field};
 644                 $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g;
 645                 my $data = $newdata{$field};
 646                 $contents .= "$properfield: $data\n";
 647             }
 648         }
 649     }
 650     return $contents;
 651 }
 652
 653 =head2 writebug
 654
 655      writebug($bug_num,$status,$location,$minversion,$disablebughook)
 656
 657 Writes the bug status and summary files out.
 658
 659 Skips writting out a status file if minversion is 2
 660
 661 Does not call bughook if disablebughook is true.
 662
 663 =cut
 664
 665 sub writebug {
 666     my ($ref, $data, $location, $minversion, $disablebughook) = @_;
 667     my $change;
 668
 669     my %outputs = (1 => 'status', 3 => 'summary');
 670     for my $version (keys %outputs) {
 671         next if defined $minversion and $version < $minversion;
 672         my $status = getbugcomponent($ref, $outputs{$version}, $location);
 673         die "can't find location for $ref" unless defined $status;
 674         my $sfh;
 675         if ($version >= 3) {
 676             open $sfh,">","$status.new"  or
 677                 die "opening $status.new: $!";
 678         }
 679         else {
 680             open $sfh,">","$status.new"  or
 681                 die "opening $status.new: $!";
 682         }
 683         print {$sfh} makestatus($data, $version) or
 684             die "writing $status.new: $!";
 685         close($sfh) or die "closing $status.new: $!";
 686         if (-e $status) {
 687             $change = 'change';
 688         } else {
 689             $change = 'new';
 690         }
 691         rename("$status.new",$status) || die "installing new $status: $!";
 692     }
 693
 694     # $disablebughook is a bit of a hack to let format migration scripts use
 695     # this function rather than having to duplicate it themselves.
 696     &bughook($change,$ref,$data) unless $disablebughook;
 697 }
 698
 699 =head2 unlockwritebug
 700
 701      unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook);
 702
 703 Writes a bug, then calls unfilelock; see writebug for what these
 704 options mean.
 705
 706 =cut
 707
 708 sub unlockwritebug {
 709     writebug(@_);
 710     unfilelock();
 711 }
 712
 713 =head1 VERSIONS
 714
 715 The following functions are exported with the :versions tag
 716
 717 =head2 addfoundversions
 718
 719      addfoundversions($status,$package,$version,$isbinary);
 720
 721 All use of this should be phased out in favor of Debbugs::Control::fixed/found
 722
 723 =cut
 724
 725
 726 sub addfoundversions {
 727     my $data = shift;
 728     my $package = shift;
 729     my $version = shift;
 730     my $isbinary = shift;
 731     return unless defined $version;
 732     undef $package if $package =~ m[(?:\s|/)];
 733     my $source = $package;
 734     if ($package =~ s/^src://) {
 735         $isbinary = 0;
 736         $source = $package;
 737     }
 738
 739     if (defined $package and $isbinary) {
 740         my @srcinfo = binary_to_source(binary => $package,
 741                                        version => $version);
 742         if (@srcinfo) {
 743             # We know the source package(s). Use a fully-qualified version.
 744             addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 745             return;
 746         }
 747         # Otherwise, an unqualified version will have to do.
 748         undef $source;
 749     }
 750
 751     # Strip off various kinds of brain-damage.
 752     $version =~ s/;.*//;
 753     $version =~ s/ *\(.*\)//;
 754     $version =~ s/ +[A-Za-z].*//;
 755
 756     foreach my $ver (split /[,\s]+/, $version) {
 757         my $sver = defined($source) ? "$source/$ver" : '';
 758         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) {
 759             push @{$data->{found_versions}}, defined($source) ? $sver : $ver;
 760         }
 761         @{$data->{fixed_versions}} =
 762             grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}};
 763     }
 764 }
 765
 766 =head2 removefoundversions
 767
 768      removefoundversions($data,$package,$versiontoremove)
 769
 770 Removes found versions from $data
 771
 772 If a version is fully qualified (contains /) only versions matching
 773 exactly are removed. Otherwise, all versions matching the version
 774 number are removed.
 775
 776 Currently $package and $isbinary are entirely ignored, but accepted
 777 for backwards compatibilty.
 778
 779 =cut
 780
 781 sub removefoundversions {
 782     my $data = shift;
 783     my $package = shift;
 784     my $version = shift;
 785     my $isbinary = shift;
 786     return unless defined $version;
 787
 788     foreach my $ver (split /[,\s]+/, $version) {
 789          if ($ver =~ m{/}) {
 790               # fully qualified version
 791               @{$data->{found_versions}} =
 792                    grep {$_ ne $ver}
 793                         @{$data->{found_versions}};
 794          }
 795          else {
 796               # non qualified version; delete all matchers
 797               @{$data->{found_versions}} =
 798                    grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
 799                         @{$data->{found_versions}};
 800          }
 801     }
 802 }
 803
 804
 805 sub addfixedversions {
 806     my $data = shift;
 807     my $package = shift;
 808     my $version = shift;
 809     my $isbinary = shift;
 810     return unless defined $version;
 811     undef $package if defined $package and $package =~ m[(?:\s|/)];
 812     my $source = $package;
 813
 814     if (defined $package and $isbinary) {
 815         my @srcinfo = binary_to_source(binary => $package,
 816                                        version => $version);
 817         if (@srcinfo) {
 818             # We know the source package(s). Use a fully-qualified version.
 819             addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo;
 820             return;
 821         }
 822         # Otherwise, an unqualified version will have to do.
 823         undef $source;
 824     }
 825
 826     # Strip off various kinds of brain-damage.
 827     $version =~ s/;.*//;
 828     $version =~ s/ *\(.*\)//;
 829     $version =~ s/ +[A-Za-z].*//;
 830
 831     foreach my $ver (split /[,\s]+/, $version) {
 832         my $sver = defined($source) ? "$source/$ver" : '';
 833         unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) {
 834             push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver;
 835         }
 836         @{$data->{found_versions}} =
 837             grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}};
 838     }
 839 }
 840
 841 sub removefixedversions {
 842     my $data = shift;
 843     my $package = shift;
 844     my $version = shift;
 845     my $isbinary = shift;
 846     return unless defined $version;
 847
 848     foreach my $ver (split /[,\s]+/, $version) {
 849          if ($ver =~ m{/}) {
 850               # fully qualified version
 851               @{$data->{fixed_versions}} =
 852                    grep {$_ ne $ver}
 853                         @{$data->{fixed_versions}};
 854          }
 855          else {
 856               # non qualified version; delete all matchers
 857               @{$data->{fixed_versions}} =
 858                    grep {$_ !~ m[(?:^|/)\Q$ver\E$]}
 859                         @{$data->{fixed_versions}};
 860          }
 861     }
 862 }
 863
 864
 865
 866 =head2 splitpackages
 867
 868      splitpackages($pkgs)
 869
 870 Split a package string from the status file into a list of package names.
 871
 872 =cut
 873
 874 sub splitpackages {
 875     my $pkgs = shift;
 876     return unless defined $pkgs;
 877     return grep {length $_} map lc, split /[\s,()?]+/, $pkgs;
 878 }
 879
 880
 881 =head2 bug_archiveable
 882
 883      bug_archiveable(bug => $bug_num);
 884
 885 Options
 886
 887 =over
 888
 889 =item bug -- bug number (required)
 890
 891 =item status -- Status hashref returned by read_bug or get_bug_status (optional)
 892
 893 =item version -- Debbugs::Version information (optional)
 894
 895 =item days_until -- return days until the bug can be archived
 896
 897 =back
 898
 899 Returns 1 if the bug can be archived
 900 Returns 0 if the bug cannot be archived
 901
 902 If days_until is true, returns the number of days until the bug can be
 903 archived, -1 if it cannot be archived. 0 means that the bug can be
 904 archived the next time the archiver runs.
 905
 906 Returns undef on failure.
 907
 908 =cut
 909
 910 # This will eventually need to be fixed before we start using mod_perl
 911 our $version_cache = {};
 912 sub bug_archiveable{
 913      my %param = validate_with(params => \@_,
 914                                spec   => {bug => {type => SCALAR,
 915                                                   regex => qr/^\d+$/,
 916                                                  },
 917                                           status => {type => HASHREF,
 918                                                      optional => 1,
 919                                                     },
 920                                           days_until => {type => BOOLEAN,
 921                                                          default => 0,
 922                                                         },
 923                                           ignore_time => {type => BOOLEAN,
 924                                                           default => 0,
 925                                                          },
 926                                          },
 927                               );
 928      # This is what we return if the bug cannot be archived.
 929      my $cannot_archive = $param{days_until}?-1:0;
 930      # read the status information
 931      my $status = $param{status};
 932      if (not exists $param{status} or not defined $status) {
 933           $status = read_bug(bug=>$param{bug});
 934           if (not defined $status) {
 935                print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG;
 936                return undef;
 937           }
 938      }
 939      # Bugs can be archived if they are
 940      # 1. Closed
 941      if (not defined $status->{done} or not length $status->{done}) {
 942           print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG;
 943           return $cannot_archive
 944      }
 945      # Check to make sure that the bug has none of the unremovable tags set
 946      if (@{$config{removal_unremovable_tags}}) {
 947           for my $tag (split ' ', ($status->{keywords}||'')) {
 948                if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) {
 949                     print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG;
 950                     return $cannot_archive;
 951                }
 952           }
 953      }
 954
 955      # If we just are checking if the bug can be archived, we'll not even bother
 956      # checking the versioning information if the bug has been -done for less than 28 days.
 957      my $log_file = getbugcomponent($param{bug},'log');
 958      if (not defined $log_file) {
 959           print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG;
 960           return $cannot_archive;
 961      }
 962      my $max_log_age = max(map {$config{remove_age} - -M $_}
 963                            $log_file, map {my $log = getbugcomponent($_,'log');
 964                                            defined $log ? ($log) : ();
 965                                       }
 966                            split / /, $status->{mergedwith}
 967                        );
 968      if (not $param{days_until} and not $param{ignore_time}
 969          and $max_log_age > 0
 970         ) {
 971           print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG;
 972           return $cannot_archive;
 973      }
 974      # At this point, we have to get the versioning information for this bug.
 975      # We examine the set of distribution tags. If a bug has no distribution
 976      # tags set, we assume a default set, otherwise we use the tags the bug
 977      # has set.
 978
 979      # In cases where we are assuming a default set, if the severity
 980      # is strong, we use the strong severity default; otherwise, we
 981      # use the normal default.
 982
 983      # There must be fixed_versions for us to look at the versioning
 984      # information
 985      my $min_fixed_time = time;
 986      my $min_archive_days = 0;
 987      if (@{$status->{fixed_versions}}) {
 988           my %dist_tags;
 989           @dist_tags{@{$config{removal_distribution_tags}}} =
 990                (1) x @{$config{removal_distribution_tags}};
 991           my %dists;
 992           for my $tag (split ' ', ($status->{keywords}||'')) {
 993                next unless exists $config{distribution_aliases}{$tag};
 994                next unless $dist_tags{$config{distribution_aliases}{$tag}};
 995                $dists{$config{distribution_aliases}{$tag}} = 1;
 996           }
 997           if (not keys %dists) {
 998                if (isstrongseverity($status->{severity})) {
 999                     @dists{@{$config{removal_strong_severity_default_distribution_tags}}} =
1000                          (1) x @{$config{removal_strong_severity_default_distribution_tags}};
1001                }
1002                else {
1003                     @dists{@{$config{removal_default_distribution_tags}}} =
1004                          (1) x @{$config{removal_default_distribution_tags}};
1005                }
1006           }
1007           my %source_versions;
1008           my @sourceversions = get_versions(package => $status->{package},
1009                                             dist => [keys %dists],
1010                                             source => 1,
1011                                            );
1012           @source_versions{@sourceversions} = (1) x @sourceversions;
1013           # If the bug has not been fixed in the versions actually
1014           # distributed, then it cannot be archived.
1015           if ('found' eq max_buggy(bug => $param{bug},
1016                                    sourceversions => [keys %source_versions],
1017                                    found          => $status->{found_versions},
1018                                    fixed          => $status->{fixed_versions},
1019                                    version_cache  => $version_cache,
1020                                    package        => $status->{package},
1021                                   )) {
1022                print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG;
1023                return $cannot_archive;
1024           }
1025           # Since the bug has at least been fixed in the architectures
1026           # that matters, we check to see how long it has been fixed.
1027
1028           # If $param{ignore_time}, then we should ignore time.
1029           if ($param{ignore_time}) {
1030                return $param{days_until}?0:1;
1031           }
1032
1033           # To do this, we order the times from most recent to oldest;
1034           # when we come to the first found version, we stop.
1035           # If we run out of versions, we only report the time of the
1036           # last one.
1037           my %time_versions = get_versions(package => $status->{package},
1038                                            dist    => [keys %dists],
1039                                            source  => 1,
1040                                            time    => 1,
1041                                           );
1042           for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) {
1043                my $buggy = buggy(bug => $param{bug},
1044                                  version        => $version,
1045                                  found          => $status->{found_versions},
1046                                  fixed          => $status->{fixed_versions},
1047                                  version_cache  => $version_cache,
1048                                  package        => $status->{package},
1049                                 );
1050                last if $buggy eq 'found';
1051                $min_fixed_time = min($time_versions{$version},$min_fixed_time);
1052           }
1053           $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24)))
1054                # if there are no versions in the archive at all, then
1055                # we can archive if enough days have passed
1056                if @sourceversions;
1057      }
1058      # If $param{ignore_time}, then we should ignore time.
1059      if ($param{ignore_time}) {
1060           return $param{days_until}?0:1;
1061      }
1062      # 6. at least 28 days have passed since the last action has occured or the bug was closed
1063      my $age = ceil($max_log_age);
1064      if ($age > 0 or $min_archive_days > 0) {
1065           print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG;
1066           return $param{days_until}?max($age,$min_archive_days):0;
1067      }
1068      else {
1069           return $param{days_until}?0:1;
1070      }
1071 }
1072
1073
1074 =head2 get_bug_status
1075
1076      my $status = get_bug_status(bug => $nnn);
1077
1078      my $status = get_bug_status($bug_num)
1079
1080 =head3 Options
1081
1082 =over
1083
1084 =item bug -- scalar bug number
1085
1086 =item status -- optional hashref of bug status as returned by readbug
1087 (can be passed to avoid rereading the bug information)
1088
1089 =item bug_index -- optional tied index of bug status infomration;
1090 currently not correctly implemented.
1091
1092 =item version -- optional version(s) to check package status at
1093
1094 =item dist -- optional distribution(s) to check package status at
1095
1096 =item arch -- optional architecture(s) to check package status at
1097
1098 =item bugusertags -- optional hashref of bugusertags
1099
1100 =item sourceversion -- optional arrayref of source/version; overrides
1101 dist, arch, and version. [The entries in this array must be in the
1102 "source/version" format.] Eventually this can be used to for caching.
1103
1104 =item indicatesource -- if true, indicate which source packages this
1105 bug could belong to (or does belong to in the case of bugs assigned to
1106 a source package). Defaults to true.
1107
1108 =back
1109
1110 Note: Currently the version information is cached; this needs to be
1111 changed before using this function in long lived programs.
1112
1113 =head3 Returns
1114
1115 Currently returns a hashref of status with the following keys.
1116
1117 =over
1118
1119 =item id -- bug number
1120
1121 =item bug_num -- duplicate of id
1122
1123 =item keywords -- tags set on the bug, including usertags if bugusertags passed.
1124
1125 =item tags -- duplicate of keywords
1126
1127 =item package -- name of package that the bug is assigned to
1128
1129 =item severity -- severity of the bug
1130
1131 =item pending -- pending state of the bug; one of following possible
1132 values; values listed later have precedence if multiple conditions are
1133 satisifed:
1134
1135 =over
1136
1137 =item pending -- default state
1138
1139 =item forwarded -- bug has been forwarded
1140
1141 =item pending-fixed -- bug is tagged pending
1142
1143 =item fixed -- bug is tagged fixed
1144
1145 =item absent -- bug does not apply to this distribution/architecture
1146
1147 =item done -- bug is resolved in this distribution/architecture
1148
1149 =back
1150
1151 =item location -- db-h or archive; the location in the filesystem
1152
1153 =item subject -- title of the bug
1154
1155 =item last_modified -- epoch that the bug was last modified
1156
1157 =item date -- epoch that the bug was filed
1158
1159 =item originator -- bug reporter
1160
1161 =item log_modified -- epoch that the log file was last modified
1162
1163 =item msgid -- Message id of the original bug report
1164
1165 =back
1166
1167
1168 Other key/value pairs are returned but are not currently documented here.
1169
1170 =cut
1171
1172 sub get_bug_status {
1173      if (@_ == 1) {
1174           unshift @_, 'bug';
1175      }
1176      my %param = validate_with(params => \@_,
1177                                spec   => {bug       => {type => SCALAR,
1178                                                         regex => qr/^\d+$/,
1179                                                        },
1180                                           status    => {type => HASHREF,
1181                                                         optional => 1,
1182                                                        },
1183                                           bug_index => {type => OBJECT,
1184                                                         optional => 1,
1185                                                        },
1186                                           version   => {type => SCALAR|ARRAYREF,
1187                                                         optional => 1,
1188                                                        },
1189                                           dist       => {type => SCALAR|ARRAYREF,
1190                                                          optional => 1,
1191                                                         },
1192                                           arch       => {type => SCALAR|ARRAYREF,
1193                                                          optional => 1,
1194                                                         },
1195                                           bugusertags   => {type => HASHREF,
1196                                                             optional => 1,
1197                                                            },
1198                                           sourceversions => {type => ARRAYREF,
1199                                                              optional => 1,
1200                                                             },
1201                                           indicatesource => {type => BOOLEAN,
1202                                                              default => 1,
1203                                                             },
1204                                          },
1205                               );
1206      my %status;
1207
1208      if (defined $param{bug_index} and
1209          exists $param{bug_index}{$param{bug}}) {
1210           %status = %{ $param{bug_index}{$param{bug}} };
1211           $status{pending} = $status{ status };
1212           $status{id} = $param{bug};
1213           return \%status;
1214      }
1215      if (defined $param{status}) {
1216           %status = %{$param{status}};
1217      }
1218      else {
1219           my $location = getbuglocation($param{bug}, 'summary');
1220           return {} if not defined $location or not length $location;
1221           %status = %{ readbug( $param{bug}, $location ) };
1222      }
1223      $status{id} = $param{bug};
1224
1225      if (defined $param{bugusertags}{$param{bug}}) {
1226           $status{keywords} = "" unless defined $status{keywords};
1227           $status{keywords} .= " " unless $status{keywords} eq "";
1228           $status{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}});
1229      }
1230      $status{tags} = $status{keywords};
1231      my %tags = map { $_ => 1 } split ' ', $status{tags};
1232
1233      $status{package} = '' if not defined $status{package};
1234      $status{"package"} =~ s/\s*$//;
1235
1236      $status{source} = binary_to_source(binary=>[split /\s*,\s*/, $status{package}],
1237                                         source_only => 1,
1238                                        );
1239
1240      $status{"package"} = 'unknown' if ($status{"package"} eq '');
1241      $status{"severity"} = 'normal' if (not defined $status{severity} or $status{"severity"} eq '');
1242
1243      $status{"pending"} = 'pending';
1244      $status{"pending"} = 'forwarded'       if (length($status{"forwarded"}));
1245      $status{"pending"} = 'pending-fixed'    if ($tags{pending});
1246      $status{"pending"} = 'fixed'           if ($tags{fixed});
1247
1248
1249      my $presence = bug_presence(status => \%status,
1250                                  map{(exists $param{$_})?($_,$param{$_}):()}
1251                                  qw(bug sourceversions arch dist version found fixed package)
1252                                 );
1253      if (defined $presence) {
1254           if ($presence eq 'fixed') {
1255                $status{pending} = 'done';
1256           }
1257           elsif ($presence eq 'absent') {
1258                $status{pending} = 'absent';
1259           }
1260      }
1261      return \%status;
1262 }
1263
1264 =head2 bug_presence
1265
1266      my $precence = bug_presence(bug => nnn,
1267                                  ...
1268                                 );
1269
1270 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1271 is found, absent, fixed, or no information is available in the
1272 distribution (dist) and/or architecture (arch) specified.
1273
1274
1275 =head3 Options
1276
1277 =over
1278
1279 =item bug -- scalar bug number
1280
1281 =item status -- optional hashref of bug status as returned by readbug
1282 (can be passed to avoid rereading the bug information)
1283
1284 =item bug_index -- optional tied index of bug status infomration;
1285 currently not correctly implemented.
1286
1287 =item version -- optional version to check package status at
1288
1289 =item dist -- optional distribution to check package status at
1290
1291 =item arch -- optional architecture to check package status at
1292
1293 =item sourceversion -- optional arrayref of source/version; overrides
1294 dist, arch, and version. [The entries in this array must be in the
1295 "source/version" format.] Eventually this can be used to for caching.
1296
1297 =back
1298
1299 =cut
1300
1301 sub bug_presence {
1302      my %param = validate_with(params => \@_,
1303                                spec   => {bug       => {type => SCALAR,
1304                                                         regex => qr/^\d+$/,
1305                                                        },
1306                                           status    => {type => HASHREF,
1307                                                         optional => 1,
1308                                                        },
1309                                           version   => {type => SCALAR|ARRAYREF,
1310                                                         optional => 1,
1311                                                        },
1312                                           dist       => {type => SCALAR|ARRAYREF,
1313                                                          optional => 1,
1314                                                         },
1315                                           arch       => {type => SCALAR|ARRAYREF,
1316                                                          optional => 1,
1317                                                         },
1318                                           sourceversions => {type => ARRAYREF,
1319                                                              optional => 1,
1320                                                             },
1321                                          },
1322                               );
1323      my %status;
1324      if (defined $param{status}) {
1325          %status = %{$param{status}};
1326      }
1327      else {
1328           my $location = getbuglocation($param{bug}, 'summary');
1329           return {} if not length $location;
1330           %status = %{ readbug( $param{bug}, $location ) };
1331      }
1332
1333      my @sourceversions;
1334      my $pseudo_desc = getpseudodesc();
1335      if (not exists $param{sourceversions}) {
1336           my %sourceversions;
1337           # pseudopackages do not have source versions by definition.
1338           if (exists $pseudo_desc->{$status{package}}) {
1339                # do nothing.
1340           }
1341           elsif (defined $param{version}) {
1342                foreach my $arch (make_list($param{arch})) {
1343                     for my $package (split /\s*,\s*/, $status{package}) {
1344                          my @temp = makesourceversions($package,
1345                                                        $arch,
1346                                                        make_list($param{version})
1347                                                       );
1348                          @sourceversions{@temp} = (1) x @temp;
1349                     }
1350                }
1351           } elsif (defined $param{dist}) {
1352                my %affects_distribution_tags;
1353                @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1354                     (1) x @{$config{affects_distribution_tags}};
1355                my $some_distributions_disallowed = 0;
1356                my %allowed_distributions;
1357                for my $tag (split ' ', ($status{keywords}||'')) {
1358                    if (exists $config{distribution_aliases}{$tag} and
1359                         exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1360                        $some_distributions_disallowed = 1;
1361                        $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1362                    }
1363                    elsif (exists $affects_distribution_tags{$tag}) {
1364                        $some_distributions_disallowed = 1;
1365                        $allowed_distributions{$tag} = 1;
1366                    }
1367                }
1368                my @archs = make_list(exists $param{arch}?$param{arch}:());
1369            GET_SOURCE_VERSIONS:
1370                foreach my $arch (@archs) {
1371                    for my $package (split /\s*,\s*/, $status{package}) {
1372                          my @versions = ();
1373                          my $source = 0;
1374                          if ($package =~ /^src:(.+)$/) {
1375                              $source = 1;
1376                              $package = $1;
1377                          }
1378                          foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1379                               # if some distributions are disallowed,
1380                               # and this isn't an allowed
1381                               # distribution, then we ignore this
1382                               # distribution for the purposees of
1383                               # finding versions
1384                               if ($some_distributions_disallowed and
1385                                   not exists $allowed_distributions{$dist}) {
1386                                    next;
1387                               }
1388                               push @versions, get_versions(package => $package,
1389                                                            dist    => $dist,
1390                                                            ($source?(arch => 'source'):
1391                                                             (defined $arch?(arch => $arch):())),
1392                                                           );
1393                          }
1394                          next unless @versions;
1395                          my @temp = make_source_versions(package => $package,
1396                                                          arch => $arch,
1397                                                          versions => \@versions,
1398                                                         );
1399                          @sourceversions{@temp} = (1) x @temp;
1400                     }
1401                }
1402                # this should really be split out into a subroutine,
1403                # but it'd touch so many things currently, that we fake
1404                # it; it's needed to properly handle bugs which are
1405                # erroneously assigned to the binary package, and we'll
1406                # probably have it go away eventually.
1407                if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1408                    @archs = (undef);
1409                    goto GET_SOURCE_VERSIONS;
1410                }
1411           }
1412
1413           # TODO: This should probably be handled further out for efficiency and
1414           # for more ease of distinguishing between pkg= and src= queries.
1415           # DLA: src= queries should just pass arch=source, and they'll be happy.
1416           @sourceversions = keys %sourceversions;
1417      }
1418      else {
1419           @sourceversions = @{$param{sourceversions}};
1420      }
1421      my $maxbuggy = 'undef';
1422      if (@sourceversions) {
1423           $maxbuggy = max_buggy(bug => $param{bug},
1424                                 sourceversions => \@sourceversions,
1425                                 found => $status{found_versions},
1426                                 fixed => $status{fixed_versions},
1427                                 package => $status{package},
1428                                 version_cache => $version_cache,
1429                                );
1430      }
1431      elsif (defined $param{dist} and
1432             not exists $pseudo_desc->{$status{package}}) {
1433           return 'absent';
1434      }
1435      if (length($status{done}) and
1436          (not @sourceversions or not @{$status{fixed_versions}})) {
1437           return 'fixed';
1438      }
1439      return $maxbuggy;
1440 }
1441
1442
1443 =head2 max_buggy
1444
1445      max_buggy()
1446
1447 =head3 Options
1448
1449 =over
1450
1451 =item bug -- scalar bug number
1452
1453 =item sourceversion -- optional arrayref of source/version; overrides
1454 dist, arch, and version. [The entries in this array must be in the
1455 "source/version" format.] Eventually this can be used to for caching.
1456
1457 =back
1458
1459 Note: Currently the version information is cached; this needs to be
1460 changed before using this function in long lived programs.
1461
1462
1463 =cut
1464 sub max_buggy{
1465      my %param = validate_with(params => \@_,
1466                                spec   => {bug       => {type => SCALAR,
1467                                                         regex => qr/^\d+$/,
1468                                                        },
1469                                           sourceversions => {type => ARRAYREF,
1470                                                              default => [],
1471                                                             },
1472                                           found          => {type => ARRAYREF,
1473                                                              default => [],
1474                                                             },
1475                                           fixed          => {type => ARRAYREF,
1476                                                              default => [],
1477                                                             },
1478                                           package        => {type => SCALAR,
1479                                                             },
1480                                           version_cache  => {type => HASHREF,
1481                                                              default => {},
1482                                                             },
1483                                          },
1484                               );
1485      # Resolve bugginess states (we might be looking at multiple
1486      # architectures, say). Found wins, then fixed, then absent.
1487      my $maxbuggy = 'absent';
1488      for my $package (split /\s*,\s*/, $param{package}) {
1489           for my $version (@{$param{sourceversions}}) {
1490                my $buggy = buggy(bug => $param{bug},
1491                                  version => $version,
1492                                  found => $param{found},
1493                                  fixed => $param{fixed},
1494                                  version_cache => $param{version_cache},
1495                                  package => $package,
1496                                 );
1497                if ($buggy eq 'found') {
1498                     return 'found';
1499                } elsif ($buggy eq 'fixed') {
1500                     $maxbuggy = 'fixed';
1501                }
1502           }
1503      }
1504      return $maxbuggy;
1505 }
1506
1507
1508 =head2 buggy
1509
1510      buggy(bug => nnn,
1511            found => \@found,
1512            fixed => \@fixed,
1513            package => 'foo',
1514            version => '1.0',
1515           );
1516
1517 Returns the output of Debbugs::Versions::buggy for a particular
1518 package, version and found/fixed set. Automatically turns found, fixed
1519 and version into source/version strings.
1520
1521 Caching can be had by using the version_cache, but no attempt to check
1522 to see if the on disk information is more recent than the cache is
1523 made. [This will need to be fixed for long-lived processes.]
1524
1525 =cut
1526
1527 sub buggy {
1528      my %param = validate_with(params => \@_,
1529                                spec   => {bug => {type => SCALAR,
1530                                                   regex => qr/^\d+$/,
1531                                                  },
1532                                           found => {type => ARRAYREF,
1533                                                     default => [],
1534                                                    },
1535                                           fixed => {type => ARRAYREF,
1536                                                     default => [],
1537                                                    },
1538                                           version_cache => {type => HASHREF,
1539                                                             optional => 1,
1540                                                            },
1541                                           package => {type => SCALAR,
1542                                                      },
1543                                           version => {type => SCALAR,
1544                                                      },
1545                                          },
1546                               );
1547      my @found = @{$param{found}};
1548      my @fixed = @{$param{fixed}};
1549      if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1550           # We have non-source version versions
1551           @found = makesourceversions($param{package},undef,
1552                                       @found
1553                                      );
1554           @fixed = makesourceversions($param{package},undef,
1555                                       @fixed
1556                                      );
1557      }
1558      if ($param{version} !~ m{/}) {
1559           my ($version) = makesourceversions($param{package},undef,
1560                                              $param{version}
1561                                             );
1562           $param{version} = $version if defined $version;
1563      }
1564      # Figure out which source packages we need
1565      my %sources;
1566      @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1567      @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1568      @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1569           $param{version} =~ m{/};
1570      my $version;
1571      if (not defined $param{version_cache} or
1572          not exists $param{version_cache}{join(',',sort keys %sources)}) {
1573           $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1574           foreach my $source (keys %sources) {
1575                my $srchash = substr $source, 0, 1;
1576                my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1577                if (not defined $version_fh) {
1578                     # We only want to warn if it's a package which actually has a maintainer
1579                     my $maints = getmaintainers();
1580                     next if not exists $maints->{$source};
1581                     warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1582                     next;
1583                }
1584                $version->load($version_fh);
1585           }
1586           if (defined $param{version_cache}) {
1587                $param{version_cache}{join(',',sort keys %sources)} = $version;
1588           }
1589      }
1590      else {
1591           $version = $param{version_cache}{join(',',sort keys %sources)};
1592      }
1593      return $version->buggy($param{version},\@found,\@fixed);
1594 }
1595
1596 sub isstrongseverity {
1597     my $severity = shift;
1598     $severity = $config{default_severity} if
1599          not defined $severity or $severity eq '';
1600     return grep { $_ eq $severity } @{$config{strong_severities}};
1601 }
1602
1603 =head1 indexdb
1604
1605 =head2 generate_index_db_line
1606
1607         my $data = read_bug(bug => $bug,
1608                             location => $initialdir);
1609         # generate_index_db_line hasn't been written yet at all.
1610         my $line = generate_index_db_line($data);
1611
1612 Returns a line for a bug suitable to be written out to index.db.
1613
1614 =cut
1615
1616 sub generate_index_db_line {
1617     my ($data) = @_;
1618
1619     # just in case someone has given us a split out data
1620     $data = join_status_fields($data);
1621
1622     my $whendone = "open";
1623     my $severity = $config{default_severity};
1624     (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1625     $pkglist =~ s/^,+//;
1626     $pkglist =~ s/,+$//;
1627     $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1628     $whendone = "done" if defined $data->{done} and length $data->{done};
1629     $severity = $data->{severity} if length $data->{severity};
1630
1631     return sprintf "%s %d %d %s [%s] %s %s\n",
1632         $pkglist, $data->{bug_num}, $data->{date}, $whendone,
1633             $data->{originator}, $severity, $data->{keywords};
1634 }
1635
1636
1637
1638 =head1 PRIVATE FUNCTIONS
1639
1640 =cut
1641
1642 sub update_realtime {
1643         my ($file, %bugs) = @_;
1644
1645         # update realtime index.db
1646
1647         return () unless keys %bugs;
1648         my $idx_old = IO::File->new($file,'r')
1649              or die "Couldn't open ${file}: $!";
1650         my $idx_new = IO::File->new($file.'.new','w')
1651              or die "Couldn't open ${file}.new: $!";
1652
1653         binmode($idx_old,':raw:utf8');
1654         binmode($idx_new,':raw:encoding(UTF-8)');
1655         my $min_bug = min(keys %bugs);
1656         my $line;
1657         my @line;
1658         my %changed_bugs;
1659         while($line = <$idx_old>) {
1660              @line = split /\s/, $line;
1661              # Two cases; replacing existing line or adding new line
1662              if (exists $bugs{$line[1]}) {
1663                   my $new = $bugs{$line[1]};
1664                   delete $bugs{$line[1]};
1665                   $min_bug = min(keys %bugs);
1666                   if ($new eq "NOCHANGE") {
1667                        print {$idx_new} $line;
1668                        $changed_bugs{$line[1]} = $line;
1669                   } elsif ($new eq "REMOVE") {
1670                        $changed_bugs{$line[1]} = $line;
1671                   } else {
1672                        print {$idx_new} $new;
1673                        $changed_bugs{$line[1]} = $line;
1674                   }
1675              }
1676              else {
1677                   while ($line[1] > $min_bug) {
1678                        print {$idx_new} $bugs{$min_bug};
1679                        delete $bugs{$min_bug};
1680                        last unless keys %bugs;
1681                        $min_bug = min(keys %bugs);
1682                   }
1683                   print {$idx_new} $line;
1684              }
1685              last unless keys %bugs;
1686         }
1687         print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1688
1689         print {$idx_new} <$idx_old>;
1690
1691         close($idx_new);
1692         close($idx_old);
1693
1694         rename("$file.new", $file);
1695
1696         return %changed_bugs;
1697 }
1698
1699 sub bughook_archive {
1700         my @refs = @_;
1701         filelock("$config{spool_dir}/debbugs.trace.lock");
1702         appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1703         my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1704                                    map{($_,'REMOVE')} @refs);
1705         update_realtime("$config{spool_dir}/index.archive.realtime",
1706                         %bugs);
1707         unfilelock();
1708 }
1709
1710 sub bughook {
1711         my ( $type, %bugs_temp ) = @_;
1712         filelock("$config{spool_dir}/debbugs.trace.lock");
1713
1714         my %bugs;
1715         for my $bug (keys %bugs_temp) {
1716              my $data = $bugs_temp{$bug};
1717              appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1718
1719              $bugs{$bug} = generate_index_db_line($data);
1720         }
1721         update_realtime("$config{spool_dir}/index.db.realtime", %bugs);
1722
1723         unfilelock();
1724 }
1725
1726
1727 1;
1728
1729 __END__