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