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