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