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