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