Debbugs/Status.pm

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