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