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