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->{source} = binary_to_source(binary=>[split /\s*,\s*/, $status->{package}],
1405                                               source_only => 1,
1406                                               cache => $bin_to_src_cache,
1407                                               defined $param{schema}?
1408                                               (schema => $param{schema}):(),
1409                                              );
1410
1411          $status->{"package"} = 'unknown' if ($status->{"package"} eq '');
1412          $status->{"severity"} = 'normal' if (not defined $status->{severity} or $status->{"severity"} eq '');
1413
1414          $status->{"pending"} = 'pending';
1415          $status->{"pending"} = 'forwarded'         if (length($status->{"forwarded"}));
1416          $status->{"pending"} = 'pending-fixed'    if ($tags{pending});
1417          $status->{"pending"} = 'fixed'     if ($tags{fixed});
1418
1419
1420          my $presence = bug_presence(status => $status,
1421                                      bug => $bug,
1422                                      map{(exists $param{$_})?($_,$param{$_}):()}
1423                                      qw(sourceversions arch dist version found fixed package)
1424                                     );
1425          if (defined $presence) {
1426              if ($presence eq 'fixed') {
1427                  $status->{pending} = 'done';
1428              } elsif ($presence eq 'absent') {
1429                  $status->{pending} = 'absent';
1430              }
1431          }
1432      }
1433      return \%statuses;
1434 }
1435
1436 =head2 bug_presence
1437
1438      my $precence = bug_presence(bug => nnn,
1439                                  ...
1440                                 );
1441
1442 Returns 'found', 'absent', 'fixed' or undef based on whether the bug
1443 is found, absent, fixed, or no information is available in the
1444 distribution (dist) and/or architecture (arch) specified.
1445
1446
1447 =head3 Options
1448
1449 =over
1450
1451 =item bug -- scalar bug number
1452
1453 =item status -- optional hashref of bug status as returned by readbug
1454 (can be passed to avoid rereading the bug information)
1455
1456 =item bug_index -- optional tied index of bug status infomration;
1457 currently not correctly implemented.
1458
1459 =item version -- optional version to check package status at
1460
1461 =item dist -- optional distribution to check package status at
1462
1463 =item arch -- optional architecture to check package status at
1464
1465 =item sourceversion -- optional arrayref of source/version; overrides
1466 dist, arch, and version. [The entries in this array must be in the
1467 "source/version" format.] Eventually this can be used to for caching.
1468
1469 =back
1470
1471 =cut
1472
1473 sub bug_presence {
1474      my %param = validate_with(params => \@_,
1475                                spec   => {bug       => {type => SCALAR,
1476                                                         regex => qr/^\d+$/,
1477                                                        },
1478                                           status    => {type => HASHREF,
1479                                                         optional => 1,
1480                                                        },
1481                                           version   => {type => SCALAR|ARRAYREF,
1482                                                         optional => 1,
1483                                                        },
1484                                           dist       => {type => SCALAR|ARRAYREF,
1485                                                          optional => 1,
1486                                                         },
1487                                           arch       => {type => SCALAR|ARRAYREF,
1488                                                          optional => 1,
1489                                                         },
1490                                           sourceversions => {type => ARRAYREF,
1491                                                              optional => 1,
1492                                                             },
1493                                          },
1494                               );
1495      my %status;
1496      if (defined $param{status}) {
1497          %status = %{$param{status}};
1498      }
1499      else {
1500           my $location = getbuglocation($param{bug}, 'summary');
1501           return {} if not length $location;
1502           %status = %{ readbug( $param{bug}, $location ) };
1503      }
1504
1505      my @sourceversions;
1506      my $pseudo_desc = getpseudodesc();
1507      if (not exists $param{sourceversions}) {
1508           my %sourceversions;
1509           # pseudopackages do not have source versions by definition.
1510           if (exists $pseudo_desc->{$status{package}}) {
1511                # do nothing.
1512           }
1513           elsif (defined $param{version}) {
1514                foreach my $arch (make_list($param{arch})) {
1515                     for my $package (split /\s*,\s*/, $status{package}) {
1516                          my @temp = makesourceversions($package,
1517                                                        $arch,
1518                                                        make_list($param{version})
1519                                                       );
1520                          @sourceversions{@temp} = (1) x @temp;
1521                     }
1522                }
1523           } elsif (defined $param{dist}) {
1524                my %affects_distribution_tags;
1525                @affects_distribution_tags{@{$config{affects_distribution_tags}}} =
1526                     (1) x @{$config{affects_distribution_tags}};
1527                my $some_distributions_disallowed = 0;
1528                my %allowed_distributions;
1529                for my $tag (split ' ', ($status{keywords}||'')) {
1530                    if (exists $config{distribution_aliases}{$tag} and
1531                         exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) {
1532                        $some_distributions_disallowed = 1;
1533                        $allowed_distributions{$config{distribution_aliases}{$tag}} = 1;
1534                    }
1535                    elsif (exists $affects_distribution_tags{$tag}) {
1536                        $some_distributions_disallowed = 1;
1537                        $allowed_distributions{$tag} = 1;
1538                    }
1539                }
1540                my @archs = make_list(exists $param{arch}?$param{arch}:());
1541            GET_SOURCE_VERSIONS:
1542                foreach my $arch (@archs) {
1543                    for my $package (split /\s*,\s*/, $status{package}) {
1544                          my @versions = ();
1545                          my $source = 0;
1546                          if ($package =~ /^src:(.+)$/) {
1547                              $source = 1;
1548                              $package = $1;
1549                          }
1550                          foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) {
1551                               # if some distributions are disallowed,
1552                               # and this isn't an allowed
1553                               # distribution, then we ignore this
1554                               # distribution for the purposees of
1555                               # finding versions
1556                               if ($some_distributions_disallowed and
1557                                   not exists $allowed_distributions{$dist}) {
1558                                    next;
1559                               }
1560                               push @versions, get_versions(package => $package,
1561                                                            dist    => $dist,
1562                                                            ($source?(arch => 'source'):
1563                                                             (defined $arch?(arch => $arch):())),
1564                                                           );
1565                          }
1566                          next unless @versions;
1567                          my @temp = make_source_versions(package => $package,
1568                                                          arch => $arch,
1569                                                          versions => \@versions,
1570                                                         );
1571                          @sourceversions{@temp} = (1) x @temp;
1572                     }
1573                }
1574                # this should really be split out into a subroutine,
1575                # but it'd touch so many things currently, that we fake
1576                # it; it's needed to properly handle bugs which are
1577                # erroneously assigned to the binary package, and we'll
1578                # probably have it go away eventually.
1579                if (not keys %sourceversions and (not @archs or defined $archs[0])) {
1580                    @archs = (undef);
1581                    goto GET_SOURCE_VERSIONS;
1582                }
1583           }
1584
1585           # TODO: This should probably be handled further out for efficiency and
1586           # for more ease of distinguishing between pkg= and src= queries.
1587           # DLA: src= queries should just pass arch=source, and they'll be happy.
1588           @sourceversions = keys %sourceversions;
1589      }
1590      else {
1591           @sourceversions = @{$param{sourceversions}};
1592      }
1593      my $maxbuggy = 'undef';
1594      if (@sourceversions) {
1595           $maxbuggy = max_buggy(bug => $param{bug},
1596                                 sourceversions => \@sourceversions,
1597                                 found => $status{found_versions},
1598                                 fixed => $status{fixed_versions},
1599                                 package => $status{package},
1600                                 version_cache => $version_cache,
1601                                );
1602      }
1603      elsif (defined $param{dist} and
1604             not exists $pseudo_desc->{$status{package}}) {
1605           return 'absent';
1606      }
1607      if (length($status{done}) and
1608          (not @sourceversions or not @{$status{fixed_versions}})) {
1609           return 'fixed';
1610      }
1611      return $maxbuggy;
1612 }
1613
1614
1615 =head2 max_buggy
1616
1617      max_buggy()
1618
1619 =head3 Options
1620
1621 =over
1622
1623 =item bug -- scalar bug number
1624
1625 =item sourceversion -- optional arrayref of source/version; overrides
1626 dist, arch, and version. [The entries in this array must be in the
1627 "source/version" format.] Eventually this can be used to for caching.
1628
1629 =back
1630
1631 Note: Currently the version information is cached; this needs to be
1632 changed before using this function in long lived programs.
1633
1634
1635 =cut
1636 sub max_buggy{
1637      my %param = validate_with(params => \@_,
1638                                spec   => {bug       => {type => SCALAR,
1639                                                         regex => qr/^\d+$/,
1640                                                        },
1641                                           sourceversions => {type => ARRAYREF,
1642                                                              default => [],
1643                                                             },
1644                                           found          => {type => ARRAYREF,
1645                                                              default => [],
1646                                                             },
1647                                           fixed          => {type => ARRAYREF,
1648                                                              default => [],
1649                                                             },
1650                                           package        => {type => SCALAR,
1651                                                             },
1652                                           version_cache  => {type => HASHREF,
1653                                                              default => {},
1654                                                             },
1655                                           schema => {type => OBJECT,
1656                                                      optional => 1,
1657                                                     },
1658                                          },
1659                               );
1660      # Resolve bugginess states (we might be looking at multiple
1661      # architectures, say). Found wins, then fixed, then absent.
1662      my $maxbuggy = 'absent';
1663      for my $package (split /\s*,\s*/, $param{package}) {
1664           for my $version (@{$param{sourceversions}}) {
1665                my $buggy = buggy(bug => $param{bug},
1666                                  version => $version,
1667                                  found => $param{found},
1668                                  fixed => $param{fixed},
1669                                  version_cache => $param{version_cache},
1670                                  package => $package,
1671                                 );
1672                if ($buggy eq 'found') {
1673                     return 'found';
1674                } elsif ($buggy eq 'fixed') {
1675                     $maxbuggy = 'fixed';
1676                }
1677           }
1678      }
1679      return $maxbuggy;
1680 }
1681
1682
1683 =head2 buggy
1684
1685      buggy(bug => nnn,
1686            found => \@found,
1687            fixed => \@fixed,
1688            package => 'foo',
1689            version => '1.0',
1690           );
1691
1692 Returns the output of Debbugs::Versions::buggy for a particular
1693 package, version and found/fixed set. Automatically turns found, fixed
1694 and version into source/version strings.
1695
1696 Caching can be had by using the version_cache, but no attempt to check
1697 to see if the on disk information is more recent than the cache is
1698 made. [This will need to be fixed for long-lived processes.]
1699
1700 =cut
1701
1702 sub buggy {
1703      my %param = validate_with(params => \@_,
1704                                spec   => {bug => {type => SCALAR,
1705                                                   regex => qr/^\d+$/,
1706                                                  },
1707                                           found => {type => ARRAYREF,
1708                                                     default => [],
1709                                                    },
1710                                           fixed => {type => ARRAYREF,
1711                                                     default => [],
1712                                                    },
1713                                           version_cache => {type => HASHREF,
1714                                                             optional => 1,
1715                                                            },
1716                                           package => {type => SCALAR,
1717                                                      },
1718                                           version => {type => SCALAR,
1719                                                      },
1720                                           schema => {type => OBJECT,
1721                                                      optional => 1,
1722                                                     },
1723                                          },
1724                               );
1725      my @found = @{$param{found}};
1726      my @fixed = @{$param{fixed}};
1727      if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) {
1728           # We have non-source version versions
1729           @found = makesourceversions($param{package},undef,
1730                                       @found
1731                                      );
1732           @fixed = makesourceversions($param{package},undef,
1733                                       @fixed
1734                                      );
1735      }
1736      if ($param{version} !~ m{/}) {
1737           my ($version) = makesourceversions($param{package},undef,
1738                                              $param{version}
1739                                             );
1740           $param{version} = $version if defined $version;
1741      }
1742      # Figure out which source packages we need
1743      my %sources;
1744      @sources{map {m{(.+)/}; $1} @found} = (1) x @found;
1745      @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed;
1746      @sources{map {m{(.+)/}; $1} $param{version}} = 1 if
1747           $param{version} =~ m{/};
1748      my $version;
1749      if (not defined $param{version_cache} or
1750          not exists $param{version_cache}{join(',',sort keys %sources)}) {
1751           $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp);
1752           foreach my $source (keys %sources) {
1753                my $srchash = substr $source, 0, 1;
1754                my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r');
1755                if (not defined $version_fh) {
1756                     # We only want to warn if it's a package which actually has a maintainer
1757                    my @maint = package_maintainer(source => $source,
1758                                                   hash_slice(%param,'schema'),
1759                                                  );
1760                     next unless @maint;
1761                     warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!";
1762                     next;
1763                }
1764                $version->load($version_fh);
1765           }
1766           if (defined $param{version_cache}) {
1767                $param{version_cache}{join(',',sort keys %sources)} = $version;
1768           }
1769      }
1770      else {
1771           $version = $param{version_cache}{join(',',sort keys %sources)};
1772      }
1773      return $version->buggy($param{version},\@found,\@fixed);
1774 }
1775
1776 sub isstrongseverity {
1777     my $severity = shift;
1778     $severity = $config{default_severity} if
1779          not defined $severity or $severity eq '';
1780     return grep { $_ eq $severity } @{$config{strong_severities}};
1781 }
1782
1783 =head1 indexdb
1784
1785 =head2 generate_index_db_line
1786
1787         my $data = read_bug(bug => $bug,
1788                             location => $initialdir);
1789         # generate_index_db_line hasn't been written yet at all.
1790         my $line = generate_index_db_line($data);
1791
1792 Returns a line for a bug suitable to be written out to index.db.
1793
1794 =cut
1795
1796 sub generate_index_db_line {
1797     my ($data,$bug) = @_;
1798
1799     # just in case someone has given us a split out data
1800     $data = join_status_fields($data);
1801
1802     my $whendone = "open";
1803     my $severity = $config{default_severity};
1804     (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g;
1805     $pkglist =~ s/^,+//;
1806     $pkglist =~ s/,+$//;
1807     $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded};
1808     $whendone = "done" if defined $data->{done} and length $data->{done};
1809     $severity = $data->{severity} if length $data->{severity};
1810     return sprintf "%s %d %d %s [%s] %s %s\n",
1811         $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone,
1812             $data->{originator}, $severity, $data->{keywords};
1813 }
1814
1815
1816
1817 =head1 PRIVATE FUNCTIONS
1818
1819 =cut
1820
1821 sub update_realtime {
1822         my ($file, %bugs) = @_;
1823
1824         # update realtime index.db
1825
1826         return () unless keys %bugs;
1827         my $idx_old = IO::File->new($file,'r')
1828              or die "Couldn't open ${file}: $!";
1829         my $idx_new = IO::File->new($file.'.new','w')
1830              or die "Couldn't open ${file}.new: $!";
1831
1832         binmode($idx_old,':raw:utf8');
1833         binmode($idx_new,':raw:encoding(UTF-8)');
1834         my $min_bug = min(keys %bugs);
1835         my $line;
1836         my @line;
1837         my %changed_bugs;
1838         while($line = <$idx_old>) {
1839              @line = split /\s/, $line;
1840              # Two cases; replacing existing line or adding new line
1841              if (exists $bugs{$line[1]}) {
1842                   my $new = $bugs{$line[1]};
1843                   delete $bugs{$line[1]};
1844                   $min_bug = min(keys %bugs);
1845                   if ($new eq "NOCHANGE") {
1846                        print {$idx_new} $line;
1847                        $changed_bugs{$line[1]} = $line;
1848                   } elsif ($new eq "REMOVE") {
1849                        $changed_bugs{$line[1]} = $line;
1850                   } else {
1851                        print {$idx_new} $new;
1852                        $changed_bugs{$line[1]} = $line;
1853                   }
1854              }
1855              else {
1856                   while ($line[1] > $min_bug) {
1857                        print {$idx_new} $bugs{$min_bug};
1858                        delete $bugs{$min_bug};
1859                        last unless keys %bugs;
1860                        $min_bug = min(keys %bugs);
1861                   }
1862                   print {$idx_new} $line;
1863              }
1864              last unless keys %bugs;
1865         }
1866         print {$idx_new} map {$bugs{$_}} sort keys %bugs;
1867
1868         print {$idx_new} <$idx_old>;
1869
1870         close($idx_new);
1871         close($idx_old);
1872
1873         rename("$file.new", $file);
1874
1875         return %changed_bugs;
1876 }
1877
1878 sub bughook_archive {
1879         my @refs = @_;
1880         filelock("$config{spool_dir}/debbugs.trace.lock");
1881         appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n");
1882         my %bugs = update_realtime("$config{spool_dir}/index.db.realtime",
1883                                    map{($_,'REMOVE')} @refs);
1884         update_realtime("$config{spool_dir}/index.archive.realtime",
1885                         %bugs);
1886         unfilelock();
1887 }
1888
1889 sub bughook {
1890         my ( $type, %bugs_temp ) = @_;
1891         filelock("$config{spool_dir}/debbugs.trace.lock");
1892
1893         my %bugs;
1894         for my $bug (keys %bugs_temp) {
1895              my $data = $bugs_temp{$bug};
1896              appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1));
1897
1898              $bugs{$bug} = generate_index_db_line($data,$bug);
1899         }
1900         update_realtime("$config{spool_dir}/index.db.realtime", %bugs);
1901
1902         unfilelock();
1903 }
1904
1905
1906 1;
1907
1908 __END__